Public myHTTP As MSXML2.XMLHTTP60
Sub SendXML()
Dim response As String
Dim MyXmlHttpHandler As CXMLHTTPHandler
Dim myxml As String
Dim a As String
Dim URL2 As String
Dim FSO As Object
Dim NewFile As Object
Dim XMLFileText As String
If Not myHTTP Is Nothing Then Set myHTTP = Nothing
Set myHTTP = New MSXML2.XMLHTTP60
Set MyXmlHttpHandler = New CXMLHTTPHandler
MyXmlHttpHandler.Initialize myHTTP
myHTTP.OnReadyStateChange = MyXmlHttpHandler
myxml = "D:\1.xml"
myHTTP.Open "get", myxml, True
myHTTP.send (myxml)
a = myHTTP.responseText
URL2=Workbooks("MainSheet.xlsm").Worksheets("OTHERS").Range("I2").Value
If Workbooks("MainSheet.xlsm").Worksheets("OTHERS").Range("h2").Value = vbNullString Or Workbooks("MainSheet.xlsm").Worksheets("OTHERS").Range("h3").Value = vbNullString Then
MsgBox "User not defined server database address or port number...!!!" & vbNewLine & " Failed.."
Exit Sub
End If
myHTTP.Open "POST", URL2, True
myHTTP.send (a)
Set FSO = CreateObject("Scripting.FileSystemObject")
Set NewFile = FSO.CreateTextFile("D:\response.XML", 1, 1)
XMLFileText = ""
NewFile.write (XMLFileText & myHTTP.responseText & vbNewLine) ‘---------error occurred here not printing my response.text in new file.
End Sub
I have already tried on error resume next, it just printing a blank file.
I have also tried on error goto errorhandler
but it also failed saying runtime error dialoge box....
I just want to save response text in a xml file without any error dialouge box..
For future readers
Change the last argument from True to False
myHTTP.Open "POST", myxml, False
Allow time for completion
Is this a large file? Why use async wrapper this way? Why not simple xmlhttp POST request with False argument? – QHarr 8 mins ago
this comment solved my error..... thnks
Related
my code is below. narDocument is throwing on error on
narDocument.Quit False
The error is "Runtime Error 438: Object doesn't support this object or method"
When I check the object type of narDocument, it's type 8, which is a String.
So it makes sense that an object of type String wouldn't have the method .Quit, but my question is - why is this a String in the first place? I can't see where it's actually assigned to being a String, and all the rest of the code works as intended... which I think would be the case if this was indeed a String. Thanks!
Public Sub testing_1()
Dim narApplication As Word.Application
Dim narDocument As Word.Document
Set narApplication = CreateObject("word.application")
Set narDocument = narApplication.Documents.Open(ThisWorkbook.Path & "/document_template.docx")
MsgBox VarType(narDocument)
Dim TITLE As String
Dim myRange As Word.range
Dim myFind As Word.Find
Dim filePath As String
TITLE = range("B1")
'For each value, find it's value in the blankdocument
Set myRange = narDocument.Content
Set myFind = myRange.Find
With myFind
.Text = "__TITLE__"
searchResult = .Execute
End With
MsgBox VarType(narDocument)
narDocument.Hyperlinks.Add Anchor:=myRange, Address:="http://www.google.com", TextToDisplay:=TITLE
filePath = ThisWorkbook.Path & "/document_test.docx"
narDocument.SaveAs2 Filename:=filePath
MsgBox VarType(narDocument)
' Cleanup
narDocument.Quit False
Set narApplication = Nothing
Set narDocument = Nothing
End Sub
You get 8 from VarType as the default property of a Document object is its Name property which returns a String.
Assuming you want to close the Document without saving and then quit Word, amend your line
narDocument.Quit False
to
narDocument.Close False
narApplication.Quit
I wrote some code to GET a response from a server using early binding (first statement when mbEARLY_BINDING_FSO = True
Option Explicit
Option Private Module
#Const mbEARLY_BINDING_FSO = False
Private Const msMODULE_NAME As String = "Controls"
Public Sub refresh_database()
Const sPROC_NAME As String = "refresh_database()"
If Not gbDEBUG Then On Error GoTo errExitLL
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'LOWER LEVEL PROCEDURE
'Comments: Refresh the database from call to app.longtrend.com/api/seach?map=tickers
'Agurments: None
'Dependencies: None
'Returns: JSON object of available companies listed to Company List sheet
'----------------------------------------------------------------------------------------------------------------------
Dim base_url As String
Dim successMsg As Variant
Dim Json As Object
Dim account_key As Variant
Dim dict_key As Variant
Dim item As Variant
Dim sheet_ticker As Worksheet
Dim lrow As Long
Dim lcol As Long
Dim rng As Range
#If mbEARLY_BINDING_FSO Then
Dim xml_obj As MSXML2.XMLHTTP60
Set xml_obj = New MSXML2.XMLHTTP60
#Else
Dim xml_obj As Object
Set xml_obj = CreateObject("MSXML2.XMLHTTP.6.0")
#End If
Set sheet_ticker = Sheets("Admin_Control")
UserFormProgress.Display 5, False
UserFormProgress.SetText "Checking stuff XX ..."
Application.Wait Now + #12:00:01 AM#
base_url = "https://app.longtrend.com/api/search?map=tickers"
'Open a new get request using URL
xml_obj.Open bstrMethod:="GET", bstrURL:=base_url
xml_obj.send
'set up the object and parse the response
Set Json = JsonConverter.ParseJson(xml_obj.responseText)
' Status code router - 200 is Success, all else will print error in range("STATUS") and exit sub
If xml_obj.Status <> 200 Then
With Range("STATUS")
.Value = xml_obj.Status & ": " & Json("Error")
.Font.Color = RGB(255, 143, 143)
End With
Application.ScreenUpdating = True
End
End If
'Parse Json object
Dim i As Long
Dim key As Variant
i = rng.Row + 1
For Each key In Json
sheet_ticker.Cells(i, rng.Column) = key
sheet_ticker.Cells(i, rng.Column + 1) = Json(key)("name")
sheet_ticker.Cells(i, rng.Column + 2) = Json(key)("sector")
sheet_ticker.Cells(i, rng.Column + 3) = Json(key)("industry")
sheet_ticker.Cells(i, rng.Column + 4) = Json(key)("marketCap")
sheet_ticker.Cells(i, rng.Column + 5) = Json(key)("lastFY")
i = i + 1
Next
Exit Sub
errExitLL:
Application.ScreenUpdating = True
ErrorHandling.LowLevel msMODULE_NAME, sPROC_NAME, "url", base_url, "last row", lrow
End Sub
With early binding, my xml_obj response is as exptected. The responseText stores all values to be parsed in the JSON converter. Now, prior to release I'd like to set to late binding. I've created the object as shown in the second statement however the responseText in the locals window says: this method cannot be called until the send method has been called. The xml_obj is sent prior to this local response.
I have tried the following so far:
Set xml_obj = CreateObject("Microsoft.XMLHTTP")
Set xml_obj = CreateObject("MSXML2.XMLHTTP60")
Set xml_obj = CreateObject("MSXML2.XMLHTTP.6.0")
Set xml_obj = CreateObject("MSXML2.ServerXMLHTTP")
To no avail! An error occur either when I attempt to create the object CreateObject(XX) and there is no associated ActiveX available, or as mentioned above, the response request isn't correct once the request is sent. I'm not sure what I'm missing as this should be a simple enough activity. Any help is much appreciated.
Running Office 365 (build 14228) for Windows (64 bit, VBA7)
Thanks,
Scott
If you don't specify a value, then the third argument to Open (asynchronous) defaults to True, so you should pass False there.
If you run asynchronously your code will not wait until the response is complete.
The asterisks indicate where the error is occuring
Below is he code that I am using
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row = Range("Item_ID").Row And _
Target.Column = Range("Item_ID").Column Then
Dim ie As New InternetExplorer
'Set IE.Visible
ie.Visible = True
***ie.navigate "https://portal.shiptrackapp.com/Admin/reports.aspx?records=" & Range("Item_ID").Value***
Do
DoEvents
Loop Until ie.readyState = READYSTATE_COMPLETE
Dim Doc As HTMLDocument
Set Doc = ie.document
Dim odd As String
odd = Trim(Doc.getElementsByClassName("odd")(1).innerText)
ie.Quit
Dim aodd As Variant
aodd = Split(sodd, ",")
Range("Tracking_Number").Value = aodd(3)
Range("Item_ID").Value = aodd(0)
Range("pick_up_date").Value = aodd(2)
Range("Delivery_Status_Date").Value = aodd(3)
Range("Time").Value = aodd(4)
Range("Delivery_Driver_Name").Value = aodd(5)
Range("Status").Value = aodd(6)
Range("Stats_des").Value = aodd(7)
Range("Comments").Value = aodd(8)
Range("Signed_By").Value = aodd(9)
Range("Del_Add").Value = aodd(10)
Range("History").Value = aodd(11)
Range("Transaction_ID").Value = aodd(12)
Range("ScanCode_dt").Value = aodd(13)
Range("Company_Name").Value = aodd(14)
Range("Def_loc_id").Value = aodd(15)
Range("Dri_cmmts").Value = aodd(16)
Range("creation_dt").Value = aodd(17)
Range("scan_type").Value = aodd(18)
End If
End Sub
You may have modelled your code on this site, where the syntax appears 100% identical with yours.
Dim ie As New InternetExplorer
Dim doc As New HTMLDocument
Dim ecoll As Object
ie.Visible = True
ie.navigate "http://demo.guru99.com/test/web-table-element.php"
Do
DoEvents
Loop Until ie.readyState = READYSTATE_COMPLETE
Set doc = ie.documen
The line of code that gives the trouble has a concatenated string. I suggested you eliminate that and try your code with a hard-coded string as shown above. If that works the problem must be caused by the concatenation: either the variable read from the worksheet or the concatenation syntax itself. Please do the first test first.
I don't use IE myself. Here is working code I use every day. Note that the argument HTMLdoc is a return object. It is passed to the function empty, the function fills it up and the calling procedure receives it back.
Function GetHTMLDoc(ByVal Site As Nur, _
HTMLdoc As MSHTML.HTMLDocument, _
Optional Secty As String) As Boolean
' NIC 003 ++ 10 Aug 2020
' return Not True if the site couldn't be reached
Dim URL As String
Dim Response As String
URL = StoredURL(Site, Secty)
' URL is a string like "https://portal.shiptrackapp.com/Admin/reports.aspx?records=MAA12345"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False ' not asynchronous
On Error GoTo NoURL
.Send
Response = StrConv(.responseBody, vbUnicode)
End With
On Error GoTo 0
Set HTMLdoc = New HTMLDocument
HTMLdoc.Body.innerHTML = Response
GetHTMLDoc = True
Exit Function
NoURL:
Msg.InfoBox "NoURL", 0, vbInformation, URL ' this is a MsgBox
Err.Clear
End Function
You may like to google for the "MSXML2.XMLHTTP" object to find code that handles the HTMLdocument. Basically, "MSXML2.XMLHTTP" connects to the Internet without the use of a browser. However, changing the system shouldn't solve your problem because that lies with the variable URL (in my code) which you will need in whichever system you deploy. Therefore I recommend that you try your existing code without the concatenation.
To take this one step further: If the hard-coded string also fails then the problem might be with the IE. You may have to load a reference library (DLL) to use it. In that case the surprise would be that no error occurs at ie.Visible = True or even Dim ie As New InternetExplorer and the possibility of using another system appears in a new light.
I am trying to use a conditional code for Object such that if value/text is found in object (in my example it is JSONObject) then do something otherwise nothing. But when I run the code it is working only when found in object and shows "runtime error" when it is not found in object.
The code is:-
Private Sub CommandButton3_Click()
Dim jsonText As String
Dim FSO As New FileSystemObject
Dim JsonTS As TextStream
Dim jsonObject As Object('It is an object created )
myfile = Application.GetOpenFilename(FileFilter:="JSON file (*.json), *.json", Title:="Get File", MultiSelect:=True)
Set JsonTS = FSO.OpenTextFile(myfile, ForReading)
jsonText = JsonTS.ReadAll
JsonTS.Close
Set jsonObject = JsonConverter.ParseJson(jsonText)
' Condition that if in jsonObect, "b2b" is found then
If Not jsonObject("b2b") Is Nothing Then
For Each item In jsonObject("b2b") '("inv")
Sheet3.Cells(a, 2) = jsonObject("fp")
Sheet3.Cells(a, 1) = item("ctin")
End If
End Sub
I'd rather have JSON to test with but you could attempt to set jsonObject("b2b") into a new variable wrapped within an On Error Resume Next and then test that for If Not Is Nothing
Dim b2bObject As Object
Dim item As Variant '<<=== ? missing from your code
On Error Resume Next
Set b2bObject = jsonObject("b2b")
On Error GoTo 0
If Not b2bObject Is Nothing Then
For Each item In b2bObject
Sheet3.Cells(a, 2) = jsonObject("fp")
Sheet3.Cells(a, 1) = item("ctin")
Next
End If
If using in a loop you may wish to Set b2bObject = Nothing before End If as safeguard.
I am trying to make a part in my routine which retrieves a .xls document from a FTP location.
I have been googling for quite a few hours now and I am starting to get quite frustrated with this piece of code.
When running the code I get Run-Time error '3001' saying that my arguments are either of the wrong type and are out of the aceptable range, or are in conflict with one another.
Sub GetFTPFile()
Dim objXML
Dim strFTPResponse
Dim varUser, varPassword As Variant
Dim LocalDir As String
Set objXML = CreateObject("MSXML2.XMLHTTP")
strURL = "ftp://xyz_hourly.xls"
LocalDir = "c//"
varUser = "xxx"
varPassword = "yyy"
Call objXML.Open("GET", strURL, varUser, varPassword, False)
Call objXML.send
Do While objXML.readystate <> 4
DoEvents
Loop
Set File = CreateObject("ADODB.Stream")
File.Type = 1
File.Open
File.Write objXML.ResponseBody
File.SaveToFile "c//yyy.xlsx", 2
End Sub