I wrote a WinHttp POST request in VBA. It works good as long as there is only one certificate installed on the computer. However, some users have multiple certs with similar certificate names and therefore it returns an error:
a certificate is required to complete client authentication
Any suggestions on how I can select the correct certificate when multiple certificates share similar names? I've tried using both the "friendly name" and the "CN" name of the cert.
Below is my code:
Sub dapull()
Dim URL As String: URL = "https://ce.midwest.org/dart/xml/query"
Dim mfile As String
pulldate = Format(Worksheets("Sheet2").Range("date").Value, "yyyy-mm-dd")
mfile = "<?xml version=" & """" & "1.0" & """" & "?><Envelope xmlns=" & """" & "http://schemas.xmlsoap.org/soap/envelope/" & """" & "><Header/><Body><QueryRequest xmlns=" & """" & "http://markets.midwest.org/dart/xml" & """" & "><QueryResults day=" & """" & pulldate & """" & "><Location>BART</Location></QueryResults></QueryRequest></Body></Envelope>"
Set Req = New WinHttp.WinHttpRequest
With Req
.Open "POST", URL, False
.SetClientCertificate "CURRENT_USER\MY\name" '*this is the issue line
.SetRequestHeader "content-type", "text/xml"
.Send (mfile)
.ResponseText
End With
End Sub
I have the same issue, did you manage to solve it?
VBA just picks the first one :( no way to list or to identify which is which (or at least sort by date or something else before picking up the certificate).
If you did it, please let me know how
For now I "solved" it by asking people to copy their own right certificate into Trusted People section and put into my XLSM an option to switch the store so that it is picked up from CURRENT_USER\TrustedPeople\ instead of MY store.
It works but it is not elegant as it needs the certificate to be manually re-copied every 6 or 12 months (but better than not working at all :) )
Related
I am trying to call an API for sending SMS from Excel Macro.
I tried sending using MSXML2.XMLHTTP it sends SMS successfully from my system, But in client's system it is giving error "An error occurred in the secure channel support".
Set httpObject = CreateObject("MSXML2.XMLHTTP")
sURL = "https://api.xxx.in/send/?apiKey=" & sAPIKey & "&sender=" & sSenderID & "&numbers=" & sMobileNo & "&message=" & sMsg
httpObject.Open "POST", sURL, False
httpObject.Send
sGetResult = httpObject.ResponseText
I tried second method like
Set winHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
myURL = "https://api.xxx.in/send/?"
postData = "apikey=" & sAPIKey & "&message=" & sMsg & "&numbers=" & sMobileNo & "&sender=" & sSenderID
winHttpReq.Open "POST", myURL, False
winHttpReq.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
winHttpReq.Send (postData)
SendSMS = winHttpReq.ResponseText
On line winHttpReq.SetRequestHeader it gives error "An error occured in the secure channel support" on my system. As per suggestions I enabled all TLS versions but still the same error. I am using Win 7 and excel 6.5.Somewhere i read to add the ciphers to the servers. I have no idea how to do that. I guess issue is somewhere else.
Can anyone pls help. I will prefer to use the 2nd method.
Thanks
I'm working on my master's thesis and really need your help with some distance calculations.
I am really struggling with some code I found online in order to calculate the distance between several addresses (~10k pairs). I tried two different codes from two websites, and they both give me an error.
I already created my own Google API, and activated billing (using the URL test actually works for me) and tried some suggestions from other forums.
1. Approach
Found on: https://analystcave.com/excel-calculate-distances-between-addresses/
Code
'Calculate Google Maps distance between two addresses
Public Function GetDistance(start As String, dest As String)
Dim firstVal As String, secondVal As String, lastVal As String
firstVal = "http://maps.googleapis.com/maps/api/distancematrix/json?origins="
secondVal = "&destinations="
lastVal = "&mode=car&language=pl&sensor=false&key=YOUR_KEY"
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
URL = firstVal & Replace(start, " ", "+") & secondVal & Replace(dest, " ", "+") & lastVal
objHTTP.Open "GET", URL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send ("")
If InStr(objHTTP.responseText, """distance"" : {") = 0 Then GoTo ErrorHandl
Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = """value"".*?([0-9]+)": regex.Global = False
Set matches = regex.Execute(objHTTP.responseText)
tmpVal = Replace(matches(0).SubMatches(0), ".", Application.International(xlListSeparator))
GetDistance = CDbl(tmpVal)
Exit Function
ErrorHandl:
GetDistance = -1
End Function
Every time I'm applying the formula, I get a "-1" i.e. error message.
2. Approach
Found on: https://syntaxbytetutorials.com/excel-function-to-calculate-distance-using-google-maps-api-with-vba/
Here I also added VBA-JSON and activated references as suggested by the author.
Code
' Returns the number of seconds it would take to get from one place to another
Function TRAVELDISTANCE(origin, destination, apikey)
Dim strUrl As String
strUrl = "https://maps.googleapis.com/maps/api/directions/json?origin=" & origin & "&destination=" & destination & "&key=" & apikey
Set httpReq = CreateObject("MSXML2.XMLHTTP")
With httpReq
.Open "GET", strUrl, False
.Send
End With
Dim response As String
response = httpReq.ResponseText
Dim parsed As Dictionary
Set parsed = JsonConverter.ParseJson(response)
Dim meters As Integer
Dim leg As Dictionary
For Each leg In parsed("routes")(1)("legs")
meters = meters + leg("distance")("value")
Next leg
TRAVELDISTANCE = meters
End Function
Here, the functions actually do not compile due to an error in the line
strUrl = "https://maps.googleapis.com/maps/api/directions/json?origin=" & origin & "&destination=" & destination & "&key=" & apikey
It returns the "Expected: end of statement" error.
I am completely lost and would be so grateful if anyone of you could provide some help.
Best,
Felix
As far as the second approach is concerned, according to this, the URL should look like the following example:
https://maps.googleapis.com/maps/api/directions/json?origin=Disneyland&destination=Universal+Studios+Hollywood&key=YOUR_API_KEY
So in your case, if you have a variable named origin, another one named destination and a third one named apikey, the URL should be built like so:
strUrl ="https://maps.googleapis.com/maps/api/directions/json?origin=" & origin & "&destination=" & destination & "&key=" & apikey
The function would have to be called like so, for example:
call TRAVELDISTANCE("Disneyland", "Universal+Studios+Hollywood", "xxxxx")
I suppose what happened is that in the website where you found the original code, the & character was resolved in its HTML version which is: &. This however will give an error in VBA.
So before copying and pasting something you need to understand how it works.
To combine strings the following applies in general:
finalString= String1 & String2 & "String3" & "String4" & ..... 'depending on whether your strings are stored in variables or not.
I need to generate a whole sheet of QR codes, (eventually about 1000), i am trying to automate the generation in Excel 2016, i currently have a sheet set up and have a URL to the generater using Google Apis, I just change the ID number in the url for it to take me to make the next code and take me to the correct place. I dont want to have to manually go and get the code and copy it into my document for each one.
Does anyone have any ideas that may help me out, i have set up the first 10 and this can be seen on the screenshot attached.
enter image description here
Thanks
You can use this VBA code to your Excel file,then you have to make a selection for the cells that you want to create QR Codes for them, then run the code "InsertQR" by (Alt+F8)
The VBA code will create QR codes for each selected cell as PNG file.
Note: You must be connected to the Internet
Sub InsertQR()
Dim xHttp: Set xHttp = CreateObject("Microsoft.XMLHTTP")
Dim bStrm: Set bStrm = CreateObject("Adodb.Stream")
Dim size: size = 500 'dalam Pixels
Dim QR, Name, val
Dim Invalid: Invalid = "\/:*?" & """" & "<>|"
For Each val In Selection
Name = val.Value
For intChar = 1 To Len(Name)
If InStr(Invalid, LCase(Mid(Name, intChar, 1))) > 0 Then
MsgBox "The file: " & vbCrLf & """" & Name & """" & vbCrLf & vbCrLf & " is invalid!"
Exit Sub
End If
Next
QR = "http://chart.googleapis.com/chart?chs=" & size & "x" & size & "&cht=qr&chl=" & Name
xHttp.Open "GET", QR, False
xHttp.Send
With bStrm
.Type = 1 '//binary
.Open
.write xHttp.responseBody
.savetofile ThisWorkbook.Path & "\" & Name & ".png", 2 '//overwrite
.Close
End With
Next
End Sub
This is the closest thing I could find with what you are trying to do.
https://sites.google.com/site/e90e50fx/home/generate-qrcode-with-excel
It's generate a QR code image but I can't get it to do it for multiple cell values.
I have made a program the receives an xml file via LAN (Net.Socket) and need to send a part of this XML data to a serial port (also to some labels)
When sending to the labels all goes well, because I'm using the following code (cross thread):
Delegate Sub SetlblScoreLine1TextInvoker(ByVal TextToDisplay1 As String)
Public Sub SetlblScoreLine1Text(ByVal TextToDisplay1 As String)
If lblScoreLine1.InvokeRequired Then
lblScoreLine1.Invoke(New SetlblScoreLine1TextInvoker(AddressOf SetlblScoreLine1Text), New Object() {TextToDisplay1})
Else
lblScoreLine1.Text = TextToDisplay1
End If
End Sub
I wanted to use this also for the serial port, but serialport1.invokerequired is not a member of systems.IO.ports.serialports.
This because not always the serial data is send correctly (cross thread??)
Any idea how I can solve this?
I'm not familiar with cross threads
Ok, this is how I send data to the serial port, hope this helps:
If SerialPort1.IsOpen = True Then
SerialPort1.Write("2" & strLine2 & vbLf & vbCr _
& "3" & strLine3 & vbLf & vbCr _
& "4" & strLine4 & vbLf & vbCr)
SerialPort1.Write("Cxx234xdx" & vbCrLf & vbCr)
End If
If you need more information, please let me know
Given a pre-configured ODBC System DSN, I'd like to write a function that gracefully tests that connection using VBA.
Private Function TestConnection(ByVal dsnName As String) As Boolean
' What goes here?? '
End Function
Edit: To clarify, the System DSNs are pointing to external SQL Server 2005 databases, with Windows NT authentication.
One approach I've tried is to send some random query to the target database and catch the error. If the query works, return true. If there's an error then return false. This works just fine but it feels...kludgy. Is there a more elegant way, especially one that doesn't rely on On Error Goto ?
Note: It's a legacy Access 2000 database I'm working on, so any solution can't have any Access 2007 or 2003 dependencies. I'd like to make it generic to VBA, but if there's a simple way in Access that's fine too.
Much obliged for any advice.
Dim cnn As ADODB.Connection
Dim canConnect as Boolean
Set cnn = New ADODB.Connection
cnn.Open "DSN HERE"
If cnn.State = adStateOpen Then
canConnect = True
cnn.Close
End If
Msgbox canConnect
EDIT: DSN Format could be "DSN=MyDSN;UID=myuser;PWD=myPwd;"
Look this for connection strings
I'm too late to give you a useful answer to your question, but I came here because I wanted to see if StaCkOverflow has a better answer than the code I'm currently using to test ADODB connections.
...It turns out that the answer is 'No', so I'll post the code for reference: someone else will find it useful.
Coding notes: this isn't a generic answer: it's a method from a class encapsulating the ADODB.Connection object, and it assumes the existence of object 'm_objConnect'.
TestConnection: a VBA Class method for publishing debugging information for an ADODB.Connection object
This prints out the connection string, the current status, a list of ADODB errors (if any) and a full listing of the onnection's named properties.
Public Sub TestConnection()
On Error GoTo ErrTest
Dim i As Integer
If m_objConnect Is Nothing Then
Debug.Print "Object 'm_objConnect' not instantiated."
Else
Debug.Print m_objConnect.ConnectionString
Debug.Print "Connection state = " & ObjectStateString(m_objConnect.State)
Debug.Print
If m_objConnect.Errors.Count > 0 Then
Debug.Print "ADODB ERRORS (" & m_objConnect.Errors.Count & "):"
For i = 0 To m_objConnect.Errors.Count
With m_objConnect.Errors(i)
Debug.Print vbTab & i & ":" _
& vbTab & .Source & " Error " & .Number & ": " _
& vbTab & .Description & " " _
& vbTab & "(SQL state = " & .SqlState & ")"
End With
Next i
End If
Debug.Print
Debug.Print "CONNECTION PROPERTIES (" & m_objConnect.Properties.Count & "):"
For i = 0 To m_objConnect.Properties.Count - 1
Debug.Print vbTab & i & ":" _
& vbTab & m_objConnect.Properties(i).Name & " = " _
& vbTab & m_objConnect.Properties(i).Value
Next i
End If
ExitTest:
Exit Sub
ErrTest:
Debug.Print "Error " & Err.Number & " raised by " & Err.Source & ": " & Err.Description
Resume Next
End Sub
Private Function ObjectStateString(ObjectState As ADODB.ObjectStateEnum) As String
Select Case ObjectState
Case ADODB.ObjectStateEnum.adStateClosed
ObjectStateString = "Closed"
Case ADODB.ObjectStateEnum.adStateConnecting
ObjectStateString = "Connecting"
Case ADODB.ObjectStateEnum.adStateExecuting
ObjectStateString = "Executing"
Case ADODB.ObjectStateEnum.adStateFetching
ObjectStateString = "Fetching"
Case ADODB.ObjectStateEnum.adStateOpen
ObjectStateString = "Open"
Case Else
ObjectStateString = "State " & CLng(ObjectState) & ": unknown state number"
End Select
End Function
Share and enjoy: and watch out for line-breaks, helpfully inserted where they will break the code by your browser (or by StackOverflow's formatting functions).
There no magic function that will test this without actually connecting and trying an operation.
If you feel bad about the random query part - you can query the system tables
For Access
SELECT TOP 1 NAME FROM MSysObjects
For SQL Server
SELECT TOP 1 NAME FROM sysobjects
If you merely have to test that the database server is actually available, this can be done, despite what is being said here that it cannot.
In that case, you can attempt to open a TCP connection to the specific server and port.
The default instance of SQL Server, for example, listens on TCP port 1433. Attempting a simple TCP connection in VBA will tell you if it succeeds or not. Only if that is successful I would query using the ODBC connection.
This is a lot more graceful and efficient. It would remove any "gross" error from your ODBC test code. However, as I said, it is only applicable if you need to test for the mere existence/availability of the database server instance.