I want to re-use a snapshot of a web response for testing an app that needs to do some web-scraping. What I tried to do is just save the response (from Chrome) and reload the the string from the file:
doc.body.innerHtml = StringFromFile
This doesn't work though, although it looks like good html. By not work, I mean data that is in tag "Table"(6) when going through the web is not found. Is there a better way to load the html doc?
The code below is an attempt to both save an existing doc to file and then reuse it. Its worthless but maybe it will help someone set me straight on this.
Cheers
Private Function GetEWhipersTestHtmlDoc() As HTMLDocument
Dim doc As HTMLDocument
Set doc = New HTMLDocument
Dim sText As String
sText = GetStringFromFile(GetFileName("UnconfirmedRelease"))
doc.body.innerHTML = sText
Set GetEWhipersTestHtmlDoc = doc
End Function
Private Function GetFileName(testName As String) As String
GetFileName = ThisWorkbook.path & Application.PathSeparator & _
"Earnings Whispers Test Scenarios" & Application.PathSeparator & testName & ".txt"
Debug.Assert Dir(GetFileName) <> ""
End Function
Private Function SaveHtmlStringToFile(testName As String, sInnerHtml As String) As String
Dim fso As Object
Dim oFile As Object
Dim sPath As String
Set fso = CreateObject("Scripting.FileSystemObject")
sPath = GetFileName(testName)
Set oFile = fso.CreateTextFile(sPath)
oFile.WriteLine sInnerHtml
oFile.Close
End Function
** UPDATE **
Saving doc.body.outerHtml seems to be an upgrade from what I had. The text can turned into the web page using 'code snippet'. I am getting an error when trying to put the saved text back into a new document though:
Err 600, Application-defined or object-defined error
Private Function GetEWhipersTestHtmlDoc() As HTMLDocument
Dim doc As New HTMLDocument
Dim sText As String
' Error Handling
On Error GoTo ErrHandler
sText = GetStringFromFile(GetFileName("UnconfirmedRelease"))
doc.body.outerHTML = sText <---- ** ERROR is Here
Set GetEWhipersTestHtmlDoc = doc
Exit Function
ErrHandler:
Select Case DspErrMsg("blah")
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Function
final update
thanks to Tim and David I got something usable. The only hair of Tim's final solution is that HtmlDocument.Write is restricted as far as VBA is concerned. So to 'fool' the compiler, I needed to declare it as an Object:
Dim doc As Object <--- don't let vba know we want to write to HTMLDoc
Set doc = New HTMLDocument
Dim sText As String
sText = GetStringFromFile(GetFileName("UnconfirmedRelease"))
doc.Open
doc.Write sText <-- no intellisense, but compiles...and works!
doc.Close
Related
I run this function with two IE browsers open. IE_count finds six objects, but it does not find any titles (my_title) within the for loop for objShell. They all return an empty string.
Any idea as to why this could be? Relevant code below:
' code below adapted from ron's answer here: https://stackoverflow.com/questions/21407340/how-to-read-text-from-an-already-open-webpage-using-vba
Function SecondBrowserSearchForAndClick(ElementID As String, searchFor As String)
Dim objShell
Set objShell = CreateObject("Shell.Application")
Dim IE_count As Integer
IE_count = objShell.Windows.Count
Dim x As Integer
For x = 0 To (IE_count - 1)
On Error Resume Next ' sometimes more web pages are counted than are open
Dim my_url As String
my_url = objShell.Windows(x).document.Location
Dim my_title As String
my_title = objShell.Windows(x).document.Title
If my_title Like "*Select Process*" Then 'compare to find if the desired web page is already open
Dim tagColl_TR As Object
Set tagColl_TR = objShell.Windows(x).document.getElementById(ElementID).contentDocument.getElementsByTagName("tr")
Dim f
While f < tagColl_TR.Length
If tagColl_TR(f).Children.Length = 5 Then
If tagColl_TR(f).Children(3).Children(0).innerText Like "*" & searchFor & "*" Then
tagColl_TR(f).Children(1).Children(0).Children(1).Focus
tagColl_TR(f).Children(1).Children(0).Children(1).Click
Exit Function
End If
End If
f = f + 1
Wend
End If
Next
End Function
Any help would be appreciated.
It's easier to put the "find document by title" functionality in its own function:
Sub Tester()
Dim doc As Object
Set doc = IEDocumentByTitle("Google")
If Not doc Is Nothing Then
Debug.Print "Found window at: " & doc.Location
'work on doc here
End If
End Sub
'Return an open IE document based on its Title property
Function IEDocumentByTitle(title As String)
Dim w As Object, ttl As String
For Each w In CreateObject("Shell.Application").Windows
If w.Application.Name = "Internet Explorer" Then 'filter out Windows Explorer
ttl = ""
On Error Resume Next
ttl = w.document.title
On Error GoTo 0
If ttl Like title Then
Set IEDocumentByTitle = w.document
Exit Function
End If
End If
Next w
End Function
This works fine for me.
BTW the shell Windows collection also includes Windows Explorer instances in addition to IE windows/tabs.
Also you should really cancel On Error Resume Next as soon as possible or it will silently swallow all errors in your code, possibly leading to unexpected results.
I am trying to capture pages in word as image and paste in Excel via VBA, below is the complete code. but got a Type Mismatch error as the comment in below. How to fix the error?
Function openFile() As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Filters.Add "Word Files", "*.doc*", 1
.Show
openFile = .SelectedItems.Item(1)
End With
End Function
Function readWord(ByVal path As String)
Debug.Print "Read word", path
Set objWordApp = CreateObject("Word.Application")
Set objWordDoc = objWordApp.Documents.Open(path)
objWordApp.Visible = False
Dim objPage As Page
Dim objPane As Pane
Dim objWindow As Window
Debug.Print objWordDoc.Windows.Count
Debug.Print TypeName(objWordDoc.Windows.Item(1))
For Each objWindow In objWordDoc.Windows 'Got Type mismatch Here
For Each objPane In objWindow.Panes
For Each objPage In objPane.Pages
Debug.Print "Page"
Next objPage
Next objPane
Next objWindow
End Function
Sub processWord()
Dim p As String
p = openFile()
readWord (p)
End Sub
The error is caused because your code contains a confused mess of objects.
You are attempting to use late binding for Word and yet you declare:
Dim objPage As Page
Dim objPane As Pane
Dim objWindow As Window
As you appear to be writing your code in Excel this results in these objects being:
Dim objPage As Excel.Page
Dim objPane As Excel.Pane
Dim objWindow As Excel.Window
This causes the type mismatch error.
I suggest that you avoid using late binding until you have your code fully working. Then you can change all the object declarations to As Object, if you really feel it is necessary.
Incidentally, if you are thinking that you can use the SaveAsPNG method listed in the documentation to get images of the documents pages, you can't - it doesn't exist.
I'm trying to add the functionality in my Outlook (with VBA, I guess is easiest) to add a simple file dialog which takes the path of any files chosen and adds them to the email body as a hyperlink.
The idea of this is for network files to be shared amongst colleagues, instead of attaching them to the email, but just as easy to do.
This is my code so far, I can't even get the dialog to open, and I've had a good look at trying to get COMDLG32.ocx, so far I can't seem to make anything work.
Sub Main2()
Dim CDLG As Object
Set CDLG = CreateObject("MSComDlg.CommonDialog")
With CDLG
.DialogTitle = "Get me a File!"
.Filter = _
"Documents|*.doc|Templates|*.dot|Text Files|*.txt"
.ShowOpen
MsgBox .FileName
End With
Set CDLG = Nothing
End Sub
Thanks in advance, hopefully someone can show me how this is done!
Just for those who need it; OS Windows 10, Office 2010 H&B (yes, I know it's out of date :))
There seems to be no direct way to open a FileDialog in Outlook 2010 VBA.
The following macro (inspired by a related post) makes use of Excel to circumvent this:
Public Function promptFileName(title As String, filter As String) As String
' requires project reference to "Microsoft Excel 14.0 Object Library"
Dim xlObj As Excel.Application
Dim fd As Office.FileDialog
Dim name As String
Dim vItem As Variant
Dim filterArray() As String
Dim i As Integer
Set xlObj = New Excel.Application
xlObj.Visible = False
Set fd = xlObj.Application.FileDialog(msoFileDialogOpen)
name = ""
With fd
.title = title
.ButtonName = "Ok"
.Filters.Clear
filterArray = Split(filter, "|")
For i = LBound(filterArray) To UBound(filterArray) - 1 Step 2
.Filters.Add filterArray(i), filterArray(i + 1), 1 + i \ 2
Next i
If .Show = -1 Then
For Each vItem In .SelectedItems
name = vItem
Exit For
Next
End If
End With
xlObj.Quit
Set xlObj = Nothing
promptFileName = name
End Function
Private Sub testPromptFile
Dim name as String
name = promptFileName("a test", "Text Files (*.txt)|*.txt|All Files (*.*)|*.*")
MsgBox name
End Sub
Outlook 2013 and beyond provide an Office.FileDialog class for this purpose.
You can press a button with Outlook VBA.
Sub ExecuteMso_strId()
Dim objItem As Object
Dim strId As String
' Text appears when hovering over icon
' when adding buttons to a Quick Access toolbar or a ribbon
strId = "HyperlinkInsert"
On Error Resume Next
Set objItem = ActiveInspector.currentItem
On Error GoTo 0
If Not objItem Is Nothing Then
ActiveInspector.CommandBars.ExecuteMso (strId)
Else
ActiveExplorer.CommandBars.ExecuteMso (strId)
End If
End Sub
With this you do not have access to the parameters as with Excel.
I'm trying to pull text from a bunch of XML files into Word. I'm working from a list of files and have found that some of them don't actually exist in the folder. So, I'm using this function to check whether the files actually exist before opening them. But I'm still getting error 52 (Bad file name or number).
This is the function:
Function FileThere(FileName As String) As Boolean
FileThere = (Dir(FileName) > "")
End Function
And this is the code I'm calling it from:
Sub PullContent()
Dim docList As Document
Dim docCombinedFile As Document
Dim objFileListTable As Table
Dim objRow As Row
Dim strContent As String
Dim strFileCode As String
'Code # for the current file. (Pulled in temporarily, output to the Word doc.)
Dim strFilename As String
'Name of XML file. Created based on strFileCode
Set docCombinedFile = Documents.Add
'The new doc which will list all warnings
Dim strXml As String
'String variable that holds the entire content of the data module
Dim strInvalidCodes
'String listing any invalid file codes. Displayed at the end.
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Documents.Open FileName:="C:\Users\kelly.keck\Documents\Triton MTS\IETMs - Test\IETMList.docx"
Set docList = Documents("IETMList.docx")
Set objFileListTable = docList.Tables(1)
For Each objRow In objFileListTable.Rows
strFileCode = objRow.Cells(4).Range.Text
strFileCode = Left(strFileCode, Len(strFileCode) - 2)
strFilename = strFileCode & ".xml"
strPath = "C:\Applications\xml\"
If FileThere(strPath & strFileCode) = True Then
'MsgBox (strPath & strFilename)
strXml = FSO.OpenTextFile(strPath & strFilename).ReadAll
Else
strInvalidCodes = strInvalidCodes & vbCr & strFileCode
End If
Next
MsgBox ("The following filenames were invalid: " & vbCr & strInvalidCodes)
End Sub
Getting this error seems to defeat the purpose of having a function to check if a file exists, but I'm not sure what's wrong with the function.
A bit late to the party, but this hasn't had an accepted answer yet.
I generally use this method to test if a file exists, and your code uses FileSystemObject already so could use that reference.
Public Function FileExists(ByVal FileName As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists(FileName)
End Function
I believe that you need to be sure that FileThere is actually returning the Boolean value you intend. It would be more reliable if you checked the Len property (the number of characters) or checked whether it actually returns the empty string.
The following is more verbose than absolutely necessary in order to make the logic clear. If you were to use Len, instead, then you'd check Len(Dir(FileName)) > 0
Function FileThere(FileName as String) as Boolean
Dim bFileExists as Boolean
If Dir(FileName) = "" Then
bFileExists = False
Else
bFileExists = True
End If
FileThere = bFileExists
End Function
Trying to use Excel VBA to capture all the file attributes from files on disk, including extended attributes. Was able to get it to loop through the files and capture the basic attributes (that come from the file system):
File Path
File Name
File Size
Date Created
Date Last Accessed
Date Last Modified
File Type
Would also like to capture the extended properties that come from the file itself:
Author
Keywords
Comments
Last Author
Category
Subject
And other properties which are visible when right clicking on the file.
The goal is to create a detailed list of all the files on a file server.
You say loop .. so if you want to do this for a dir instead of the current document;
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace("c:\foo")
For Each sFile In oDir.Items
Debug.Print oDir.GetDetailsOf(sFile, XXX)
Next
Where XXX is an attribute column index, 9 for Author for example.
To list available indexes for your reference you can replace the for loop with;
for i = 0 To 40
debug.? i, oDir.GetDetailsOf(oDir.Items, i)
Next
Quickly for a single file/attribute:
Const PROP_COMPUTER As Long = 56
With CreateObject("Shell.Application").Namespace("C:\HOSTDIRECTORY")
MsgBox .GetDetailsOf(.Items.Item("FILE.NAME"), PROP_COMPUTER)
End With
You can get this with .BuiltInDocmementProperties.
For example:
Public Sub PrintDocumentProperties()
Dim oApp As New Excel.Application
Dim oWB As Workbook
Set oWB = ActiveWorkbook
Dim title As String
title = oWB.BuiltinDocumentProperties("Title")
Dim lastauthor As String
lastauthor = oWB.BuiltinDocumentProperties("Last Author")
Debug.Print title
Debug.Print lastauthor
End Sub
See this page for all the fields you can access with this: http://msdn.microsoft.com/en-us/library/bb220896.aspx
If you're trying to do this outside of the client (i.e. with Excel closed and running code from, say, a .NET program), you need to use DSOFile.dll.
'vb.net
'Extended file stributes
'visual basic .net sample
Dim sFile As Object
Dim oShell = CreateObject("Shell.Application")
Dim oDir = oShell.Namespace("c:\temp")
For i = 0 To 34
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(oDir, i) & vbCrLf
For Each sFile In oDir.Items
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(sFile, i) & vbCrLf
Next
TextBox1.Text = TextBox1.Text & vbCrLf
Next
I was finally able to get this to work for my needs.
The old voted up code does not run on windows 10 system (at least not mine). The referenced MS library link below provides current examples on how to make this work. My example uses them with late bindings.
https://learn.microsoft.com/en-us/windows/win32/shell/folder-getdetailsof.
The attribute codes were different on my computer and like someone mentioned above most return blank values even if they are not. I used a for loop to cycle through all of them and found out that Title and Subject can still be accessed which is more then enough for my purposes.
Private Sub MySubNamek()
Dim objShell As Object 'Shell
Dim objFolder As Object 'Folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("E:\MyFolder")
If (Not objFolder Is Nothing) Then
Dim objFolderItem As Object 'FolderItem
Set objFolderItem = objFolder.ParseName("Myfilename.txt")
For i = 0 To 288
szItem = objFolder.GetDetailsOf(objFolderItem, i)
Debug.Print i & " - " & szItem
Next
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Sub
Lucky discovery
if objFolderItem is Nothing when you call
objFolder.GetDetailsOf(objFolderItem, i)
the string returned is the name of the property, rather than its (undefined) value
e.g. when i=3 it returns "Date modified"
Doing it for all 288 values of I makes it clear why most cause it to return blank for most filetypes
e.g i=175 is "Horizontal resolution"