VBA extract and parse data from website to Word - vba

I'm trying to extract some data from here: http://www.hnb.hr/tecajn/f140215.dat
This is the exchange rate list from the Croatian National Bank. The file name "f140215.dat" is basically a date, formatted in the following order:
"f" "DDMMYY" ".dat"
I intend to have the data organized in a Word table, which contains the following cells:
Cell#1 where a user would manually input a date in the following
format: "MMM DD, YYYY"
Cell#2 where a user would manually input the requested currency code
name (USD, GBP, etc)
Cell#3 where the extracted exchange rate should appear for the
specified date and currency.
Underneath the table there is an "UPDATE" button that updates the Cell#3 information. The script I'm asking for should be connected to that button.
After clicking the button, I'd like the script to do the following:
Figure out which page to go to based on the date inputted in Cell #1.
For example, if the Cell#1 contains "February 14, 2015", the script
should point to "http://www.hnb.hr/tecajn/f140215.dat"
On that page, grab the middle value for the currency specified in
Cell#2. For example, if Cell#2 contains "USD", the script should
extract "6,766508" which is the middle value for "840USD001". Only
the middle value is relevant.
Write this value to Cell#3.
So to sum it up, based in the criteria specified in the two table cells, the script needs to identify which page to go to and what data to extract from it, and with that data populate the third cell.
Hope I explained it well enough. This is only a part of the whole invoice generator I'm building. So far I've gotten everything to work, but this I really don't even know how to start. I can send the whole thing if needed, but figured it's not exactly relevant.
EDIT:
I watched some tutorials and played around, and this is what I got so far.
Enum READYSTATE
READYSTATE_UNINITIALIZED = 0
READYSTATE_LOADING = 1
READYSTATE_LOADED = 2
READYSTATE_INTERACTIVE = 3
READYSTATE_COMPLETE = 4
End Enum
Sub Test()
Dim ie As New InternetExplorer
ie.Visible = False
ie.navigate "http://www.hnb.hr/tecajn/f140215.dat"
Do While ie.READYSTATE <> READYSTATE_COMPLETE
DoEvents
Loop
Dim html As HTMLDocument
Set html = ie.document
MsgBox html.DocumentElement.innerText
End Sub
I know it's not much, but like I said, I'm new at this. I was able to get the data into the message box, but I have no idea how to parse it, and without that I can't really do anything mentioned above. What now?
EDIT 2:
Alright!! Made some progress! I've managed to parse it by using the split function:
Sub Test()
Dim ie As New InternetExplorer
ie.Visible = False
ie.navigate "http://www.hnb.hr/tecajn/f140215.dat"
Do While ie.READYSTATE <> READYSTATE_COMPLETE
DoEvents
Loop
Dim html As HTMLDocument
Set html = ie.document
Dim getData As String
getData = html.DocumentElement.innerText
'replaced all the space fields with line breaks
Dim repData As String
repData = Replace(getData, " ", vbCrLf)
'used line breaks as separators
Dim splData As Variant
splData = Split(repData, vbCrLf)
MsgBox splData(1)
MsgBox splData(2)
MsgBox splData(3)
End Sub
Right now it displays the parsed data in message boxes. The rest should be easy!
Addendum from OP's comment:
This is a part of the continued code:
Dim cur As String
cur = ActiveDocument.SelectContentControlsByTitle("valCombo").Item(1).Range.Text
If cur = "USD" Then
ActiveDocument.Tables(1).Cell(7, 3).Range.Text = splData(40) & " HRK"
End If
If cur = "EUR" Then
ActiveDocument.Tables(1).Cell(7, 3).Range.Text = splData(20) & " HRK"
End If
This way it works, but I'd like to set ActiveDocument.Tables(1).Cell(7, 3).Range.Text as a string. However, once I do that, it doesn't do anything. Why is that?

This should help you with the first half of your project; that being the retrieval of the data. As I mentioned in my earlier comment, data retrieval such as this is better suited to an MSXML2.ServerXMLHTT type of object.
You will have to go into the VBE's Tools ► References and add Microsoft XML v6.0.
Sub scrape_CNB()
Dim u As String, dtDATE As Date, xmlHTTP As MSXML2.ServerXMLHTTP60
Dim sTMP As String, sCURR As String
Dim i As Long, j As Long, vLINE As Variant, vRATE As Variant
On Error GoTo CleanUp
Set xmlHTTP = New MSXML2.ServerXMLHTTP60
sCURR = "USD"
dtDATE = CDate("February 14, 2015")
With xmlHTTP
u = "http://www.hnb.hr/tecajn/f" & Format(dtDATE, "ddmmyy") & ".dat"
.Open "GET", u, False
.setRequestHeader "Content-Type", "text/xml"
.send
If .Status <> 200 Then GoTo CleanUp
sTMP = .responseText
vLINE = Split(sTMP, Chr(13) & Chr(10))
For i = LBound(vLINE) To UBound(vLINE)
If CBool(InStr(1, vLINE(i), sCURR, vbTextCompare)) Then
Do While CBool(InStr(1, vLINE(i), Chr(32) & Chr(32))): vLINE(i) = Replace(vLINE(i), Chr(32) & Chr(32), Chr(32)): Loop
vRATE = Split(vLINE(i), Chr(32))
For j = LBound(vRATE) To UBound(vRATE)
MsgBox j & ": " & vRATE(j)
Next j
Exit For
End If
Next i
End With
CleanUp:
Set xmlHTTP = Nothing
End Sub
Since you are not initiating a full Internet.Explorer object, this should be much quicker and the .responseText that is returned is raw text, not HTML.
TBH, I find the cursor position based VBA programming within Word to be hard to deal with; preferring the one-to-one explicitly defined relationship(s) with an Excel worksheet. You may want to consider using Excel as a data repository and merging with Word to provide your invoice output.
Addendum:
Dim cur As String, t as long, r as long, c as long
cur = ActiveDocument.SelectContentControlsByTitle("valCombo").Item(1).Range.Text
t = 1: r = 7: c = 3
Select Case cur
Case "USD"
ActiveDocument.Tables(t).Cell(r, c).Range.Text = splData(40) & " HRK"
Case "EUR"
ActiveDocument.Tables(t).Cell(r, c).Range.Text = splData(20) & " HRK"
End Select

