Object variable or With Block variable not set - Access 2010 VBA - 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...

Related

Auto insert individual members' names and their amounts into a message body and send as SMS to their corresponding numbers

This question is about BulkSMS Messaging.
Sending the same message to different contacts is successful. The problem is, how can i personalized the message to send to their respective recipients.
For instance, in sending the message, i would like an access vba code to auto insert the individual members' names and their amounts into the message body and send to their corresponding numbers.
Something like this; (Dear [NameField], your [AmountField] has been received. Thank you.)
Updated:
The sSendMessage procedure below is what I call to send my messages. The way it works is like, there is a button that when clicked it populates the ttcontact textbox with MembersNumbers. The user then typed the message in the ttmessage textbox and in sending it then uses sSendMessage procedure to send the message in the ttmessage to the contacts in the ttcontacts.
Ever since you (# Applecore) responded to my question, I have been trying how to work around it but don’t know where to start. This time around too, there will be no ttmessage and ttcontact for the user to typed data, every info will be selected from the tblMember table and uniquely sent to their respective contacts. Can you please possibly look at my sSendMessages and check how it can be called by the sSend2Member to send the message row by row till it gets to the last record.
Private Sub sSendMessages()
Dim myURL As String
Dim sender As String
Dim contact As String
Dim msg As String
Dim postData As String
Dim winHttpReq As Object
apikey = "xxxxxxxxxxxxx"
sender = Me.ttSender.Value
contact = Me.ttContact.Value
msg = Me.ttMessage.Value
Set winHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
myURL = "https://apps.mnotify.net/smsapi?key=" & apikey & "&to=" & contact & "&msg=" & msg & "&sender_id=" & sender
postData = "key=" + apikey _
+ "&to=" + contact _
+ "&msg=" + msg _
+ "&sender_id=" + sender
winHttpReq.Open "POST", myURL, False
winHttpReq.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
winHttpReq.send (postData)
SendSMS = winHttpReq.ResponseText
MsgBox SendSMS
End If
End Sub
If you have already created a procedure that sends a message (for example sSendMessage), you can modify it to accept the number and message. You can then have some code like this which accepts the ID field from the table of members and then calls sSendMessage:
Sub sSend2Member(lngMember As Long)
On Error GoTo E_Handle
Dim db As DAO.Database
Dim rsData As DAO.Recordset
Dim strMsg As String
Set db = DBEngine(0)(0)
Set rsData = db.OpenRecordset("SELECT * FROM tblMember WHERE MemberID=" & lngMember)
If Not (rsData.BOF And rsData.EOF) Then
strMsg = "Dear " & rsData!MemberName & ", "
strMsg = strMsg & "your " & Format(rsData!MemberAmount, "#0.00") & " has been received. Thank you."
Call sSendMessage(rsData!MemberNumber, strMsg)
End If
sExit:
On Error Resume Next
rsData.Close
Set rsData = Nothing
Set db = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sSend2Member", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
If you are sending to 6 members, then you would call this procedure with each of the 6 MemberIDs.
Regards,

vb.net WPF application combobox not waiting for user to choose

I have a wpf vb.net application (written in VS 2019 community) containing two website searches. The first search is a string search and that either produces one result, which I then load into the second search, or it produces more than one result, which I load into a combobox to let the user choose. My problem is getting the application to stop and allow the user to choose from the combobox. I have implemented a workaround that uses a modal form containing a combobox and this allows the user to choose from the combobox and supply the value to the second search. I have been advised to use the 'change' event for the combobox but there isn't one available, I have also been advised to use the selectedindexchanged but the control doesn't let the dropdown list occur to select anything. I have also tried using various forms of addhandler (commented out in the code below).
' Build the 'Search API' URL.
Dim uri = New Uri("https://api.themoviedb.org/3/search/tv?" _
& "api_key=" & TMDBAPIKey _
& "&language=en-US" _
& "&query=" & sLvl1NodeName _
& "&page=1" _
& "&first_air_date_year=" & sFirstXmitYear)
' Retrieve the IMDB ID with an API Search function using the series title
Try
Dim Site = New WebClient()
Answer = Site.DownloadString(uri)
Catch ex As NullReferenceException
Dim messagetext As String = "The 'Search API' from GetDetails popup failed with : " _
& ex.Message & " for: Title=" & sLvl1NodeName
Me.txtErrorMessageBox.Text = messagetext
Exit Sub
End Try
' Deserialise the answer
Dim JsonElem As TMDBtitle = JsonConvert.DeserializeObject(Of TMDBtitle)(Answer)
' If the websearch finds only one result this is the TV series we want, if more than
' one result is found load the results into a combobox and get the user to choose.
If JsonElem.results.Length = 1 Then
TVSeriesID = JsonElem.results(0).id
Else
Me.cmbChooseSeries.BeginUpdate()
Me.lblChooseSeries.Text = Me.lblChooseSeries.Text & "( " & JsonElem.results.Length & " )"
Me.cmbChooseSeries.Items.Clear()
For Each titleresult In JsonElem.results
ComboSeriesChoice = titleresult.name & " | " &
titleresult.id & " | " &
titleresult.first_air_date & " | " &
titleresult.overview
Me.cmbChooseSeries.Items.Add(ComboSeriesChoice)
Next
cmbChooseSeries.DroppedDown = True
Me.cmbChooseSeries.EndUpdate()
If cmbChooseSeries.SelectedIndex <> -1 Then
Dim var1 = cmbChooseSeries.SelectedText
Else
Threading.Thread.Sleep(3000)
End If
'AddHandler cmbChooseSeries.MouseDoubleClick,
'Sub()
'Threading.Thread.Sleep(3000)
'End Sub
TVSeriesID = cmbChooseSeries.SelectedItem
End If
' Build the 'TV Search API' call URL.
Dim urix = New Uri("https://api.themoviedb.org/3/tv/" _
& TVSeriesID & "?" _
& "api_key=" & TMDBAPIKey _
& "&language=en-US")
Try
Dim site = New WebClient()
Answer = site.DownloadString(urix) ' download the JSON from the server.
Catch ex As NullReferenceException
Dim MessageText As String = "The 'TV Search API' from GetDetails popup failed with : " _
& ex.Message & " for: Title=" & sLvl1NodeName & " ID=" & popupid
Me.txtErrorMessageBox.Text = MessageText
Exit Sub
End Try
Dim jsonelemx = JsonConvert.DeserializeObject(Of TVResult)(Answer)
lstDetailItems(0) = "Name"
lstDetailItems(1) = jsonelemx.name
lstDetailItems(2) = (String.Empty)
Dim DelItems = New ListViewItem(lstDetailItems)
Me.lstSeriesDetails.Items.Add(DelItems)
lstDetailItems(0) = "Status"
lstDetailItems(1) = jsonelemx.status
lstDetailItems(2) = (String.Empty)
DelItems = New ListViewItem(lstDetailItems)
Me.lstSeriesDetails.Items.Add(DelItems)
lstDetailItems(0) = "Episode run time"
lstDetailItems(1) = Convert.ToString(jsonelemx.episode_run_time(0))
lstDetailItems(2) = (String.Empty)
DelItems = New ListViewItem(lstDetailItems)
Me.lstSeriesDetails.Items.Add(DelItems)

Parsing xml string in VBA

I am trying to parse xml document that i am getting from a website.
from some reason i cant figure out i cant parse the value inside the 'RATE' node.
the xml string seems O.K.
but in the end of the code (commented) i get Object variable or With block variable not set error.
i will be grateful for any help.
XML STRING:
<?xml version="1.0" encoding="utf-8" standalone="yes"?>
<CURRENCIES>
<LAST_UPDATE>2016-01-25</LAST_UPDATE>
<CURRENCY>
<NAME>Dollar</NAME>
<UNIT>1</UNIT>
<CURRENCYCODE>USD</CURRENCYCODE>
<COUNTRY>USA</COUNTRY>
<RATE>3.982</RATE>
<CHANGE>0.277</CHANGE>
</CURRENCY>
</CURRENCIES>
VBA CODE:
Private Sub loadXMLString(xmlString)
Dim strXML As String
Dim xNode As IXMLDOMNode
Dim XDoc As MSXML2.DOMDocument
strXML = xmlString
Set XDoc = New MSXML2.DOMDocument
If Not XDoc.LoadXML(strXML) Then 'strXML is the string with XML'
Err.Raise XDoc.parseError.ErrorCode, , XDoc.parseError.reason
End If
Set xNode = XDoc.FirstChild
Debug.Print xNode.SelectSingleNode("RATE").Text ' here i get the Object variable or With block variable not set error
Debug.Print xNode.ChildNodes(2).SelectSingleNode("RATE").Text ' also with that try i get the Object variable or With block variable not set error
End Sub
UPDATE:
i found the problem (as i wrote down in the comments to #Nathan).
the problem is the <?xml version="1.0" encoding="utf-8" standalone="yes"?> node
Tested it an this code is working:
so how can i do that with out to remove this node as a substring, there must be a way i guess, but i dont have a lot of experience working with XML
Private Sub loadXMLString(xmlString)
Dim strXML As String
Dim xNode As IXMLDOMNode
Dim XDoc As MSXML2.DOMDocument
strXML = "<CURRENCIES>" & _
"<LAST_UPDATE>2016-01-25</LAST_UPDATE>" & _
"<CURRENCY>" & _
"<NAME>Dollar</NAME>" & _
"<UNIT>1</UNIT>" & _
"<CURRENCYCODE>USD</CURRENCYCODE>" & _
"<COUNTRY>USA</COUNTRY>" & _
"<RATE>3.982</RATE>" & _
"<CHANGE>0.277</CHANGE>" & _
"</CURRENCY>" & _
"</CURRENCIES>"
Set XDoc = New MSXML2.DOMDocument
If Not XDoc.LoadXML(strXML) Then 'strXML is the string with XML'
Err.Raise XDoc.parseError.ErrorCode, , XDoc.parseError.reason
End If
Set xNode = XDoc.FirstChild
Debug.Print strXML
Debug.Print xNode.ChildNodes(1).SelectSingleNode("RATE").Text ' also with that try i get the Object variable or With block variable not set error
End Sub
SelectSingleNode() expects an XPath expression. Try this one:
xNode.SelectSingleNode("//RATE").Text
But in general it's not very smart to access properties of an object reference that could be Nothing – like it is in the above case, if SelectSingleNode does not find any matching node, this line will trigger a run-time error ("Object variable or With block variable not set", which effectively is a null pointer exception.)
Always guard your property accesses by validating your object reference:
Set rate = xNode.SelectSingleNode("//RATE")
If rate Is Nothing Then
Debug.Print "Error: no RATE found in document"
Else
Debug.Print rate.Text
End If
FWIW, here is a complete version of the code I would use, featuring a few nice details like a custom type for currency information and the use the Sleep() function to wait for the server to return the XML document:
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Type CurrencyInfo
Success As Boolean
LastUpdate As Date
Name As String
Unit As Double
CurrencyCode As String
Country As String
Rate As Double
Change As Double
End Type
Private Function GetXmlDoc(url As String) As MSXML2.DOMDocument60
With New MSXML2.XMLHTTP60
.Open "GET", url, False
.send
While .readyState <> 4: Sleep 50: Wend
If .Status = 200 Then
If .responseXML.parseError.ErrorCode = 0 Then
Set GetXmlDoc = .responseXML
Else
Err.Raise vbObjectError + 1, "GetXmlDoc", "XML parser error: " & .responseXML.parseError.reason
End If
Else
Err.Raise vbObjectError + 2, "GetXmlDoc", "Server responded with status code " & .Status
End If
End With
End Function
Public Function GetCurrencyInfo(currencyName As String) As CurrencyInfo
Dim curr As MSXML2.DOMDocument60
Set curr = GetXmlDoc("http://the/url/you/use?currency=" + currencyName)
GetCurrencyInfo.Success = True
GetCurrencyInfo.LastUpdate = CDate(GetText(curr, "//LAST_UPDATE"))
GetCurrencyInfo.Name = GetText(curr, "//NAME")
GetCurrencyInfo.Unit = Val(GetText(curr, "//UNIT"))
GetCurrencyInfo.CurrencyCode = GetText(curr, "//CURRENCYCODE")
GetCurrencyInfo.Country = GetText(curr, "//COUNTRY")
GetCurrencyInfo.Rate = Val(GetText(curr, "//RATE"))
GetCurrencyInfo.Change = Val(GetText(curr, "//CHANGE"))
End Function
Private Function GetText(context As IXMLDOMNode, path As String) As String
Dim result As IXMLDOMNode
If Not context Is Nothing Then
Set result = context.SelectSingleNode(path)
If Not result Is Nothing Then GetText = result.Text
End If
End Function
Usage is as follows:
Sub Test()
Dim USD As CurrencyInfo
USD = GetCurrencyInfo("USD")
Debug.Print "LastUpdate: " & USD.LastUpdate
Debug.Print "Name: " & USD.Name
Debug.Print "Unit: " & USD.Unit
Debug.Print "CurrencyCode: " & USD.CurrencyCode
Debug.Print "Country: " & USD.Country
Debug.Print "Rate: " & USD.Rate
Debug.Print "Change: " & USD.Change
End Sub
Tried this, and got somwhere.
Dim strXML As String
Dim xNode As IXMLDOMNode
Dim XDoc As MSXML2.DOMDocument
Dim xParent As IXMLDOMNode
Dim xChild As MSXML2.IXMLDOMNode
strXML = xmlString
Set XDoc = New MSXML2.DOMDocument
If Not XDoc.Load(strXML) Then 'strXML is the string with XML'
Err.Raise XDoc.parseError.ErrorCode, , XDoc.parseError.reason
End If
Set xNode = XDoc.DocumentElement
Set xParent = xNode.FirstChild
For Each xParent In xNode.ChildNodes
For Each xChild In xParent.ChildNodes
Debug.Print xChild.Text
Next xChild
Next xParent

SQL Server (specific) table not updating

I am having a really strange issue with classic asp insert/update that worked flawlessly for years and was never altered. Out of the blue, the table is no longer updating or taking new records. The code does not throw any errors and the SQL Server log shows no errors either. Other tables in the same database work fine so I can insert and update without issues.
Is there a way to find out what is happening with this table or whether it is locked for some reason. I restarted SQL Server and web application, even the server and no luck.
I updated the table directly in SQL Server and it updates and inserts new records fine.
I used the same code on another table and was able to update records.
Can someone please point me in the right direction as I am out ideas on what may be causing this.
Thanks in advance.
Here is the code:
<%
' *** Edit Operations: (Modified for File Upload) declare variables
Dim MM_editAction
Dim MM_abortEdit
Dim MM_editQuery
Dim MM_editCmd
Dim MM_editConnection
Dim MM_editTable
Dim MM_editRedirectUrl
Dim MM_editColumn
Dim MM_recordId
Dim MM_fieldsStr
Dim MM_columnsStr
Dim MM_fields
Dim MM_columns
Dim MM_typeArray
Dim MM_formVal
Dim MM_delim
Dim MM_altVal
Dim MM_emptyVal
Dim MM_i
MM_editAction = CStr(Request.ServerVariables("SCRIPT_NAME"))
If (UploadQueryString <> "") Then
MM_editAction = MM_editAction & "?" & Server.HTMLEncode(UploadQueryString)
End If
' boolean to abort record edit
MM_abortEdit = false
' query string to execute
MM_editQuery = ""
%>
<%
' *** Insert Record: (Modified for File Upload) set variables
If (CStr(UploadFormRequest("MM_insert")) = "update") Then
MM_editConnection = MM_ar_inventory_STRING
MM_editTable = "Artists"
MM_editRedirectUrl = "artists_add.asp?status=ok"
MM_fieldsStr = "ArtistName|value|WebsiteStatus|value|Biography|value|Notes|value|ImageFileName|value|ModifiedBy|value|DT|value|IpAddress|value"
MM_columnsStr = "ARTST_Artist|',none,''|ARTST_WebsiteStatus|',none,''|ARTST_Biography|',none,''|ARTST_Notes|',none,''|ARTST_ArtistImageFileName|',none,''|ARTST_ModifiedBy|',none,''|ARTST_LastModified|',none,NULL|ARTST_LastModifiedIP|',none,''"
' create the MM_fields and MM_columns arrays
MM_fields = Split(MM_fieldsStr, "|")
MM_columns = Split(MM_columnsStr, "|")
' set the form values
For MM_i = LBound(MM_fields) To UBound(MM_fields) Step 2
MM_fields(MM_i+1) = CStr(UploadFormRequest(MM_fields(MM_i)))
Next
' append the query string to the redirect URL
If (MM_editRedirectUrl <> "" And UploadQueryString <> "") Then
If (InStr(1, MM_editRedirectUrl, "?", vbTextCompare) = 0 And UploadQueryString <> "") Then
MM_editRedirectUrl = MM_editRedirectUrl & "?" & UploadQueryString
Else
MM_editRedirectUrl = MM_editRedirectUrl & "&" & UploadQueryString
End If
End If
End If
%>
<%
' *** Insert Record: (Modified for File Upload) construct a sql insert statement and execute it
Dim MM_tableValues
Dim MM_dbValues
If (CStr(UploadFormRequest("MM_insert")) <> "") Then
' create the sql insert statement
MM_tableValues = ""
MM_dbValues = ""
For MM_i = LBound(MM_fields) To UBound(MM_fields) Step 2
MM_formVal = MM_fields(MM_i+1)
MM_typeArray = Split(MM_columns(MM_i+1),",")
MM_delim = MM_typeArray(0)
If (MM_delim = "none") Then MM_delim = ""
MM_altVal = MM_typeArray(1)
If (MM_altVal = "none") Then MM_altVal = ""
MM_emptyVal = MM_typeArray(2)
If (MM_emptyVal = "none") Then MM_emptyVal = ""
If (MM_formVal = "") Then
MM_formVal = MM_emptyVal
Else
If (MM_altVal <> "") Then
MM_formVal = MM_altVal
ElseIf (MM_delim = "'") Then ' escape quotes
MM_formVal = "'" & Replace(MM_formVal,"'","''") & "'"
Else
MM_formVal = MM_delim + MM_formVal + MM_delim
End If
End If
If (MM_i <> LBound(MM_fields)) Then
MM_tableValues = MM_tableValues & ","
MM_dbValues = MM_dbValues & ","
End If
MM_tableValues = MM_tableValues & MM_columns(MM_i)
MM_dbValues = MM_dbValues & MM_formVal
Next
MM_editQuery = "insert into " & MM_editTable & " (" & MM_tableValues & ") values (" & MM_dbValues & ")"
If (Not MM_abortEdit) Then
' execute the insert
Set MM_editCmd = Server.CreateObject("ADODB.Command")
MM_editCmd.ActiveConnection = MM_editConnection
MM_editCmd.CommandText = MM_editQuery
MM_editCmd.Execute
MM_editCmd.ActiveConnection.Close
If (MM_editRedirectUrl <> "") Then
Response.Redirect(MM_editRedirectUrl)
End If
End If
End If
%>
I notice that UploadQueryString is undefined so if you add this as the fist line
<%OPTION EXPLICIT%>
I guess that you will get some meaningful error messages
The craziest solution to the problem that totally seems unrelated was to disable Symantec Endpoint Protection (Network Protection) and it worked for a reason I cannot possibly explain! Thank you all for the suggestions above.

ActiveX calling URL page

I'm using the following code inside an ActiveX Script job on SQl Server to call an URL every X minutes.
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run "iexplore.exe http://www.google.com.br"
Set WsShell = Nothing
it is working but the processes created keep running:
Any way of changin that code to call the URL and kill the recent called process or call it with a "time-to-live". I think it is more secure, I wouldn't want to kill the wrong process.
Following up on the suggestion by #Ted, you can also fetch a URL using native Microsoft capabilities in an in-process fashion. You can do this via a component known as WinHTTP (the latest appears to be WinHTTP 5.1).
See my script below which includes a function to simply obtain the status of a URL. When I run this script I get the following output:
http://www.google.com => 200 [OK]
http://www.google.com/does_not_exist => 404 [Not Found]
http://does_not_exist.google.com => -2147012889
[The server name or address could not be resolved]
If you want the actual content behind a URL, try oHttp.ResponseText. Here's the WinHTTP reference if you are interested in other capabilities as well.
Option Explicit
Dim aUrlList
aUrlList = Array( _
"http://www.google.com", _
"http://www.google.com/does_not_exist", _
"http://does_not_exist.google.com" _
)
Dim i
For i = 0 To UBound(aUrlList)
WScript.Echo aUrlList(i) & " => " & GetUrlStatus(aUrlList(i))
Next
Function GetUrlStatus(sUrl)
Dim oHttp : Set oHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
On Error Resume Next
With oHttp
.Open "GET", SUrl, False
.Send
End With
If Err Then
GetUrlStatus = Err.Number & " [" & Err.Description & "]"
Else
GetUrlStatus = oHttp.Status & " [" & oHttp.StatusText & "]"
End If
Set oHttp = Nothing
End Function
The way you start IE is external, you have little control over the process once it is started.
A better interactive way is like this
Function GetData(strUrl) 'As String
Set web = CreateObject("InternetExplorer.Application")
web.Navigate strUrl
Do While web.Busy
wscript.sleep 100
Loop
Set doc = Nothing
Do Until Not doc Is Nothing
Set doc = web.Document
Loop
strWebPage = doc.all(1).innerHTML 'This does return the head sections
web.Quit
GetData = strWebPage
End Function
wscript.echo GetData("www.google.com")
UPDATE: As it stands now, it looks like this is not a viable solution. After multiple invocations, IE processes begin to accumulate with this approach as well. It appears this behavior has something to do with IE's session management. IE doesn't like to be abruptly terminated.
I found some very useful information about managing processes via WMI here. Using that as a basis, I came up with the code I show below. One of the nice aspects of the WMI approach is that you are given access to the unique ID for the process. I consider my code a starting point as I'm sure further improvements are possible (including the addition of exception handling).
Perhaps others with deeper knowledge of WMI can offer additional advice.
PS: Hope you like that I wrapped this functionality inside a VBScript class called Process.
Option Explicit
' Const PROG = "notepad.exe"
Const TARGET = "http://www.google.com"
Dim PROG : PROG = "C:\Program Files\Internet Explorer\iexplore.exe " & TARGET
Const ABOVE_NORMAL = 32768 ' what are the other priority constants?
Dim oProc : Set oProc = New Process
oProc.Name = PROG
' oProc.Priority = ABOVE_NORMAL
oProc.Launch
WScript.Echo "Launched '" & PROG & "' with process ID '" & oProc.ID & "'"
WScript.Sleep 5000
oProc.Terminate
WScript.Echo "Process " & oProc.ID & " killed."
Set oProc = Nothing
' ----------------------------------------------------------------------
Class Process
Public Computer
Public Name
Public Priority
Public ID
Public IsRunning
Private mHandle
Private Sub Class_Initialize()
Me.Computer = "."
Me.Name = Null
Me.ID = -1
Me.Priority = Null
Me.IsRunning = False
Set mHandle = Nothing
End Sub
Private Sub Class_Terminate()
Set mHandle = Nothing
End Sub
Public Sub Launch()
Dim oWmi, oStartup, oConfig
Dim nPid
Set oWmi = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& Me.Computer & "\root\cimv2")
Set oStartup = oWmi.Get("Win32_ProcessStartup")
If Not IsNull(Me.Priority) Then
Set oConfig = oStartup.SpawnInstance_
oConfig.PriorityClass = Me.Priority
End If
Set mHandle = GetObject("winmgmts:root\cimv2:Win32_Process")
mHandle.Create Me.Name, Null, oConfig, nPid
' WScript.Echo "TypeName Is [" & TypeName(mHandle) & "]"
Me.ID = nPid
Me.IsRunning = True
End Sub
Public Sub Terminate()
' mHandle.Terminate ' hmmm, doesn't work...
Dim oWmi
Dim colProcessList, oProc
Set oWmi = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& Me.Computer & "\root\cimv2")
Set colProcessList = oWmi.ExecQuery _
("Select * from Win32_Process Where ProcessId = '" & Me.ID & "'")
For Each oProc In colProcessList ' should be only one process
' WScript.Echo "TypeName Is [" & TypeName(oProc) & "]"
oProc.Terminate
Next
Me.IsRunning = False
End Sub
End Class
Could you consider using a lightweight command line URL retrieval program, like CURL ( http://curl.haxx.se/docs/manpage.html ) or WGET ( http://www.gnu.org/software/wget/ )? These programs can be executed from the command line quite simply:
wget http://www.google.com
curl http://www.google.com
You can execute them from VBScript like this:
sub shell(cmd)
' Run a command as if you were running from the command line
dim objShell
Set objShell = WScript.CreateObject( "WScript.Shell" )
objShell.Run(cmd)
Set objShell = Nothing
end sub
shell "wget http://www.google.com"
The only downside to this is that WGET and CURL won't execute javascript, download affiliated images, or render the HTML; they will simply download the web page. In my experience, I use CURL and WGET regularly as long as I only have to retrieve a single HTML page; but if I have to render something or trigger AJAX functions I use an automatable web browser toolkit like Selenium, WATIN, or IMacros.