VBA - Retrieve data from ASP page - vba

I originally created a VBA macro that would uses IE automation to click specific form buttons on an ASPX page. The page has 5 form options you have to pass through.
drop down list for group
drop down list for location
Graphical calendar where you select the date
List box for area's
Generate Report button
I would like to move away from using the IE automation to something more efficient. I have seen other posts where they were able to pull the data back using the MSXML object. This is what I was able to build from what I read but am not having any luck figuring out how to pass more than one of the form options. This is a company specific/internal website so unfortunately it is not available externally for me to be able to post the link example.
The element ID's are as follows; dlDivision, dlLocation, calRptDate, lbAreas, btnGenReport.
Public Sub XMLhttp_Search_Extract()
Dim URL As String
Dim XMLreq As Object
Dim POSTdata As String
Dim i As Integer
URL = "somewebURL.test.aspx"
POSTdata = "(" & Q("dlDivision") & ":" & Q("divisionNAMEHERE") & "," & Q("dlLocation") & ":" & Q("123 - Location") & ")"
Set XMLreq = CreateObject("MSXML2.XMLHTTP")
With XMLreq
.Open "POST", URL, False
.setRequestHeader "User-Agent", "Moilla/5.0 (Windows NT 5.1; rv:23.0) Gecko/20100101 Firefox/23.0"
.setRequestHeader "Referer", "somewebURL.test.aspx"
.setRequestHeader "Content-Type", "application/json; charset=utf-8"
.Send (POSTdata)
For i = 1 To Len(.responseText) Step 1023
MsgBox Mid(.responseText, i, i + 1023), _
Title:=i & " to " & Min(i + 1023 - 1, Len(.responseText)) & " of " & Len(.responseText)
Next i
End With
End Sub
Private Function Q(text As String) As String
Q = Chr(34) & text & Chr(34)
End Function
Private Function Min(n1 As Long, n2 As Long) As Long
Min = IIf(n1 < n2, n1, n2)
End Function

Related

Implement google translation