Related

Can't get rid of "old format or invalid type library" error in vba

I've written a script in vba to get some set names from a webpage and the script is getting them accordingly until it catches an error somewhere within the execution. This is the first time I encountered such error.
What my script is doing is get all the links under Company Sets and then tracking down each of the links it goes one layer deep and then following all the links under Set Name it goes another layer deep and finally parse the table from there. I parsed the name of PUBLISHED SET which is stored within the variable bName instead of the table as the script is getting bigger. I used IE to get the PUBLISHED SET as there are few leads which were causing encoding issues.
I searched through all the places to find any workaround but no luck.
However, I came across this thread where there is a proposed solution written in vb but can't figure out how can I make it work within vba.
Script I'm trying with:
Sub FetchRecords()
Const baseUrl$ = "https://www.psacard.com"
Const link = "https://www.psacard.com/psasetregistry/baseball/company-sets/16"
Dim IE As New InternetExplorer, Htmldoc As HTMLDocument
Dim Http As New XMLHTTP60, Html As New HTMLDocument, bName$, tRow As Object
Dim post As Object, elem As Object, posts As Object, I&, R&, C&
Dim key As Variant
Dim idic As Object: Set idic = CreateObject("Scripting.Dictionary")
With Http
.Open "GET", link, False
.send
Html.body.innerHTML = .responseText
End With
Set posts = Html.querySelectorAll(".dataTable tr td a[href*='/psasetregistry/baseball/company-sets/']")
For I = 0 To posts.Length - 7
idic(baseUrl & Split(posts(I).getAttribute("href"), "about:")(1)) = 1
Next I
For Each key In idic.Keys
With Http
.Open "GET", key, False
.send
Html.body.innerHTML = .responseText
End With
For Each post In Html.getElementsByTagName("a")
If InStr(post.getAttribute("title"), "Contact User") > 0 Then
If InStr(post.ParentNode.getElementsByTagName("a")(0).getAttribute("href"), "publishedset") > 0 Then
IE.Visible = True
IE.navigate baseUrl & Split(post.ParentNode.getElementsByTagName("a")(0).getAttribute("href"), "about:")(1)
While IE.Busy = True Or IE.readyState < 4: DoEvents: Wend
Set Htmldoc = IE.document
bName = Htmldoc.querySelector("h1 b.text-primary").innerText
If InStr(bName, "/") > 0 Then bName = Split(Htmldoc.querySelector(".inline-block a[href*='/contactuser/']").innerText, " ")(1)
R = R + 1: Cells(R, 1) = bName
End If
End If
Next post
Next key
IE.Quit
End Sub
I get that error pointing at the following line after extracting records between 70 to 90:
bName = Htmldoc.querySelector("h1 b.text-primary").innerText
The error looks like:
Automation Error: old format or invalid type library
Proposed solution in the linked thread written in vb (can't convert to vba):
'save the current settings for easier restoration later
Dim oldCI As System.Globalization.CultureInfo = _
System.Threading.Thread.CurrentThread.CurrentCulture
'change the settings
System.Threading.Thread.CurrentThread.CurrentCulture = _
New System.Globalization.CultureInfo("en-US")
Your code here
'restore the previous settings
System.Threading.Thread.CurrentThread.CurrentCulture = oldCI

How to reply to mail based on attachment extension?

I can read code, and adjust code a bit.
I've got access to a company email (say invoice#rr.com).
I want code which looks through all new mail in the inbox of invoice#rr.com (best if this works even when Outlook is not open, but a manually clicked macro would make me happy) and reply to all (with attachment) when:
there is more then one attachment (exception is one .xml and one .pdf file)
the attachment is not .pdf, .xml or .icf
when there is no attachment at all
when the title has the word "reminder"
when the message has the word "reminder"
Besides that, the code needs to move the mail to a subfolder called "send back".
I've been reading forums and one of the problems is a picture in a signature also counts as an attachment.
First try after help from Tony:
Sub reply()
'still need to get rid of all the stuff i dont use below (up to the *) but still not sure about the code so I left it here for now
Dim olInspector As Outlook.Inspector
Dim olDocument As Outlook.DocumentItem
Dim olSelection As Outlook.Selection
Dim olReply As MailItem
Dim olAtt As Attachment
Dim olFileType As String
Dim AttachCount As Long
Dim AttachDtl() As String
Dim ExcelWkBk As Excel.Workbook
Dim FileName As String
Dim FolderTgt As MAPIFolder
Dim HtmlBody As String
Dim InterestingItem As Boolean
Dim InxAttach As Long
Dim InxItemCrnt As Long
Dim PathName As String
Dim ReceivedTime As Date
Dim RowCrnt As Long
Dim SenderEmailAddress As String
Dim SenderName As String
Dim Subject As String
Dim TextBody As String
Dim myDestFolder As Outlook.Folder
'*
Set myDestFolder = Session.Folders("Outlook Data File").Folders("replied")
Set Myselect = Outlook.ActiveExplorer.Selection '(i use this in my test to only process selected test mails)
'Set FolderTgt = Session.Folders("invoice#rr.com").Folders("Inbox") ***(this will replace the code above)
For InxItemCrnt = Myselect.Items.Count To 1 Step -1 '(myselect = foldertgt in live)
With Myselect.Items.Item(InxItemCrnt) '(myselect = foldertgt in live)
'still need a workaround for mail with (1 .PDF and 1 .ICF) or (1 .PDF and 1 .XML)
'those combinations are the only combinations when more then one attachment is allowed
'1st filter
If AttachCount = 0 Then 'no attachment = reply
Reply0
.move myDestFolder
Else
'2nd filter
If AttachCount > 1 Then 'more then one attachment = reply
Reply1
.move myDestFolder
Else
'3rd filter
If InStr(Subject, "Reminder") = 0 Then 'reminders need to go to a different mailbox
Reply2
.move myDestFolder
Else
'4th filter
Select Case olFileType
Case ".pdf, .icf, .xml"
If olFileType = LCase$(Right$(olAtt.FileName, 4)) Then
Exit Sub 'if attachment = pdf or ICF then this sub can exit
Else
Reply3 'all mails with incorrect files
.move myDestFolder
End Select
End If
End If
End If
End If
End With
'replies below
Reply0:
Set olReply = Item.Reply '// Reply if no attachment found
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Reply1:
Set olReply = Item.Reply '// Reply more then one attachment
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Reply2:
Set olReply = Item.Reply '// Reply reminders need to go to reminder#rr.com
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Reply3:
Set olReply = Item.Reply '// Reply not correct file
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & ".... insert text...." 'still need to insert some text
olReply.Send
Next
Set olInspector = Nothing
Set olDocument = Nothing
Set olSelection = Nothing
Set olAtt = Nothing
End Sub
2nd try after some more help from Tony: (note: I'm Dutch so some code has dutch words I'll explain them in English behind the code, it basicly is copy paste from his answer, all credits to Tony)
Sub reply()
Dim Fso As New FileSystemObject
Dim DiagFile As TextStream
Dim FldrInvInbox As MAPIFolder
Dim InxA As Long
Dim InxItemCrnt As Long
Dim NumIcfAttach As Long
Dim NumPdfAttach As Long
Dim NumXmlAttach As Long
Dim NumDocAttach As Long
Dim NumDoxAttach As Long
Dim PathDiag As String
Dim Pos As Long
Dim ProcessThisEmail As Boolean
Dim Subject As String
Dim ReminderInBody As Boolean
Dim ReminderInSubject As Boolean
Dim ReminderInBody1 As Boolean
Dim ReminderInSubject1 As Boolean
Set FldrInvInbox = Session.Folders("invoice#rr.com").Folders("Postvak IN") 'Postvak IN = Inbox)
PathDiag = "z:\VBA test" 'location for diagnostics report
Set DiagFile = Fso.CreateTextFile(PathDiag & "\Diag.txt", True, False)
For InxItemCrnt = FldrInvInbox.Items.Count To 1 Step -1
With FldrInvInbox.Items.Item(InxItemCrnt)
' It is unlikely an Inbox will contain anything but emails
' but it does no harm to check
If .Class = olMail Then
' Extract information that will identify if this email is to be processed
ProcessThisEmail = True ' Assume True until find otherwise
'Below i'm looking for reminder, payment reminder and other similiar text in subject, dutch words are betalingsherinnering and openstaande posten
If InStr(1, LCase(.Subject), "betalingsherinnering") = 0 Then
ReminderInSubject = False
Else
ReminderInSubject = True
ProcessThisEmail = False
End If
If InStr(1, LCase(.Subject), "openstaande posten") = 0 Then
ReminderInSubject1 = False
Else
ReminderInSubject1 = True
ProcessThisEmail = False
End If
'Below i'm looking for reminder, payment reminder and other similiar text in mail, dutch words are betalingsherinnering and openstaande posten
If InStr(1, LCase(.Body), "betalingsherinnering") = 0 Then
ReminderInBody = False
Else
ReminderInBody = True
ProcessThisEmail = False
End If
If InStr(1, LCase(.Body), "openstaande posten") = 0 Then
ReminderInBody1 = False
Else
ReminderInBody1 = True
ProcessThisEmail = False
End If
NumIcfAttach = 0
NumPdfAttach = 0
NumXmlAttach = 0
NumDocAttach = 0
For InxA = 1 To .Attachments.Count
Select Case LCase(Right$(.Attachments(InxA).FileName, "3"))
Case "txt"
NumIcfAttach = NumIcfAttach + 1 'code will be changed soon, need to look at ICF in the name of the attachment
Case "pdf"
NumPdfAttach = NumPdfAttach + 1
Case "doc"
NumDocAttach = NumDocAttach + 1
Case "xml"
NumXmlAttach = NumXmlAttach + 1
End Select
Next InxA
Else ' Not email
ProcessThisEmail = False
End If
End With
' Decide if email is to be processed
If ProcessThisEmail = True Then
If NumXmlAttach > 1 Then
ProcessThisEmail = False
Else
If NumDocAttach <> 0 Then
ProcessThisEmail = False
Else
If NumPdfAttach > 1 Then
ProcessThisEmail = False
Else
If NumIcfAttach > 1 Then
ProcessThisEmail = False
Else
If NumIcfAttach + NumPdfAttach = 2 Then
ProcessThisEmail = True
Else
If NumXmlAttach + NumPdfAttach = 2 Then
ProcessThisEmail = True
Else
If NumXmlAttach = 1 And NumIcfAttach = 0 And NumPdfAttach = 0 And NumDocAttach = 0 Then
ProcessThisEmail = True
Else
If NumPdfAttach = 1 And NumIcfAttach = 0 And NumXmlAttach = 0 And NumDocAttach = 0 Then
ProcessThisEmail = True
Else
If NumIcfAttach = 1 And NumXmlAttach = 0 And NumPdfAttach = 0 And NumDocAttach = 0 Then
ProcessThisEmail = True
Else
If NumXmlAttach + NumPdfAttach + NumIcfAttach = 0 Then
ProcessThisEmail = False
Else
If NumXmlAttach + NumIcfAttach = 2 Then
ProcessThisEmail = False
Else
If NumXmlAttach + NumPdfAttach + NumIcfAttach = 3 Then
ProcessThisEmail = False
Else
If NumIcfAttach + NumPdfAttach <> 2 Then
ProcessThisEmail = False
Else
If NumXmlAttach + NumPdfAttach <> 2 Then
ProcessThisEmail = False
Else
Procisthisemail = False
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
' Output diagnostic information
DiagFile.WriteLine "----- " & InxItemCrnt & " -----"
With FldrInvInbox.Items.Item(InxItemCrnt)
DiagFile.WriteLine "ReceivedTime=" & .ReceivedTime
DiagFile.WriteLine "Sender=" & .Sender
Subject = .Subject
For Pos = Len(Subject) To 1 Step -1
If AscW(Mid(Subject, Pos, 1)) < 1 Or _
AscW(Mid(Subject, Pos, 1)) > 255 Then
Subject = Replace(Subject, Mid(Subject, Pos, 1), "?")
End If
Next
DiagFile.WriteLine "Subject=" & Subject
DiagFile.WriteLine "Reminders: Subject 1=" & ReminderInSubject & _
" Subject 2=" & ReminderInSubject1 & _
" Body 1=" & ReminderInBody & _
" Body 2=" & ReminderInBody1
DiagFile.WriteLine "Attachment counts: ICF=" & NumIcfAttach & _
" PDF=" & NumPdfAttach & " XML=" & NumXmlAttach & _
" Doc=" & NumDocAttach
DiagFile.WriteLine "ProcessThisEmail=" & ProcessThisEmail
End With
' Process email if required
If ProcessThisEmail Then
End If
Next InxItemCrnt
DiagFile.Close
End Sub
My first reaction is: there is way too much untested code in your revised question. I plan to review your code but most of this answer is a tutorial explaining how I would have tackled your requirement.
None of us were born with the knowledge to write the macro you need. I started with Excel VBA which I believe was lucky since the training material for Excel VBA is much better than that for Outlook VBA. I visited a good library and borrowed several “Teach yourself to program Excel” books. I tried them all and then bought the one that was best for my learning style. I would recommend you invest a few days learning Excel VBA. I am confident that this investment will quickly repay itself. I did buy a highly recommended Outlook VBA but was not impressed. The transition from Excel to Outlook was not as easy as it could have been because I have never found a good explanation of the Outlook Object Model. Most of my knowledge is the result of much experimentation over many years. This background means I can usually look at some badly explained Outlook property and be able to deduce what they meant to say.
One of my advantages is that I have spent time studying development and testing theory. There is little in your code that is wrong but I believe a different approach would produce the desired result more quickly.
Another advantage which I would recommend to you is a folder on my system named “Resources” with sub-folders by topic. Every time I complete a development, I look through the code for ideas I might need again. I capture each idea in a file in the appropriate sub-folder with sample code, references to the source and notes on anything I found difficult. I don’t use VBA often enough to remember everything I have learnt. Being able to look for relevant files when starting a new development saves me a lot of time.
That’s enough general points. From your original question, I think you need the following for your requirement:
To read up or down the Inbox of invoice#rr.com.
To identify the number of attachments of an email and, if any, their extensions.
To check if the title of an email includes "remainder".
To check if body of an email includes "remainder".
To reply to selected emails
To move selected emails to folder “send back”
Your original specification of which emails were to be selected is not clear to me. Your added code is a little clearer but adds the complication that you appear to envisage different replies for different emails.
In your code, you do not read up or down the Inbox of invoice#rr.com. Instead you use Inspector to process selected emails. This would allow you to select an email with no attachments, say, and test how you code handles it. I do not think this is a good idea. For me, reading down the inbox and selecting the emails to be processed is the larger and more complicated block of code. I would want to write and test that code before writing the code to replying or moving emails. I would not want to reply to emails until I knew I had everything else correct. I would not want to move emails to a different folder until near the end of testing because I would not want to move them back for a retest.
The potential problem with my approach is the number of emails in the Inbox of invoice#rr.com. How do I test each email is correctly identified as needing a reply or not needing a reply? VBA comes with some diagnostic aids but one of my favourite technique is to write the envelope for my code but to output diagnostic text identifying the decisions made by the code without acting on those decisions. The code I have written shows what I mean by this.
To output diagnostic text, I can use something like Debug.Print "xxxx=" & xxxx where xxxx is a variable. This outputs to the Immediate Window which is often the most convenient technique. But you can only see the last 200 or so displays with Debug.Print and I suspect this will not be enough. Instead I will output to a text file. I do not do this often enough to remember the syntax so I have a file to remind me. File “Output to diagnostic file.txt” contains:
' Needs reference to Microsoft Scripting Runtime
Dim Fso As New FileSystemObject
Dim DiagFile As TextStream
Dim PathDiag As String
PathDiag = ThisWorkbook.Path
PathDiag = CreateObject("WScript.Shell").specialfolders("Desktop")
Set DiagFile = Fso.CreateTextFile(PathDiag & "\Diag.txt", True, False)
DiagFile.WriteLine ""
DiagFile.Close
I do not need the reminder about “Microsoft Scripting Runtime” for Outlook because I referenced it when I first installed Outlook. You will need to open the Outlook VBA Editor, click Tools and select References from the drop down menu. Scroll down the list of libraries and tick “Microsoft Scripting Runtime”. Without this reference, the compiler will not recognise “FileSystemObject” or “TextStream”. I use the first value for PathDiag if I am working with Excel. Here I will use the second value which will create the file on the desktop.
I have taken code from the answer I referenced in my comment. I renamed some of the variables and simplified the handling of attachments. I inserted code from file “Output to diagnostic file.txt”. I added code to extract the values needed for selecting emails. This code only involves simple (for me) statements that I remember how to use correctly. I added the code to output diagnostics to the text file. Here I hit a problem. Execution stopped on DiagFile.WriteLine “Subject=" & .Subject saying this an invalid call. It took me a while to identify the cause and add code to fix it. I will explain this latter. Here is my code:
Option Explicit
Sub ReplyToInvoiceEmails()
Dim Fso As New FileSystemObject
Dim DiagFile As TextStream
Dim FldrInvInbox As MAPIFolder
Dim InxA As Long
Dim InxItemCrnt As Long
Dim NumIcoAttach As Long
Dim NumPdfAttach As Long
Dim NumXmlAttach As Long
Dim PathDiag As String
Dim Pos As Long
Dim ProcessThisEmail As Boolean
Dim Subject As String
Dim ReminderInBody As Boolean
Dim ReminderInSubject As Boolean
Set FldrInvInbox = Session.Folders("tonydallimore23#gmail.com").Folders("Inbox")
PathDiag = CreateObject("WScript.Shell").specialfolders("Desktop")
Set DiagFile = Fso.CreateTextFile(PathDiag & "\Diag.txt", True, False)
For InxItemCrnt = FldrInvInbox.Items.Count To 1 Step -1
With FldrInvInbox.Items.Item(InxItemCrnt)
' It is unlikely an Inbox will contain anything but emails
' but it does no harm to check
If .Class = olMail Then
' Extract information that will identify if this email is to be processed
ProcessThisEmail = True ' Assume True until find otherwise
If InStr(1, LCase(.Subject), "reminder") = 0 Then
ReminderInSubject = False
Else
ReminderInSubject = True
End If
If InStr(1, LCase(.Body), "reminder") = 0 Then
ReminderInBody = False
Else
ReminderInBody = True
End If
NumIcoAttach = 0
NumPdfAttach = 0
NumXmlAttach = 0
For InxA = 1 To .Attachments.Count
Select Case LCase(Right$(.Attachments(InxA).Filename, "3"))
Case "ico"
NumIcoAttach = NumIcoAttach + 1
Case "pdf"
NumPdfAttach = NumPdfAttach + 1
Case "xml"
NumXmlAttach = NumXmlAttach + 1
End Select
Next InxA
Else ' Not email
ProcessThisEmail = False
End If
End With
' Decide if email is to be processed
If ProcessThisEmail Then
If ReminderInSubject Or ReminderInBody Then
ProcessThisEmail = False
ElseIf NumXmlAttach = 1 Then
ProcessThisEmail = False
End If
End If
' Output diagnostic information
DiagFile.WriteLine "----- " & InxItemCrnt & " -----"
With FldrInvInbox.Items.Item(InxItemCrnt)
DiagFile.WriteLine "ReceivedTime=" & .ReceivedTime
DiagFile.WriteLine "Sender=" & .Sender
Subject = .Subject
For Pos = Len(Subject) To 1 Step -1
If AscW(Mid(Subject, Pos, 1)) < 1 Or _
AscW(Mid(Subject, Pos, 1)) > 255 Then
Subject = Replace(Subject, Mid(Subject, Pos, 1), "?")
End If
Next
DiagFile.WriteLine "Subject=" & Subject
DiagFile.WriteLine "Reminders: Subject=" & ReminderInSubject & _
" Body=" & ReminderInBody
DiagFile.WriteLine "Attachment counts: ICO=" & NumIcoAttach & _
" PDF=" & NumPdfAttach & " XML=" & NumXmlAttach
DiagFile.WriteLine "ProcessThisEmail=" & ProcessThisEmail
End With
' Process email if required
If ProcessThisEmail Then
End If
Next InxItemCrnt
DiagFile.Close
End Sub
The first executable statement is Set FldrInvInbox = Session.Folders("tonydallimore23#gmail.com").Folders("Inbox"). You must replace "tonydallimore23#gmail.com" with "invoice#rr.com" or the real name for this store. Apart from this change, this code should run without problems on your system.
Next are the statements to prepare the diagnostic text file and then: For InxItemCrnt = FldrInvInbox.Items.Count To 1 Step -1.
FldrInvInbox.Items is a collection holding all the items in FldrInvInbox. A collection is like an array (if you know what an array is) except you can add items to the middle of a collection and delete items from the middle. FldrInvInbox.Items.Count is the number of items in FldrInvInbox.Items. I am accessing items in this collection by their position. If the code decides item 5 is to be moved to another folder, item 6 become item 5, item 7 becomes item 6 and so on. This would mess up the For-Loop. I am accessing this collection starting from the end. If I move item 1000 to a different folder then items 1 to 999, which I have yet to process, do not move so the For-Loop works properly.
The next block of code extracts properties to variables. I think I have extracted every property you need but you must check. The next block of code decides if an email is to be processed. I like to divide code into blocks like this because it is easier to write and easier to understand if you need to change it in a year’s time. I do not understand how you want to select emails and I am sure my selection code is wrong. You will have to correct this block of code or provide more information on the selection process so I can correct it.
Next is code to create the diagnostic output. On my system, the diagnostic output looks like:
----- 55 -----
ReceivedTime=09/08/2018 13:03:09
Sender=TechTarget Channel Media
Subject=Channel ecosystem sees major shift in partner types
Reminders: Subject=False Body=False
Attachment counts: ICO=0 PDF=0 XML=0
ProcessThisEmail=True
----- 54 -----
ReceivedTime=09/08/2018 11:48:10
Sender=TechTarget
Subject=Industrial control systems a specialised cyber target
Reminders: Subject=False Body=False
Attachment counts: ICO=0 PDF=0 XML=0
ProcessThisEmail=True
----- 53 -----
The first three lines of each email identify the email so you can locate it in the folder. The second three lines are the selection values which I know are wrong.
If I had missed some selection values, you will have to add them. You will have to correct my selection code. You want every “ProcessThisEmail=True/False” line to be correct before we move on to the reply code.
The problem I encountered with the diagnostic code was because of emojis. Execution stopped on the statement outputting the subject for some emails and it took me sometime to locate the cause. The diagnostic file is a simple ASCII text file and an emoji cannot be output to an ASCII text file. I thought of ignoring the problem since you were unlikely to have emojis in your subject. I decided to fix the problem because you have neither the experience to diagnose the problem nor to experience fix it if you did diagnose it. Have a look at my code and try to understand what I have done.
I need you to complete tmy code before we move on to the next section. I will add some text about the next section later but this section is much later than I promised so I will post what I have now.
This next paragraphs are to get you thinking about the email bodies you will create and the ones you have checked for “Reminder”.
An Outlook email can have three bodies: a text body, an Html body and a Rich Text Format (RTF) body. I have never received an email with a RTF body. I have seen a question about them but to my mind they are obsolete; perhaps they were useful before Html became so well known. I will ignore the theoretical existence of RTF bodies. An Outlook email can have a text body, an Html body or both. If there is an Html body, that is the body that is shown to the user. I rarely receive emails without an Html body. The Html bodies I receive vary enormously in both appearance and the Html used to create that appearance. Many are very complicated with style sheets and nested table so the result will look good on a laptop or a smartphone or whatever device the user views it on. I said, an Outlook email can have an Html body without a text body but I cannot find one in my archives for the last few years. I suspect they are being created by Outlook from the Html body by deleting all the Html tags and adding carriage-return-linefeeds to mark deleted paragraphs and table cells.
With an Outlook email, property Body is the text body and property HtmlBody is the Html body. In my code I only check the text body for “Reminder”. This seems sensible since the text body will be a lot smaller and I cannot find an email without a text body. If you want to be ultra-cautious, I will show you how to check the Html body if there is no text body or you might like to consider how to do this as a training exercise.
In your code you have:
olReply.Body = "this is an automatic generated mail." & vbCrLf & vbCrLf & _
vbCrLf & vbCrLf & vbCrLf & ".... insert text...."
You might find that the following gives a more attractive appearance since email packages tend to use a more attractive font when displaying Html bodies if none is specified:
olReply.Body = ""
olReply.HtmlBody = "<HTML><BODY>" & _
"<P>this is an automatic generated mail.</P>" & _
"<P>.... insert text....</P>" & _
"</BODY>" & "</HTML>"
This is very basic Html and is now depreciated but it shows an Html body could be created for little more effort than creating a text body. Html also allows formatting (bold, italic, font size, font colour and so on) which might be helpful.

Automatically collect data from multiple webpages for excel

I've been trying to automate a task but recently came to an issue. Part of the task is to copy and paste 2 pieces of information from a website into the excel document.
Here is some examples of what the webpages looks like:
https://nvd.nist.gov/vuln/detail/CVE-2018-0253
https://nvd.nist.gov/vuln/detail/CVE-2018-0300
https://nvd.nist.gov/vuln/detail/CVE-2018-0256
The data that I wish to collect is the "Current Description" and the value for "CVSS v3.0 Base score"
There is always multiple links which I have to take the data from but they are all very similar, the only difference being what CVE-****-**** it is.
Currently I have it so that excel puts the actual links to the webpages into a list.
Is there a way that I can create a macro which automatically goes through the list of links and takes the "Current Description" and "CVSS v3.0 Base Score" data from the websites and puts them into cells in excel.
Thank you for any help / suggestions / tips.
This is how I would approach it. Obviously you can tweak how you handle missing information. I am just giving an example using the CVEs provided. You really should provide your efforts as I have no idea what approach you are using.
Option Explicit
Public Sub GetInfo()
Const BASE_URL As String = "https://nvd.nist.gov/vuln/detail/"
Dim i As Long, CVES(), tempArr()
CVES = Array("CVE-2018-0253", "CVE-2018-0300", "CVE-2018-0256")
For i = LBound(CVES) To UBound(CVES)
tempArr = GetDescriptionAndScore(BASE_URL & CVES(i))
Debug.Print "Desc: " & tempArr(0)
Debug.Print "Score: " & tempArr(1)
Erase tempArr
Next i
End Sub
Public Function GetDescriptionAndScore(ByVal url As String) As Variant
Dim html As New HTMLDocument, arr(1), sResponse As String
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", url, False
.send
sResponse = StrConv(.responseBody, vbUnicode)
End With
sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
With html
.body.innerHTML = sResponse
arr(0) = .querySelector("[data-testid=vuln-description]").innerText
If InStr(1, sResponse, "This vulnerability is currently awaiting analysis") > 0 Then
arr(1) = "Not available"
Else
arr(1) = .querySelector("[data-testid=vuln-cvssv3-base-score]").innerText
End If
End With
GetDescriptionAndScore = arr
End Function
References (via VBE> Tools > References):
HTML Object Library

Extract list of all input boxes on webpage vba

I want to create a list on Excel of all the labels of input boxes on a webpage- so I imagine the code would be something like:
Sub IEInteract()
Dim i As Long
Dim URL As String
Dim IE As Object
Dim objCollection As Object
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
URL = "mywebsite.com"
IE.Navigate URL
Do While IE.ReadyState = 4: DoEvents: Loop
Do Until IE.ReadyState = 4: DoEvents: Loop
objCollection = IE.Document.getElementsByTagName("input")
For Each el In objCollection
label = el.label 'or something like that????'
Debug.Print label
Next el
End Sub
Where am I going wrong? Thanks
BTW My VBA is OK, but my HTML is non-existent.
For learning purposes maybe choose a website that has more obvious inputboxes, rather than dropdowns.
Many inputboxes won't be pre-populated so maybe consider reading other properties of the retrieved elements. Or even writing to them and then retrieving those values.
Selecting by tag name can bring back a host of items that you might not have expected.
Bearing all of the above in mind. Try running the following, which generates a collection of <input> tag elements.
Code:
Option Explicit
Public Sub PrintTagInfo()
'Tools > references > Microsoft XML and HTML Object library
Dim http As New XMLHTTP60 '<== this will be specific to your excel version
Dim html As New HTMLDocument
With http
.Open "GET", "https://www.mrexcel.com/forum/register.php", False
.send
html.body.innerHTML = .responseText
End With
Dim inputBoxes As MSHTML.IHTMLElementCollection, iBox As MSHTML.IHTMLElement, i As Long
Set inputBoxes = html.getElementsByTagName("input") '<== the collection of input tags on the page
'<== These are input boxes i.e. you are putting info into them so perhaps populate and then try to read what is in the entry box?
For Each iBox In inputBoxes
Debug.Print "Result #" & i + 1
Debug.Print vbNewLine
Debug.Print "ID: " & iBox.ID '<== select a sample of properties to print out as some maybe empty
Debug.Print "ClassName: " & iBox.className,
Debug.Print "Title: " & iBox.Title
Debug.Print String$(20, Chr$(61))
Debug.Print vbNewLine
i = i + 1
Next iBox
End Sub
Sample output:
From the above, it looks like class name might be in some ways more informative if you are looking to target boxes to input information into.
An initial inspection of the page source, selecting an inputbox and right-click > inspect... will help you refine your choices.
I noticed that a lot of the boxes of interest had the Input tag and then type = "text"
This means you can target elements matching this pattern using CSS selectors. In this case using the selector input[type=""text""].
Adjusting the former code to factor this in gives a smaller set of more targeted results. Note, using .querySelectorAll, to apply the CSS selector, returns a NodeList object which requires a different method of iterating over. A For Each Loop will cause Excel to crash as described here.
Code:
Option Explicit
Public Sub PrintTagInfo()
'Tools > references > Microsoft XML and HTML Object library
Dim http As New XMLHTTP60 '<== this will be specific to your excel version
Dim html As New HTMLDocument
With http
.Open "GET", "https://www.mrexcel.com/forum/register.php", False
.send
html.body.innerHTML = .responseText
End With
Dim inputBoxes As Object, i As Long
Set inputBoxes = html.querySelectorAll("input[type=""text""]") '<== the collection of text input boxes on page. Returned as a NodeList
'<== These are input boxes i.e. you are putting info into them so perhaps populate and then try to read what is in the entry box?
For i = 0 To inputBoxes.Length - 1
Debug.Print "Result #" & i + 1
Debug.Print vbNewLine
Debug.Print "ID: " & inputBoxes.Item(i).ID '<== select a sample of properties to print out as some maybe empty
Debug.Print "ClassName: " & inputBoxes.Item(i).className,
Debug.Print "Title: " & inputBoxes.Item(i).Title
Debug.Print String$(20, Chr$(61))
Debug.Print vbNewLine
Next i
End Sub
Sample results:
Note: I have edited the spacing to fit more into the image.
References added via VBE > Tools > References
Last two are those of interest. The bottom one will be version specific and you will need to re-write XMLHTTP60 which is for XML 6.0 to target your version of Excel if not using Excel 2016.

Excel vba macro to connect to a particular webpage - search and retrieve data

I have column, say column A containing 1500 rows each having a string (Hexadecimal encodes). What I need is connect to a particular website search paste the string, press on decode, copy the result and paste it back to column B.
Any help would be of great help. I am new here.
Example:
String in Column A: 5468616e6b732061206c6f7420696e20616476616e6365
Website to search in: http://encodertool.com/hexadecimal
Copy from excel cell and paste in tab (under heading): ENTER AN Hexadecimal CONTENT TO DECODE
Then hit DECODE
Then Copy from DECODING RESULT
Finally paste back in ColumnB in my excel sheet.
Looking forward for an answer.
Thanks a million in advance.
Are you doing this as an exercise in automating the browser? Seems like you could more easily do it directly in VBA
From: http://bytes.com/topic/access/answers/874752-convert-hex-string
Sub tester()
Debug.Print fConvertHexToString( _
"5468616e6b732061206c6f7420696e20616476616e6365")
End Sub
Public Function fConvertHexToString(strHexString As String) As String
Dim intLenOfString As Integer
Dim intCounter As Integer
Dim strBuild As String
'Hex String must have a valid length, and it must be an even length
If Len(strHexString) = 0 Or Len(strHexString) Mod 2 <> 0 Then Exit Function
intLenOfString = Len(strHexString)
For intCounter = 1 To Len(strHexString)
If intCounter Mod 2 <> 0 Then 'need Hex pairs
'Retrieve the Value of the Hex Pair, then Convert to a Character,
'then Append to a Base String
strBuild = strBuild & Chr$(Val("&H" & Mid$(strHexString, intCounter, 2)))
End If
Next
fConvertHexToString = strBuild
End Function
Something like this. I have just run a mock test and it works. Give it a try. You can modify the code to your needs. This is a plain code. Code can be enhanced as well. But this does what you ask for
Dim ie As InternetExplorer
Dim doc As HTMLDocument
Sub start()
Dim ran As Range
Dim cel As Excel.Range
Set ran = Worksheets("Sheet1").Range("A1:A4") 'Change Your input range here
For Each cel In ran
If cel.Value <> Empty Then
Set ie = New InternetExplorerMedium 'open iE
ie.navigate ("http://encodertool.com/hexadecimal") 'Navigate to IE
ie.Visible = True
'Wait untill IE is loaded
Do
' Wait till the Browser is loaded
Loop Until ie.readyState = READYSTATE_COMPLETE
Set doc = ie.document
doc.getElementById("input_4").innerText = cel.Value ' Enter input value
test ' Click button
cel.Offset(0, 1).Value = doc.getElementById("output_4").innerText ' save Output value
End If
ie.Quit
Next cel
End Sub
'Click the Decode button
Sub test()
Set cl_button= doc.getElementsByTagName("a")
For Each one In cl_button
If one.getAttribute("onclick") = "ajaxfct('fcts.php','4')" Then
one.Click
Exit For
End If
Next one
End Sub
Before running the code, add reference to HTML object library & Internet controls. Also change the range of your input. I have set it to A1:A4 . Change to it whatever. Make sure there are no blank cells in the Range. ALso, If you dont want the browser to be displayed set
ie.visible = false
This is one way of doing it. THere are many simpler and effective ways of doing it