I'm writing a macro to grab the current exchange rate from yahoo but I'm having trouble converting a html string into a HTMLDocument to allow me to search for the required element by id. Here is my code so far but it fails on the debug.print line.
Public Sub Forex(currency1 As String, currency2 As String)
Dim oXHTTP As Object
Dim doc As HTMLDocument
Dim url As String
Dim html As String
Dim id As String
Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
url = "http://finance.yahoo.com/q?s=" & currency1 & currency2 & "=X"
oXHTTP.Open "GET", url, False
oXHTTP.send
html = oXHTTP.responseText
Set oXHTTP = Nothing
Set doc = New HTMLDocument
doc.body.innerHTML = html
id = "yfs_l10_" & currency1 & currency2
Debug.Print doc.getElementById("id").innerText
End Sub
What am I missing here?
I am making use of method from excel-vba-http-request-download-data-from-yahoo-finance:
Sub Forex(currency1 As String, currency2 As String)
Dim url As String, html As String, id As String
Dim oResult As Variant, oLine As Variant, sRate As String
url = "http://finance.yahoo.com/q?s=" & currency1 & currency2 & "=X"
id = "<span id=""yfs_l10_" & currency1 & currency2 & "=x"">"
html = GetHTTPResult(url)
oResult = Split(html, vbLf)
For Each oLine In oResult
If InStr(1, oLine, id, vbTextCompare) Then
sRate = Split(Split(oLine, "<span id=""yfs_l10_audusd=x"">")(1), "</span>")(0)
Exit For
End If
Next
End Sub
Function GetHTTPResult(sURL As String) As String
Dim XMLHTTP As Variant, sResult As String
Set XMLHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
XMLHTTP.Open "GET", sURL, False
XMLHTTP.send
sResult = XMLHTTP.responseText
Set XMLHTTP = Nothing
GetHTTPResult = sResult
End Function
You're almost there, you just have the id wrong:
id = "yfs_l10_" & currency1 & currency2 & "=X"
Debug.Print doc.getElementById(id).innerText
Related
I am trying to download a macro enabled file (xlsm) from Jira, I have tried the below method and able to download the file but the file is corrupted. Please advice what I am missing here.
Dim myURL As String
myURL = "Put your download link here"
Dim HttpReq As Object
Set HttpReq = CreateObject("Microsoft.XMLHTTP")
HttpReq.Open "GET", myURL, False, "username", "password"
HttpReq.send
myURL = HttpReq.responseBody
If HttpReq.Status = 200 Then
Set oStrm = CreateObject("ADODB.Stream")
oStrm.Open
oStrm.Type = 1
oStrm.Write HttpReq.responseBody
oStrm.SaveToFile ThisWorkbook.Path & "\" & "file.xlsm", 2 ' 1 = no overwrite, 2 = overwrite
oStrm.Close
End If
(source)
Finally after several attempts, below code work, hope this is helpful for others.
Private Sub DownloadFromJira()
Dim oJiraService As MSXML2.ServerXMLHTTP60
Dim sPath As String
Dim sStatus As String
Dim FileData() As Byte
Dim FileNum As Long
Set oJiraService = New MSXML2.ServerXMLHTTP60
sPath = "C:\Users\**ID**\Downloads\Test.xlsm"
With oJiraService
.Open "GET", "https://**MyJiraLink**/secure/attachment/123455/Test.xlsm", False
.setRequestHeader "Content-Type", "application/json"
.setRequestHeader "Authorization", "Basic " & EncodeBase64(JiraUID & ":" & JiraPWD)
.setRequestHeader "Accept", "application/json"
.send
sStatus = .status & " | " & .statusText
If .status = "401" Then
MsgBox "Not Connected"
End If
FileData = .responseBody
FileNum = FreeFile
Open sPath For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
End With
Set oJiraService = Nothing
End Sub
Private Function EncodeBase64(srcTxt As String) As String
Dim arrData() As Byte
arrData = StrConv(srcTxt, vbFromUnicode)
Dim objXML As MSXML2.DOMDocument60
Dim objNode As MSXML2.IXMLDOMElement
Set objXML = New MSXML2.DOMDocument60
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
EncodeBase64 = objNode.Text
Set objNode = Nothing
Set objXML = Nothing
End Function
This is my code for this task. The issue is with the invalid characters in Windows. I can replace them fine on files but on folders in doesn't seem to work.
Dim xFSO As Scripting.FileSystemObject
Sub CopyOutlookFldStructureToWinExplorer()
ExportAction "Copy"
End Sub
Sub ExportAction(xAction As String)
Dim xFolder As Outlook.Folder
Dim xFldPath As String
xFldPath = SelectAFolder()
If xFldPath = "" Then
MsgBox "You did not select a folder. Export cancelled.", vbInformation + vbOKOnly, "Kutools for Outlook"
Else
Set xFSO = New Scripting.FileSystemObject
Set xFolder = Outlook.Application.ActiveExplorer.CurrentFolder
ExportOutlookFolder xFolder, xFldPath
End If
Set xFolder = Nothing
Set xFSO = Nothing
End Sub
Sub ExportOutlookFolder(ByVal OutlookFolder As Outlook.Folder, xFldPath As String)
Dim xSubFld As Outlook.Folder
Dim xItem As Object
Dim xPath As String
Dim xFilePath As String
Dim xSubject As String
Dim xFilename As String
On Error Resume Next
xPath = xFldPath & "\" & OutlookFolder.Name
'?????????,??????
If Dir(xPath, 16) = Empty Then MkDir xPath
For Each xItem In OutlookFolder.Items
xItem = ReplaceInvalidCharacters(xItem.Item)
xSubject = ReplaceInvalidCharacters(xItem.Subject)
xSubFld = ReplaceInvalidCharacters(xItem.SubFld)
xFldPath = ReplaceInvalidCharacters(xItem.FldPath)
xPath = ReplaceInvalidCharacters(xItem.Path)
xSubject = ReplaceInvalidCharacters(xItem.Subject)
xFilename = xSubject & ".msg"
xFilename = ReplaceInvalidCharacters(xItem.FileName)
xFilePath = xPath & "\" & xFilename
xFilePath = ReplaceInvalidCharacters(xItem.FilePath)
If xFSO.FileExists(xFilePath) Then
xCounter = xCounter + 1
xFilename = xSubject & " (" & xCounter & ").msg"
xFilePath = xPath & "\" & xFilename
xFilePath = ReplaceInvalidCharacters(xItem.FilePath)
End If
xItem.SaveAs xFilePath, olMSG
Next
For Each xSubFld In OutlookFolder.Folders
ExportOutlookFolder xSubFld, xPath
Next
Set OutlookFolder = Nothing
Set xItem = Nothing
End Sub
Function SelectAFolder() As String
Dim xSelFolder As Object
Dim xShell As Object
On Error Resume Next
Set xShell = CreateObject("Shell.Application")
Set xSelFolder = xShell.BrowseForFolder(0, "Select a folder", 0, 0)
If Not TypeName(xSelFolder) = "Nothing" Then
SelectAFolder = xSelFolder.self.Path
End If
Set xSelFolder = Nothing
Set xShell = Nothing
End Function
Function ReplaceInvalidCharacters(Str As String) As String
Dim xRegEx
Set xRegEx = CreateObject("vbscript.regexp")
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"
ReplaceInvalidCharacters = xRegEx.Replace(Str, "_")
End Function
Always use Option Explicit at the very top of every module, before any function. This will tell you if you have not Dim'med any variables. In this case there is an issue with xCount and xCounter, which should have only one name.
I think the problem may come from the function ExportOutlookFolder, this line:
xPath = xFldPath & "\" & OutlookFolder.Name
Try replacing it with:
xPath = xFldPath & "\" & ReplaceInvalidCharacters(OutlookFolder.Name)
When creating a new JIRA issue using REST API in VBA, I'm getting the following error message for custom field 13744: "Operation value must be a number".
I've tested the following code without the numeric field, and everything works fine, the issue is created and all the other fields value are passed:
Public Pass As Variant
Sub criarIssue()
Dim JiraService As New MSXML2.XMLHTTP60
Dim sErg As Variant
Dim sRestAntwort As Variant
Dim sSummary As Variant
Dim sDescription As Variant
Dim sProject As Variant
Dim sIssueType As Variant
Dim sData As Variant
Dim sPath As Variant
Dim sUsername As Variant
Dim sPassword As Variant
Dim sAux As Variant
Dim sStatus As Variant
Dim sEncbase64Auth As Variant
sUsername = Environ$("UserName")
Senha.Show
sPassword = Pass
sSummary = ActiveSheet.Range("C3").Value 'Issue name
sIssueType = "Projeto"
sProject = "EXP"
sData = " { ""fields"" : { ""project"" : { ""key"" : """ & sProject & """ }, ""summary"" : """ & _
sSummary & """, ""issuetype"" : { ""name"" : """ & sIssueType & """}, ""customfield_13744"" : ""1234"", ""customfield_13663"" : {""name"" : ""vitor.ribeiro""}, ""customfield_13670"" : ""2019-01-23 00:00:00"", ""customfield_13671"" : {""value"" : ""SP"" , ""child"" : {""value"" : ""SAO PAULO"" }}}} "
sEncbase64Auth = EncodeBase64(sUsername & ":" & sPassword)
'Creates Issue
With JiraService
.Open "POST", "http://172.16.2.128:8080/rest/api/2/issue/", False
.SetRequestHeader "Content-Type", "application/json"
.SetRequestHeader "Accept", "application/json"
.SetRequestHeader "X-Atlassian-Token", "nocheck"
.SetRequestHeader "Authorization", "Basic " & sEncbase64Auth
.Send (sData)
sRestAntwort = .ResponseText
sStatus = .Status & " | " & .StatusText
End With
' JSON Response
sAux = Replace(sRestAntwort, "{", "")
sAux = Replace(sAux, "}", "")
sAux = Split(sAux, ",")
sAux = sAux(1)
sAux = Split(sAux, ":")
sAux = sAux(1)
sAux = Replace(sAux, """", "")
ActiveSheet.Range("J2").Value = sStatus
ActiveSheet.Range("J3").Value = sRestAntwort & " | " & sAux
ActiveSheet.Range("J4").Value = ActiveSheet.Range("J4").Value + 1
ActiveSheet.Range("C2").Value = sAux
With JiraService
.Open "DELETE", "http://172.16.2.128:8080/rest/auth/1/session", False
.Send
End With
End Sub
Public Function EncodeBase64(text As String) As String
Dim arrData() As Byte
arrData = StrConv(text, vbFromUnicode)
Dim objXML As MSXML2.DOMDocument
Dim objNode As MSXML2.IXMLDOMElement
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
EncodeBase64 = objNode.text
Set objNode = Nothing
Set objXML = Nothing
End Function
All but custom field 13744 values are passed without a problem.
For this one I get the following error message:
{"errorMessages":[],"errors":{"customfield_13744":"Operation value must be a number"}
Why isn't it recognized as a number?
It turns out I just had to pass de numeric value without quotes, as suggested by #cyboashu. It's working now.
You must delete punctuation mark "
I have a macro that calculates distances between two points. I am unable to get it to work, and would like some help debugging it.
I have created a Google API key, and have incorporated that in as well, but for some reason the macro doesn't work
Public Function
GetDT(origin_city As String, _
origin_state As String, origin_country As String, _
destination_city As String, _
destination_state As String, destination_country As String _
)
Dim surl As String
Dim oXH As Object
Dim bodytxt As String
Dim distanc_e As String
surl = "http://maps.googleapis.com/maps/api/distancematrix/xml?origins="
& _
Replace(origin_city, " ", "+") & "+" & Replace(origin_state, " ", "+") &
"+" & Replace(origin_country, " ", "+") & _
"&destinations=" & _
Replace(destination_city, " ", "+") & "+" & Replace(destination_state, "
", "+") & "+" & Replace(destination_country, " ", "+") & _
"&mode=driving&units=metric&key=MY_KEY"
Set oXH = CreateObject("msxml2.xmlhttp")
With oXH
.Open "get", surl, False
.send
bodytxt = .responseText
End With
bodytxt = Right(bodytxt, Len(bodytxt) - InStr(1, bodytxt, "<text>") - 5)
tim_e = Left(bodytxt, InStr(1, bodytxt, "</text>") - 1)
bodytxt = Right(bodytxt, Len(bodytxt) - InStr(1, bodytxt, "<text>") - 5)
distanc_e = Left(bodytxt, InStr(1, bodytxt, "</text>") - 1)
GetDT = distanc_e
Set oXH = Nothing
End Function
There is no way to confidently answer this question with the information provided. Writing a separate function to create the url will make your code more testable. Using Option Explicit to force all variables to be declared will detect any typos.
If MY_KEY is a variable then the url should look like this "..metric&key=" & MY_KEY.
surl = GetDTURL(origin_city, origin_state, origin_country, destination_city, destination_state, destination_country)
Function GetDTURL(origin_city As String, origin_state As String, origin_country As String, destination_city As String, destination_state As String, destination_country As String)
Dim surl As String
Const BaseURl As String = "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=#origin_city+#origin_state+#origin_country&destinations=#destination_city+#destination_state+#destination_country&mode=driving&units=metric&key=MY_KEY"
surl = BaseURl
surl = Replace(surl, "#origin_city", origin_city)
surl = Replace(surl, "#origin_state", origin_state)
surl = Replace(surl, "#origin_country", origin_country)
surl = Replace(surl, "#destination_city", destination_city)
surl = Replace(surl, "#destination_state", destination_state)
surl = Replace(surl, "#destination_country", destination_country)
surl = Replace(surl, " ", "+")
GetDTURL = surl
End Function
I want to download multiple files from a list of links. The website where I find the links is protected. This is why I want to use IE (using the current session/cookie). The target of each link is a xml file. The files are too large to open and then save. So I need to save them directly (right-click, save target as).
The list of links looks like this:
<html>
<body>
<p> <a href="https://example.com/report?_hhhh=XML"Link A</a><br>> </p>
<p> <a href="https://example.com/report?_aaaa=XML"Link B</a><br>> </p>
...
</body>
</html>
I want to loop through all links and save each target. Currently I have problems with the "Save As". I don't really know how to do it. This is my code so far:
Sub DownloadAllLinks()
Dim IE As Object
Dim Document As Object
Dim List As Object
Dim Link As Object
' Before I logged in to the website
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True
IE.Navigate ("https:\\......\links.html")
Do While IE.Busy
DoEvents
Loop
' Detect all links on website
Set Document = IE.Document
Set List = Document.getElementsByTagName("a")
' Loop through all links to download them
For Each Link In List
' Now I need to automate "save target as" / right-click and then "save as"
...
Next Link
End Sub
Do you have any ideas to automate "Save As" for each link?
Any help is appreciated. Many thanks,
Uli
Private Declare PtrSafe Function Test Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Sub AutoOpen()
Dim strFile As String
Dim strURL As String
Dim strPath As String
Dim ret As Long
Dim strFile1 As String
Dim strURL1 As String
Dim strPath1 As String
Dim ret1 As Long
Dim Shex As Object
Dim Test2 As String
strFile = "1st_file"
strURL = "first-url" & strFile
strPath = Environ("UserProfile") & "your-path" & strFile
ret = Test(0, strURL, strPath, 0, 0)
strFile1 = "something_else"
strURL1 = "your-url" & strFile1
strPath1 = Environ("UserProfile") & "your-path" & strFile1
re1t = Test(0, strURL1, strPath1, 0, 0)
If ret <> 0 Then MsgBox "Something went wrong!", vbInformation
End Sub
You can use this macro to download multiple files. To download even more just duplicate this part
Dim strFile As String
Dim strURL As String
Dim strPath As String
Dim ret As Long
and this part:
strFile = "1st_file"
strURL = "first-url" & strFile
strPath = Environ("UserProfile") & "your-path" & strFile
ret = Test(0, strURL, strPath, 0, 0)
Obviously just change the variables and then you are good to go.
Below is a quite common example I adapted for your case, it shows the usage of XHR and RegEx to retrieve webpage HTML content, extract all links from it, and download each link's target file:
Option Explicit
Sub Test()
' declare vars
Dim sUrl As String
Dim sReqProt As String
Dim sReqAddr As String
Dim sReqPath As String
Dim sContent As String
Dim oLinks As Object
Dim oMatch As Object
Dim sHref As String
Dim sHrefProt As String
Dim sHrefAddr As String
Dim sHrefPath As String
Dim sHrefFull As String
Dim n As Long
Dim aContent() As Byte
' set source URL
sUrl = "https:\\......\links.html"
' process source URL
SplitUrl sUrl, sReqProt, sReqAddr, sReqPath
If sReqProt = "" Then sReqProt = "http:"
sUrl = sReqProt & "//" & sReqAddr & "/" & sReqPath
' retrieve source page HTML content
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", sUrl, False
.Send
sContent = .ResponseText
End With
' parse source page HTML content to extract all links
Set oLinks = CreateObject("Scripting.Dictionary")
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.IgnoreCase = True
.Pattern = "<a.*?href *= *(?:'|"")(.*?)(?:'|"").*?>"
For Each oMatch In .Execute(sContent)
sHref = oMatch.subMatches(0)
SplitUrl sHref, sHrefProt, sHrefAddr, sHrefPath
If sHrefProt = "" Then sHrefProt = sReqProt
If sHrefAddr = "" Then sHrefAddr = sReqAddr
sHrefFull = sHrefProt & "//" & sHrefAddr & "/" & sHrefPath
oLinks(oLinks.Count) = sHrefFull
Next
End With
' save each link target into file
For Each n In oLinks
sHref = oLinks(n)
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", sHref, False
.Send
aContent = .ResponseBody
End With
With CreateObject("ADODB.Stream")
.Type = 1 ' adTypeBinary
.Open
.Write aContent
.SaveToFile "C:\Test\" & n & ".xml", 2 ' adSaveCreateOverWrite
.Close
End With
Next
End Sub
Sub SplitUrl(sUrl, sProt, sAddr, sPath)
' extract protocol, address and path from URL
Dim aSplit
aSplit = Split(sUrl, "//")
If UBound(aSplit) = 0 Then
sProt = ""
sAddr = sUrl
Else
sProt = aSplit(0)
sAddr = aSplit(1)
End If
aSplit = Split(sAddr, "/")
If UBound(aSplit) = 0 Then
sPath = sAddr
sAddr = ""
Else
sPath = Mid(sAddr, Len(aSplit(0)) + 2)
sAddr = aSplit(0)
End If
End Sub
This method doesn't employ IE automation. Usually the IE's cookies which Microsoft.XMLHTTP processes are sufficient to refer to the current session, so if your website doesn't use additional procedures for authentication and generation the list of the links then the method should work for you.