i have tried using google translate to translate names from language to another using c# and its working fine but now im trying to do the same thing using ms access vba i have tried so many ways but with no luck!
this is the code written in c# and its working fine
public string trans_arabic_to_english(string word)
{
var toLanguage = "en";//English
var fromLanguage = "ar";//Deutsch
var url = $"https://translate.googleapis.com/translate_a/single?client=gtx&sl={fromLanguage}&tl={toLanguage}&dt=t&q={HttpUtility.UrlEncode(word)}";
var webClient = new WebClient
{
Encoding = System.Text.Encoding.UTF8
};
var result = webClient.DownloadString(url);
try
{
result = result.Substring(4, result.IndexOf("\"", 4, StringComparison.Ordinal) - 4);
return result;
}
catch
{
return "Error";
}
}
this is the code in vba
Private Sub Command0_Click()
Dim toLan As String, fromLan As String, resp As String, s As String, a_name As String, url As String
toLang = "ar"
fromlang = "en"
a_name = "omar khalil"
url = "https://translate.googleapis.com/translate_a/single?"
url = url & "client=gtx&sl={""" & toLang & """}&tl={""" & fromlang & """}&dt=t&q={""" & a_name & """}"
url = "https://translate.googleapis.com/translate_a/single?client=gtx&sl="
url = url & fromlang & "&tl=" & to_lang & "&dt=t&q=" & a_name
'==
Dim ob As Object
Set ob = CreateObject("WinHttp.WinHttpRequest.5.1")
ob.Open "POST", url, False
ob.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
ob.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
ob.Send
If ob.Status <> 200 Then
resp = ob.ResponseText
MsgBox resp
End Sub
i have tried using WinHttp also with no luck at all!
any one can help me with this issue Thanks .
Try the next function, please:
Private Function GTranslate(strInput As String, strFromLang As String, strToLang As String) As String
Dim strURL As String, objHTTP As Object, objHTML As Object, objDivs As Object, objDiv As Variant
strURL = "https://translate.google.com/m?hl=" & strFromLang & _
"&sl=" & strFromLang & _
"&tl=" & strToLang & _
"&ie=UTF-8&prev=_m&q=" & strInput
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
objHTTP.Open "GET", strURL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.Send ""
Set objHTML = CreateObject("htmlfile")
With objHTML
.Open
.Write objHTTP.responseText
.Close
End With
Set objDivs = objHTML.getElementsByTagName("div")
For Each objDiv In objDivs
'If objDiv.className = "t0" Then 'it does not work, anymore
If objDiv.className = "result-container" Then 'adapted on December 28th
GTranslate = objDiv.innerText: Exit For
End If
Next objDiv
Set objHTML = Nothing: Set objHTTP = Nothing
End Function
It can be called in the next way:
Sub testTranslateG()
MsgBox GTranslate("Este es un libro", "auto", "en")
End Sub
The second parameter can be "auto" (like in the testing Sub), or the specific language abbreviation if more accurate translation needed ("es" - Spanish, "ru" - Russian, "ro" - Romanian etc.).
In order to find the correct abbreviation, you can open Google Translate page, right click and choose 'View page source'. Then try finding some language. Let us say Spanish. In that area you will see a script having strings like the following one: "code:'it',name:'Italian'". Easy to understand that "it" is the abbreviation for Italian...

Click on a href in VBA

I want to click on the following link
I have the class name and the line code I was trying ot use is the following:
objIE.document.getElementByClassName("msDataText searchLink").Click
This may well be a very basic question.. any guidance
Thanks a lot
Not sure if it is a duplicate question.
A good function GetHTTPResult is already available from the link. You need to just pass the url for the GET request to fetch the data. For POST request (this function will not work), you need to make a POST request with postdata.
Also there is a sample for XMLHttpRequest at link
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
Debug.Print "Status: " & XMLHTTP.Status & " - " & XMLHTTP.StatusText
sResult = XMLHTTP.ResponseText
Debug.Print "Length of response: " & Len(sResult)
Set XMLHTTP = Nothing
GetHTTPResult = sResult
End Function

Outlook VBA Passing form variables to XMLHTTP

I'm trying to pass textbox values from an Outlook userform to an asmx web service. I've done this successfully with PHP but now need to do so with VBA. Currently the form does absolutely nothing on submit. I believe something is wrong with what or how I'm passing to the send method. Any suggestions how I can get this to work?
CliAcctNo = TicketCreateForm1.CliAcctNo.Value
ContactName = TicketCreateForm1.ContactName.Value
ContactNum = TicketCreateForm1.ContactNum.Value
Ext = TicketCreateForm1.Ext.Value
Email = TicketCreateForm1.Email.Value
TicketTitle = TicketCreateForm1.TicketTitle.Value
TicketDesc = TicketCreateForm1.Desc.Value
'DataToPost = ("cliacctno=44121&pname=John&pnum=404-223-9655&ext=0&emailaddress=john#noemail.com&tickettitle=test from vab&ticketdetails=test line item vba")
'objEvn.Parameters.Create "Test", "Test"
DataToPost = ("CliAcctNo&ContactName&ContactNum&Ext&Email&TicketTitle&TicketDesc")
Set objHttp = New MSXML2.XMLHTTP
'Set objHttp = New MSXML2.XMLHTTPRequest
objHttp.Open "POST", "http://localhost/test/test.asmx"
objHttp.setRequestHeader "Content-Type", "text/xml"
'objHttp.setRequestHeader "SOAPAction", "CreateTicket"
objHttp.setRequestHeader "SOAPAction", "tempri.org/CreateTicket"
objHttp.Send (DataToPost)
In your posted code you're sending a fixed string to the web service: you need to somehow include your parameters in that -
CliAcctNo = TicketCreateForm1.CliAcctNo.Value
ContactName = TicketCreateForm1.ContactName.Value
ContactNum = TicketCreateForm1.ContactNum.Value
Ext = TicketCreateForm1.Ext.Value
Email = TicketCreateForm1.Email.Value
TicketTitle = TicketCreateForm1.TicketTitle.Value
TicketDesc = TicketCreateForm1.Desc.Value
'DataToPost = ("cliacctno=44121&pname=John&pnum=404-223-9655&ext=0&emailaddress=john#noemail.com&tickettitle=test from vab&ticketdetails=test line item vba")
DataToPost = "cliacctno=" & CliAcctNo & _
"pname=" & ContactName & _
"pnum=" & ContactNum & _
"ext=" & Ext & _
"emailaddress=" & Email & _
"tickettitle=" & TicketTitle & _
"ticketdetails=" & TicketDesc

VBA and SurveyMonkey API

I have tried to do access the SM API through VBA. I have left out the JSON for now as I am already in trouble. The below is giving me "Developer Inactive" as a result, though I have another project in VB.NET (using a .NET DLL) where the same key and token works fine and I can retrieve the list of surveys.
What am I doing wrong?
Public Sub GetSMList()
Dim apiKey As String
Dim Token As String
Dim sm As Object
apiKey = "myKey"
Token = "myToken"
Set sm = CreateObject("MSXML2.XMLHTTP.6.0")
With sm
.Open "POST", "https://api.surveymonkey.net/v2/surveys/get_survey_list", False
.setRequestHeader "Authorization", "Bearer " & Token
.setRequestHeader "Content-Type", "application/json"
.send "api_key=" & apiKey
result = .responseText
End With
End Sub
You're sending your API key as part of the request body of your POST request. Add the query parameter to the URL directly and this should work.
"https://api.surveymonkey.net/v2/surveys/get_survey_list?api_key=" & apiKey
You'll then need to use "send" to send a JSON encoded request object. For get_survey_list, an empty object ("{}") will get your started.
The purpose of this code is to show error handling. This is vbscript but vbscript is pastable into VBA. The error will probably tell you why.
ALWAYS DO ERRORS on files (users delete them), networking or internet (they are not guaranteed to work), and registry reads (users delete them).
The URL has to be 100% correct. Unlike a browser there is no code to fix urls.
The purpose of my program is to get error details.
How I get a correct URL is to type my url in a browser, navigate, and the correct URL is often in the address bar. The other way is to use Properties of a link etc to get the URL.
Also Microsoft.XMLHTTP maps to Microsoft.XMLHTTP.1.0. HKEY_CLASSES_ROOT\Msxml2.XMLHTTP maps to Msxml2.XMLHTTP.3.0. Try a later one
Try this way using xmlhttp. Edit the url's etc. If it seems to work comment out the if / end if to dump info even if seeming to work. It's vbscript but vbscript works in vb6.
On Error Resume Next
Set File = WScript.CreateObject("Microsoft.XMLHTTP")
File.Open "GET", "http://www.microsoft.com/en-au/default.aspx", False
'This is IE 8 headers
File.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 6.0; Trident/4.0; SLCC1; .NET CLR 2.0.50727; Media Center PC 5.0; .NET CLR 1.1.4322; .NET CLR 3.5.30729; .NET CLR 3.0.30618; .NET4.0C; .NET4.0E; BCD2000; BCD2000)"
File.Send
If err.number <> 0 then
line =""
Line = Line & vbcrlf & ""
Line = Line & vbcrlf & "Error getting file"
Line = Line & vbcrlf & "=================="
Line = Line & vbcrlf & ""
Line = Line & vbcrlf & "Error " & err.number & "(0x" & hex(err.number) & ") " & err.description
Line = Line & vbcrlf & "Source " & err.source
Line = Line & vbcrlf & ""
Line = Line & vbcrlf & "HTTP Error " & File.Status & " " & File.StatusText
Line = Line & vbcrlf & File.getAllResponseHeaders
wscript.echo Line
Err.clear
wscript.quit
End If
On Error Goto 0
Set BS = CreateObject("ADODB.Stream")
BS.type = 1
BS.open
BS.Write File.ResponseBody
BS.SaveToFile "c:\users\test.txt", 2
Also see if these other objects work.
C:\Users>reg query hkcr /f xmlhttp
HKEY_CLASSES_ROOT\Microsoft.XMLHTTP
HKEY_CLASSES_ROOT\Microsoft.XMLHTTP.1.0
HKEY_CLASSES_ROOT\Msxml2.ServerXMLHTTP
HKEY_CLASSES_ROOT\Msxml2.ServerXMLHTTP.3.0
HKEY_CLASSES_ROOT\Msxml2.ServerXMLHTTP.4.0
HKEY_CLASSES_ROOT\Msxml2.ServerXMLHTTP.5.0
HKEY_CLASSES_ROOT\Msxml2.ServerXMLHTTP.6.0
HKEY_CLASSES_ROOT\Msxml2.XMLHTTP
HKEY_CLASSES_ROOT\Msxml2.XMLHTTP.3.0
HKEY_CLASSES_ROOT\Msxml2.XMLHTTP.4.0
HKEY_CLASSES_ROOT\Msxml2.XMLHTTP.5.0
HKEY_CLASSES_ROOT\Msxml2.XMLHTTP.6.0
End of search: 12 match(es) found.
Also be aware there is a limit on how many times you can call any particular XMLHTTP object before a lockout occurs. If that happens, and it does when debugging code, just change to a different xmlhttp object

Object variable or With Block variable not set - Access 2010 VBA

Greetings to the well of knowledge...
I've been reading the numerous posts on this particular error and have not found anything that resolves my particular issue.
I have some VBA code within an Access 2010 front-end. Sometimes, but not always, I get a "Object variable or With block variable not set." error. My code is as follows:
Public Sub ValidateAddress(PassedAddress As Object, PassedCity As Object, PassedState As Object, _
PassedZIP As Object, PassedCongressionalDistrict As Object, PassedValidated As Object, HomeForm As Form)
On Error GoTo ShowMeError
Dim strUrl As String ' Our URL which will include the authentication info
Dim strReq As String ' The body of the POST request
Dim xmlHttp As New MSXML2.XMLHTTP60
Dim xmlDoc As MSXML2.DOMDocument60
Dim dbs As Database
Dim candidates As MSXML2.IXMLDOMNode, candidate As MSXML2.IXMLDOMNode
Dim components As MSXML2.IXMLDOMNode, metadata As MSXML2.IXMLDOMNode, analysis As MSXML2.IXMLDOMNode
Dim AddressToCheck As Variant, CityToCheck As Variant, StateToCheck As Variant, ZIPToCheck As Variant
Dim Validated As Boolean, District As Variant, MatchCode As Variant, Footnotes As Variant
Dim candidate_count As Long, SQLCommand As String, Start, Finish
' This URL will execute the search request and return the resulting matches to the search in XML.
strUrl = "https://api.smartystreets.com/street-address/?auth-id=<my_auth_id>" & _
"&auth-token=<my_auth_token>"
AddressToCheck = PassedAddress.Value
CityToCheck = PassedCity.Value
StateToCheck = PassedState.Value
If Len(PassedZIP) = 6 Then ZIPToCheck = Left(PassedZIP.Value, 5) Else ZIPToCheck = PassedZIP.Value
' Body of the POST request
strReq = "<?xml version=""1.0"" encoding=""utf-8""?>" & "<request>" & "<address>" & _
" <street>" & AddressToCheck & "</street>" & " <city>" & CityToCheck & "</city>" & _
" <state>" & StateToCheck & "</state>" & " <zipcode>" & ZIPToCheck & "</zipcode>" & _
" <candidates>5</candidates>" & "</address>" & "</request>"
With xmlHttp
.Open "POST", strUrl, False ' Prepare POST request
.setRequestHeader "Content-Type", "text/xml" ' Sending XML ...
.setRequestHeader "Accept", "text/xml" ' ... expect XML in return.
.send strReq ' Send request body
End With
' The request has been saved into xmlHttp.responseText and is
' now ready to be parsed. Remember that fields in our XML response may
' change or be added to later, so make sure your method of parsing accepts that.
' Google and Stack Overflow are replete with helpful examples.
Set xmlDoc = New MSXML2.DOMDocument60
If Not xmlDoc.loadXML(xmlHttp.ResponseText) Then
Err.Raise xmlDoc.parseError.errorCode, , xmlDoc.parseError.reason
Exit Sub
End If
' According to the schema (http://smartystreets.com/kb/liveaddress-api/parsing-the-response#xml),
' <candidates> is a top-level node with each <candidate> below it. Let's obtain each one.
Set candidates = xmlDoc.documentElement
' First, get a count of all the search results.
candidate_count = 0
For Each candidate In candidates.childNodes
candidate_count = candidate_count + 1
Next
Set candidates = xmlDoc.documentElement
Select Case candidate_count
Case 0 ' Bad address cannot be corrected. Try again.
Form_frmPeople.SetFocus
MsgBox "The address supplied does not match a valid address in the USPS database. Please correct this.", _
vbOKOnly, "Warning"
PassedAddress.BackColor = RGB(255, 0, 0)
PassedCity.BackColor = RGB(255, 0, 0)
PassedState.BackColor = RGB(255, 0, 0)
PassedZIP.BackColor = RGB(255, 0, 0)
Exit Sub
Case 1 ' Only one candidate address...use it and return.
For Each candidate In candidates.childNodes
Set analysis = candidate.selectSingleNode("analysis")
PassedAddress.Value = candidate.selectSingleNode("delivery_line_1").nodeTypedValue
Set components = candidate.selectSingleNode("components")
PassedCity.Value = components.selectSingleNode("city_name").nodeTypedValue
PassedState.Value = components.selectSingleNode("state_abbreviation").nodeTypedValue
PassedZIP.Value = components.selectSingleNode("zipcode").nodeTypedValue & "-" & _
components.selectSingleNode("plus4_code").nodeTypedValue
Set metadata = candidate.selectSingleNode("metadata")
PassedCongressionalDistrict.Value = CInt(metadata.selectSingleNode("congressional_district").nodeTypedValue)
PassedValidated.Value = True
Next
Exit Sub
Case Else ' Multiple candidate addresses...post them and allow the user to select.
DoCmd.SetWarnings False
Set dbs = CurrentDb
If IsTableQuery("temptbl") Then dbs.Execute "DROP TABLE temptbl"
dbs.Execute "CREATE TABLE temptbl (Selected BIT, CandidateAddress CHAR(50), CandidateCity CHAR(25), _
CandidateState CHAR(2), CandidateZIP CHAR(10), CandidateCongressionalDistrict INTEGER, _
MatchCode CHAR(1), Footnotes CHAR(30));"
DoCmd.SetWarnings True
Start = Timer
Do While Timer < Start + 1
DoEvents
Loop
For Each candidate In candidates.childNodes
Set components = candidate.selectSingleNode("components")
AddressToCheck = candidate.selectSingleNode("delivery_line_1").nodeTypedValue
CityToCheck = components.selectSingleNode("city_name").nodeTypedValue
StateToCheck = components.selectSingleNode("state_abbreviation").nodeTypedValue
ZIPToCheck = components.selectSingleNode("zipcode").nodeTypedValue & "-" & _
components.selectSingleNode("plus4_code").nodeTypedValue
Set metadata = candidate.selectSingleNode("metadata")
District = metadata.selectSingleNode("congressional_district").nodeTypedValue
Set analysis = candidate.selectSingleNode("analysis")
MatchCode = analysis.selectSingleNode("dpv_match_code").nodeTypedValue
Footnotes = analysis.selectSingleNode("dpv_footnotes").nodeTypedValue
DoCmd.SetWarnings False
dbs.Execute "INSERT INTO temptbl ( CandidateAddress, CandidateCity, CandidateState, CandidateZIP, _
CandidateCongressionalDistrict, MatchCode, Footnotes ) " & vbCrLf & "SELECT """ & AddressToCheck & _
""" AS Expr1, """ & CityToCheck & """ AS Expr2, """ & StateToCheck & """ AS Expr3, """ & _
ZIPToCheck & """ AS Expr4, " & District & " AS Expr5, """ & MatchCode & """ AS Expr6, """ & _
Footnotes & """ AS Expr7;"
DoCmd.SetWarnings True
Next
DoCmd.OpenForm "frmPeopleAddressMaintenance"
Do Until CurrentProject.AllForms("frmPeopleAddressMaintenance").IsLoaded = False
DoEvents
Loop
HomeForm.SetFocus
If IsTableQuery("temptbl") Then dbs.Execute "DROP TABLE temptbl"
End Select
dbs.Close
Exit Sub
ShowMeError:
MsgBox Err.Description, vbOKOnly, "ERROR!"
End Sub
The error occurs in two specific places:
Under the "Case 1": The error happens immediately after...
PassedCongressionalDistrict.Value = CInt(metadata.selectSingleNode("congressional_district").nodeTypedValue)
...is executed. I have debugged this and verified that the statement executed properly and that the value of the "PassedCongressionalDistrict" object is correct.
Then, under "Case Else": The For loop processes the first item list correctly, but fails with the identified error when beginning processing the second item, even though there is good and legitimate data in the second item.
I hope I've explained this well enough. I just can't seem to figure out (1) how to more fully debug this and (2) why the error occurs as it seems that I have all of my object variables defined properly.
Regards,
Ken
It's almost definitely because (on occasion) there is no child node member named "metadata" in the XML body - so when you try to bind your "metadata" object to the .selectSingleNode() method it returns Nothing. You can always check to make sure that it's actually bound...
'// ...start code snippet...
Set metadata = candidate.selectSingleNode("metadata")
If Not metadata is Nothing Then
PassedCongressionalDistrict.Value = CInt(metadata.selectSingleNode("congressional_district").nodeTypedValue)
End If
PassedValidated.Value = True
'// ...end code snippet...