How to set the browser I have developed as the default browser? - vb.net

I'm working on a Web Browser in VB.NET and I want to set the option of making it the default browser. Any help? Tks

See Becoming the Default Browser in MSDN's default programs API docs

Here is how to do it in VB6, needs to be converted
Const REG_SZ As Long = 1
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const KEY_SET_VALUE = &H2
Const KEY_ALL_ACCESS = &H3F
Const REG_OPTION_NON_VOLATILE = 0
Const HWND_BROADCAST = &HFFFF
Const WM_SETTINGCHANGE = &H1A
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" _
Alias "RegCreateKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, ByVal Reserved As Long, _
ByVal lpClass As String, ByVal dwOptions As Long, _
ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, _
phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" _
Alias "RegSetValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal dwType As Long, ByVal lpValue As String, _
ByVal cbData As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lparam As String) As Long
Public Function SetClient(iClient As Integer, sDisplayName As String, _
sClientCommandLine As String, sClientResourceDLL As String, _
iLocalization As Integer, bGlobalClient As Boolean, _
Optional sCLParameters As String, Optional bMakeDefault As Boolean) As Integer
' iClient - 1 for internet browser, 2 for e-mail client
' sDisplayName - the name to be displayed on the menu for the client
' sClientCommandLine - the path and filename of the e-mail client
'
' The next two parameters are included for localization of the client.
' For backwards compatibility with applications that do not support localized
' strings, the name of the application in the installed language should be set
' as the Default value for the key.
' sClientResourceDLL - provides a path to an EXE or DLL containing the
' localized strings for the client.
' iLocalization - a string resource ID within the DLL whose value is
' to be displayed to the user allowing the same registration to
' be used for multiple languages. For each language, provide a
' different Resource DLL, and the dynamic loading of the string
' from the DLL results in the correct strings being displayed, depending
' on the language.
'
' bGlobalClient - sets the value for either all users (True) or the
' current user (False)
' sCLParameters - additional parameters on the command line to be passed to the
' browser or e-mail client.
' bMakeDefault - (Optional) set the browser or e-mail application as the default
Dim iStatus As Integer
Dim hHandle As Long
Dim hGRegKey As String
Dim hLRegKey As String
Dim sCommand As String
Dim sKey As String
Dim sAll As String
Dim sRoot As String
Dim hKey As Long
Dim sLoc As String
hGRegKey = HKEY_LOCAL_MACHINE
hLRegKey = HKEY_CURRENT_USER
If iClient = 1 Then
sRoot = "Software\Clients\StartMenuInternet"
Else
sRoot = "Software\Clients\Mail"
End If
' Create and null terminate needed strings
sCommand = "shell\open\command"
sKey = sRoot & "\" & sDisplayName
sAll = sKey & "\" & sCommand
sLoc = "#" & sClientResourceDLL & "," & iLocalization & Chr$(0)
sClientLocation = """" & sClientCommandLine & """" & _
IIf(sCLParameters <> "", " ", "") & Trim(sCLParameters) & Chr$(0)
sDisplayName = sDisplayName & Chr$(0)
' Create a registry key for the new client
iStatus = RegCreateKeyEx(hGRegKey, sKey, 0&, vbNullString, _
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
iStatus = RegCreateKeyEx(hGRegKey, sAll, 0&, vbNullString, _
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
If iStatus = ERROR_NONE Then
iStatus = RegOpenKeyEx(hGRegKey, sAll, 0, KEY_SET_VALUE, hKey)
iStatus = RegSetValueExString(hKey, "", 0&, REG_SZ, sClientLocation, _
Len(sClientLocation))
iStatus = RegCloseKey(hKey)
iStatus = RegOpenKeyEx(hGRegKey, sKey, 0, KEY_SET_VALUE, hKey)
iStatus = RegSetValueExString(hKey, "", 0&, REG_SZ, sDisplayName, _
Len(sDisplayName))
' Add the localization string
iStatus = RegSetValueExString(hKey, "LocalizedString", 0&, REG_SZ, _
sLoc, Len(sLoc))
iStatus = RegCloseKey(hKey)
Else
SetClient = iStatus
Exit Function
End If
' Sets browser as local or global default if specified
If bMakeDefault Then
If bGlobalClient Then
iStatus = RegOpenKeyEx(hGRegKey, sRoot, 0, KEY_SET_VALUE, hKey)
iStatus = RegSetValueExString(hKey, "", 0&, REG_SZ, sDisplayName, _
Len(sDisplayName))
iStatus = RegCloseKey(hKey)
Else
iStatus = RegCreateKeyEx(hLRegKey, sRoot, 0&, vbNullString, _
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hNewKey, lRetVal)
iStatus = RegSetValueExString(hNewKey, "", 0&, REG_SZ, _
sDisplayName, Len(sDisplayName))
iStatus = RegCloseKey(hNewKey)
End If
UpdateMenus
End If
End Function
Private Sub UpdateMenus()
' Refresh the menu choices with the updated client
Dim iRetVal As Integer
iRetVal = SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, _
"SOFTWARE\Clients\mail")
iRetVal = SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, _
"SOFTWARE\Clients\StartMenuInternet")
End Sub
From Microsoft

Related

FtpFindFirstFile always returns zero

I've hit a brick wall trying to get FTP working in Excel VBA (64-bit Office on 64-bit Windows 10). As an early proof of concept, I'm just trying to list the name of the single text file that I've uploaded to the FTP server.
The sub I'm running is ListFilesOnFTP. hOpen and hConnection both get set to handle values successfully by InternetOpen and InternetConnect respecitvely.
blReturn is set to True by FtpSetCurrentDirectory, indicating that this is not failing.
The problem I have is in EnumFiles - no matter what combination of wildcards I use for lpszSearchfile, FtpFindFirstFile always returns zero, and therefore EnumFiles exits immediately.
Obviously I have provided placeholder values below for strFTPServerIP, strUsername, strPassword and strRemoteDirectory, but I am 100% certain that the IP address and credentials are correct, and that the directory with the provided name does exist under the root of the FTP server.
Any ideas where I'm going wrong here?
Relevant constant and type declarations:
Private Const MAX_PATH As Integer = 260
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Const INTERNET_NO_CALLBACK = 0
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Relevant wininet.dll function declarations (please note - I do have these wrapped in the usual #If VBA7 Then... #Else... #End If conditional compilation structures, with 32-bit compatible declarations in the else clause, but for brevity I have only provided the PtrSafe functions here):
Private Declare PtrSafe Function InternetCloseHandle Lib "wininet.dll" ( _
ByVal hInet As LongPtr) As LongPtr
Private Declare PtrSafe Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, _
ByVal lAccessType As LongPtr, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As LongPtr) As LongPtr
Private Declare PtrSafe Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As LongPtr, _
ByVal sServerName As String, _
ByVal nServerPort As LongPtr, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As LongPtr, _
ByVal lFlags As LongPtr, _
ByVal lContext As LongPtr) As LongPtr
Private Declare PtrSafe Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszDirectory As String) As Boolean
Private Declare PtrSafe Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszCurrentDirectory As String, _
ByVal lpdwCurrentDirectory As LongPtr) As LongPtr
Private Declare PtrSafe Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszSearchFile As String, _
ByRef lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags As LongPtr, _
ByVal dwContent As LongPtr) As LongPtr
Procedures using the above:
Public Sub EnumFiles(ByVal hConnection As LongPtr)
Dim pData As WIN32_FIND_DATA
#If VBA7 Then
Dim hFind As LongPtr, lRet As LongPtr
#Else
Dim hFind As Long, lRet As Long
#End If
' Create a buffer
pData.cFileName = String(MAX_PATH, vbNullChar)
' Find the first file
hFind = FtpFindFirstFile(hConnection, "*.*", pData, INTERNET_FLAG_RELOAD Or INTERNET_FLAG_NO_CACHE_WRITE, 0)
' If there's no file, then exit sub
If hFind = 0 Then Exit Sub
' Show the filename
MsgBox Left$(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Do
' Create a buffer
pData.cFileName = String(MAX_PATH, vbNullChar)
' Find the next file
lRet = InternetFindNextFile(hFind, pData)
' If there's no next file, exit loop
If lRet = 0 Then Exit Do
' Show the filename
MsgBox Left$(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Loop
' Close the search handle
InternetCloseHandle hFind
End Sub
Public Sub ListFilesOnFTP()
#If VBA7 Then
Dim hOpen As LongPtr, hConnection As LongPtr
#Else
Dim hOpen As Long, hConnection As Long
#End If
Dim blReturn As Boolean
Dim strFTPServerIP As String, strUsername As String, strPassword As String, _
strRemoteDirectory As String
strFTPServerIP = "12.345.678.901"
strUsername = "username"
strPassword = "password"
strRemoteDirectory = "directory_name/"
' Open an internet connection
hOpen = InternetOpen("FTP", _
INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, _
vbNullString, _
0)
hConnection = InternetConnect( _
hOpen, _
strFTPServerIP, _
INTERNET_DEFAULT_FTP_PORT, _
strUsername, _
strPassword, _
INTERNET_SERVICE_FTP, _
INTERNET_FLAG_PASSIVE, _
INTERNET_NO_CALLBACK)
blReturn = FtpSetCurrentDirectory(hConnection, strRemoteDirectory)
Call EnumFiles(hConnection)
InternetCloseHandle hConnection
InternetCloseHandle hOpen
End Sub
Cross-posted here: excelforum.com
And here: mrexcel.com
So I gave up on this idea a couple of weeks ago, got rid of the FTP server I'd created, and had resolved to rethinking my approach to the problem I was trying to solve with FTP.
But... although my original FTP server is now long gone, I just made some changes to the API declarations after some advice from elsewhere about the datatypes of arguments to API calls not necessarily having to be LongPtrs (depends if the API function expects a Long), and then went looking for a test FTP server - found one here: https://dlptest.com/ftp-test/
Connected to it in File Explorer, used netstat -abno in command prompt to find the 'foreign address' with port 21 at the end of it, and used that IP in my code, along with the credentials listed on the webpage above.
And then boom...
immediate window output
actual directory content
As you can see, FtpGetCurrentDirectory doesn't like one of the parameters I'm passing it (a quick Google suggests that's what LastDllError code 87 means), but FtpSetCurrentDirectory obviously did run OK (the directory was set successfully)... so the hFtpSession argument being a LongPtr can't be a huge problem (or it is a problem for FtpGetCurrentDirectory, but weirdly not for FtpSetCurrentDirectory).
I tried changing all the parameters in the PtrSafe declarations to Longs, but because some of them are LongPtrs returned by other API calls, to get the code to compile I had to relent and put some parameters back to being LongPtrs.
So either the changes to the API declarations worked, or there was a problem with the previous FTP server that I got rid of which caused FtpFindFirstFile to fail.
Anyway... my working code in full (bear in mind that because this is an open test FTP server, the directories which exist on there are changing all the time... the one in my code below and in the screenshots above is now no longer there!! Just connect to it via File Explorer or FileZilla first to get the name of a directory which currently exists, and set strRemoteDirectory in ListFilesOnFTP to that):
Option Explicit
Private Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H2
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0 ' use registry configuration
Private Const INTERNET_OPEN_TYPE_DIRECT = 1 ' direct to net
Private Const INTERNET_OPEN_TYPE_PROXY = 3 ' via named proxy
Private Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 ' prevent using java/script/INS
Private Const INTERNET_CONNECTION_CONFIGURED = &H40
Private Const INTERNET_CONNECTION_LAN = &H2
Private Const INTERNET_CONNECTION_MODEM = &H1
Private Const INTERNET_CONNECTION_OFFLINE = &H20
Private Const INTERNET_CONNECTION_PROXY = &H4
Private Const INTERNET_RAS_INSTALLED = &H10
Private Const INTERNET_INVALID_PORT_NUMBER = 0
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_DEFAULT_GOPHER_PORT = 70
Private Const INTERNET_DEFAULT_HTTP_PORT = 80
Private Const INTERNET_DEFAULT_HTTPS_PORT = 443
Private Const INTERNET_DEFAULT_SOCKS_PORT = 1080
Private Const INTERNET_NO_CALLBACK = 0
Private Const INTERNET_FLAG_PASSIVE = &H8000000 ' used for FTP connections
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const MAX_PATH As Integer = 260
Private Const GENERIC_READ = &H80000000
Private Const MAXDWORD As Double = (2 ^ 32) - 1
Private Const ERROR_NO_MORE_FILES = 18&
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
#If Win64 Then
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet.dll" ( _
ByRef dwFlags As Long, ByVal dwReserved As Long) As LongPtr
Private Declare PtrSafe Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" ( _
ByVal lpszUrl As String, _
ByVal dwFlags As Long, _
ByVal dwReserved As Long) As Boolean
Private Declare PtrSafe Function InternetCloseHandle Lib "wininet.dll" ( _
ByVal hInet As LongPtr) As LongPtr
Private Declare PtrSafe Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, _
ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As Long) As LongPtr
Private Declare PtrSafe Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As LongPtr, _
ByVal sServerName As String, _
ByVal nServerPort As Long, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lContext As Long) As LongPtr
Private Declare PtrSafe Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszDirectory As String) As Boolean
Private Declare PtrSafe Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszCurrentDirectory As String, _
ByVal lpdwCurrentDirectory As LongPtr) As Boolean
Private Declare PtrSafe Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" ( _
ByVal lpdwError As Long, _
ByVal lpszBuffer As String, _
ByVal lpdwBufferLength As Long) As Boolean
Private Declare PtrSafe Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszSearchFile As String, _
ByRef lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags As Long, _
ByVal dwContent As Long) As LongPtr
Private Declare PtrSafe Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" ( _
ByVal hFind As LongPtr, _
ByRef lpFindData As WIN32_FIND_DATA) As LongPtr
#Else
Private Declare Function InternetGetConnectedState Lib "wininet.dll" ( _
ByRef dwflags As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" ( _
ByVal lpszUrl As String, _
ByVal dwFlags As Long, _
ByVal dwReserved As Long) As Boolean
Private Declare Function InternetCloseHandle Lib "wininet.dll" ( _
ByVal hInet As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, _
ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, _
ByVal sServerName As String, _
ByVal nServerPort As Integer, _
ByVal sUserName As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lContext As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" ( _
ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" ( _
ByVal hFtpSession As Long, _
ByVal lpszCurrentDirectory As String, _
lpdwCurrentDirectory As Long) As Boolean
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" ( _
lpdwError As Long, _
ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Boolean
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszSearchFile As String, _
lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags As Long, _
ByVal dwContent As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" ( _
ByVal hFind As Long, _
lpFindData As WIN32_FIND_DATA) As Long
#End If
Public Sub EnumFiles(ByVal hConnection As LongPtr)
Dim pData As WIN32_FIND_DATA
#If Win64 Then
Dim hFind As LongPtr, lRet As LongPtr
#Else
Dim hFind As Long, lRet As Long
#End If
' Create a buffer
pData.cFileName = String(MAX_PATH, vbNullChar)
' Find the first file
hFind = FtpFindFirstFile(hConnection, "*.*", pData, INTERNET_FLAG_RELOAD Or INTERNET_FLAG_NO_CACHE_WRITE, 0)
' If there's no file, then exit sub
If hFind = 0 Then Exit Sub
' Show the filename
Debug.Print vbNewLine & "FILES FOUND:" & vbNewLine & Left$(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Do
' Create a buffer
pData.cFileName = String(MAX_PATH, vbNullChar)
' Find the next file
lRet = InternetFindNextFile(hFind, pData)
' If there's no next file, exit loop
If lRet = 0 Then Exit Do
' Show the filename
Debug.Print Left$(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Loop
' Close the search handle
InternetCloseHandle hFind
End Sub
Public Sub ListFilesOnFTP()
#If Win64 Then
Dim hOpen As LongPtr, hConnection As LongPtr, lngCurrentDirLength As LongPtr
#Else
Dim hOpen As Long, hConnection As Long, lngCurrentDirLength As Long
#End If
Dim fConnectionTestFlags As Long
Dim blCheckConnection As Boolean
Dim blCheckGetDirSuccess As Boolean, blCheckSetDirSuccess As Boolean
Dim strFTPServerIP As String, strUsername As String, strPassword As String
Dim strRemoteDirectory As String, strCurrentDirectory As String
strFTPServerIP = "35.163.228.146"
strUsername = "dlpuser"
strPassword = "rNrKYTX9g7z3RgJRmxWuGHbeu"
strRemoteDirectory = "File"
' Open an internet connection
hOpen = InternetOpen("FTP Client", _
INTERNET_OPEN_TYPE_DIRECT, _
vbNullString, _
vbNullString, _
0)
hConnection = InternetConnect( _
hOpen, _
strFTPServerIP, _
INTERNET_DEFAULT_FTP_PORT, _
strUsername, _
strPassword, _
INTERNET_SERVICE_FTP, _
INTERNET_FLAG_PASSIVE, _
INTERNET_NO_CALLBACK)
blCheckConnection = InternetCheckConnection(strFTPServerIP, 0, 0)
If blCheckConnection Then
InternetGetConnectedState fConnectionTestFlags, 0
' Debug.Print "INTERNET_CONNECTION_CONFIGURED = " & CBool((fConnectionTestFlags And INTERNET_CONNECTION_CONFIGURED) > 0)
' Debug.Print "INTERNET_CONNECTION_LAN = " & CBool((fConnectionTestFlags And INTERNET_CONNECTION_LAN) > 0)
' Debug.Print "INTERNET_CONNECTION_MODEM = " & CBool((fConnectionTestFlags And INTERNET_CONNECTION_MODEM) > 0)
' Debug.Print "INTERNET_CONNECTION_OFFLINE = " & CBool((fConnectionTestFlags And INTERNET_CONNECTION_OFFLINE) > 0)
' Debug.Print "INTERNET_CONNECTION_PROXY = " & CBool((fConnectionTestFlags And INTERNET_CONNECTION_PROXY) > 0)
' Debug.Print "INTERNET_RAS_INSTALLED = " & CBool((fConnectionTestFlags And INTERNET_RAS_INSTALLED) > 0)
blCheckSetDirSuccess = FtpSetCurrentDirectory(hConnection, strRemoteDirectory)
Debug.Print "Set current directory successful = " & blCheckSetDirSuccess
If blCheckSetDirSuccess Then
' Create buffer
strCurrentDirectory = String(MAX_PATH, vbNullChar)
blCheckGetDirSuccess = FtpGetCurrentDirectory(hConnection, strCurrentDirectory, lngCurrentDirLength)
If blCheckGetDirSuccess Then
Debug.Print "Current directory = " & strCurrentDirectory
Else
Debug.Print "Get current directory call failed - " & GetError
Debug.Print "LastDllError code = " & Err.LastDllError
End If
Call EnumFiles(hConnection)
End If
End If
InternetCloseHandle hConnection
InternetCloseHandle hOpen
End Sub
Private Function GetError() As String
Dim lngErrorCode As Long, strError As String, lngBufferLength As Long
Dim blGetInfoSuccess As Boolean
' Get the required buffer size
InternetGetLastResponseInfo lngErrorCode, strError, lngBufferLength
' Create a buffer
strError = String(lngBufferLength, 0)
' Retrieve the last response info
blGetInfoSuccess = InternetGetLastResponseInfo(lngErrorCode, strError, lngBufferLength)
If blGetInfoSuccess Then
GetError = "Error code " & CStr(lngErrorCode) & ": " & strError
Else
GetError = "error information could not be retrieved"
End If
End Function

Getting started with smartcard & ISO 7816 in excel vba ( SCardEstablishContext )

I just received a standard cheap usb smartcard reader.
I'm trying to find out how to interact with it using VBA in excel.
-- I wrote this as I attempted to create basic smartcard functionality in a workbook. I figured at some point I would get stuck (and I did). If I get unstuck I will update this question until I reach my goal of working smartcard in excel.
TL;DR at this point the error is "Bad DLL calling convention" when calling function SCardListReaders
Smartcards are microcontrollers like AT88SC1608R powered by the reader.
There is a standard windows interface for dealing with the readers centered around winscard.dll.
Some of the documentation is here "Smart Card and Reader Access Functions"
After some research, it seems that the first thing to do is to receive a handle to a "resource manager context" using the function SCardEstablishContext.
This "context" object has "scopes", USER or SYSTEM. These are selected by the two constants SCARD_SCOPE_USER and SCARD_SCOPE_SYSTEM.
From this thread , it seems that SCARD_SCOPE_USER = 1 and SCARD_SCOPE_SYSTEM = 2 . I don't know if these values are signed. Also according to this page, the value of USER might be 0.
So, I have attempted to create some code to use SCardEstablishContext & SCardReleaseContext as follows.
Public Declare Function SCardEstablishContext Lib "winscard.dll" (ByVal dwScope As Long, _
ByVal pvReserved1 As Long, _
ByVal pvReserved2 As Long, _
ByRef phContext As SCARDCONTEXT _
) As Long
Public Declare Function SCardReleaseContext Lib "winscard.dll" (ByRef phContext As SCARDCONTEXT) As Long
Public Type SCARDCONTEXT
CardContext1 As Long
ReaderName As Byte
End Type
Sub GetContext()
Dim lReturn As Long
Dim RSVD1 As Long, RSVD2 As Long
Dim myContext As SCARDCONTEXT
' Constants, maybe unsigned ?
Dim SCARD_SCOPE_USER As Long
Dim SCARD_SCOPE_SYSTEM As Long
SCARD_SCOPE_USER = 1
SCARD_SCOPE_SYSTEM = 2
lReturn = SCardEstablishContext(SCARD_SCOPE_USER, RSVD1, RSVD2, myContext)
Debug.Print lReturn
Debug.Print myContext.CardContext1 & " " & myContext.ReaderName
lReturn = SCardReleaseContext(myContext)
Debug.Print lReturn
End Sub
Running this code returns
-2146435055
0 0
6
Using a decimal to hex converter I found that the hex value of this -2146435055 is FFFFFFFF80100011 and according to this chart Authentication Return Values
The first return value would be
SCARD_E_INVALID_VALUE
0x80100011
One or more of the supplied parameter values could not be properly interpreted.
I then tried using a value of 0 for SCARD_SCOPE_USER and got this more promising output
0
-855572480 0
6
This might be working so moving on, the next function appears to be SCardConnect to establish a link to the card in the reader. A successful call here probably means the entire system is working.
I created the following declarations for SCardConnect
I found a list of the constants at this address
Public Const SCARD_SHARE_SHARED As Long = &H2
Public Const SCARD_SHARE_EXCLUSIVE As Long = &H1
Public Const SCARD_SHARE_DIRECT As Long = &H3
Public Const SCARD_PROTOCOL_T0 As Long = &H1
Public Const SCARD_PROTOCOL_T1 As Long = &H2
Public Declare Function SCardConnect Lib "winscard.dll" (ByVal phContext As SCARDCONTEXT, _
ByVal dwShareMode As Long, _
ByVal szReader As String, _
ByVal dwPreferredProtocols As Long, _
ByRef phCard As Long, _
ByRef pdwActiveProtocol As Long _
) As Long
To call this function, I will need the name of the reader. It seems that the SCARDCONTEXT type was supposed to contain the name of the reader but my type declaration might be wrong, I only get an empty byte out of it. I tried changing the type of "ReaderName" variable to string, but then I just get an empty string.
So I will now attempt to use the SCardListReaders function to get the name.
This requires a new constant defined SCARD_DEFAULT_READERS containing text "SCard$DefaultReaders\000"
Public Const SCARD_DEFAULT_READERS As String = "SCard$DefaultReaders\000"
Public Declare Function SCardListReaders Lib "winscard.dll" (ByRef phContext As SCARDCONTEXT, _
ByVal dwShareMode As Long, _
ByVal mszGroups As String, _
ByRef mszReaders As String, _
ByRef pcchReaders As Long _
) As Long
It appears that this function is to be used twice, first to get the length of the output string, by setting mszReaders to NULL the lenght will be outputted by pcchReaders. The second time we prepare a buffer to receive the string from mszReaders.
Now about to give this a try, here is the entire code as it exists.
Public Const SCARD_SCOPE_USER As Long = &H0
Public Const SCARD_SCOPE_SYSTEM As Long = &H2
Public Const SCARD_SHARE_SHARED As Long = &H2
Public Const SCARD_SHARE_EXCLUSIVE As Long = &H1
Public Const SCARD_SHARE_DIRECT As Long = &H3
Public Const SCARD_PROTOCOL_T0 As Long = &H1
Public Const SCARD_PROTOCOL_T1 As Long = &H2
Public Const SCARD_DEFAULT_READERS As String = "SCard$DefaultReaders\000"
Public Declare Function SCardEstablishContext Lib "winscard.dll" (ByVal dwScope As Long, _
ByVal pvReserved1 As Long, _
ByVal pvReserved2 As Long, _
ByRef phContext As SCARDCONTEXT _
) As Long
Public Declare Function SCardReleaseContext Lib "winscard.dll" (ByRef phContext As SCARDCONTEXT) As Long
Public Declare Function SCardConnect Lib "winscard.dll" (ByVal phContext As SCARDCONTEXT, _
ByVal dwShareMode As Long, _
ByVal szReader As String, _
ByVal dwPreferredProtocols As Long, _
ByRef phCard As Long, _
ByRef pdwActiveProtocol As Long _
) As Long
Public Declare Function SCardListReaders Lib "winscard.dll" (ByRef phContext As SCARDCONTEXT, _
ByVal dwShareMode As Long, _
ByVal mszGroups As String, _
ByRef mszReaders As String, _
ByRef pcchReaders As Long _
) As Long
Public Type SCARDCONTEXT
CardContext1 As Long
ReaderName As String
End Type
Sub GetContext()
Dim lReturn As Long
Dim RSVD1 As Long, RSVD2 As Long
Dim myContext As SCARDCONTEXT
lReturn = SCardEstablishContext(SCARD_SCOPE_USER, RSVD1, RSVD2, myContext)
Debug.Print "SCardEstablishContext: Return =" & lReturn & _
" myContext.CardContext1 = " & myContext.CardContext1 & _
" myContext.ReaderName = " & Chr(34) & myContext.ReaderName & Chr(34)
Dim ListOfReaders As String, lenListOfReaders As Long
lReturn = SCardListReaders(myContext, SCARD_SHARE_SHARED, SCARD_DEFAULT_READERS, ListOfReaders, lenListOfReaders)
Debug.Print "SCardListReaders: Return =" & lReturn & _
" ListOfReaders = " & Chr(34) & ListOfReaders & Chr(34) & _
" lenListOfReaders = " & lenListOfReaders
lReturn = SCardReleaseContext(myContext)
Debug.Print "SCardReleaseContext: Return =" & lReturn
End Sub
I attempt to run and get the error
On line
lReturn = SCardListReaders(myContext, SCARD_SHARE_SHARED, SCARD_DEFAULT_READERS, ListOfReaders, lenListOfReaders)
Error
Run-time error '453':
Can't find DLL entry point SCardListReaders in winscard.dll
Reviewing the documentation for SCardListReaders function I find that it does list this DLL, winscard.dll for this function
There is also a line that says
Unicode and ANSI names
SCardListReadersW (Unicode) and SCardListReadersA (ANSI)
So I tried adding an "Alias" parameter to the declation for SCardListReaders and now the declaration is like this
Public Declare Function SCardListReaders Lib "winscard.dll" _
Alias "SCardListReadersA" (ByRef phContext As SCARDCONTEXT, _
ByVal dwShareMode As Long, _
ByVal mszGroups As String, _
ByRef mszReaders As String, _
ByRef pcchReaders As Long _
) As Long
Running this code I get the error
Run-time error '49':
Bad DLL calling convention
According to VB documentation it seems that this error is often caused by " incorrectly omitting or including the ByVal keyword from the Declare statement".
Now I failed to mention something earlier, in the declaration for SCardListReaders, when I first tried it, I declared phContext as
ByVal phContext As SCARDCONTEXT
Since this is an input only, I figured it didn't need to be ByRef.
However, when I did this I got the following error
Complile error:
User-defined type may not be passed ByVal
So I modified the line to be
ByRef phContext As SCARDCONTEXT
Which leads to the Bad DLL calling convention error.
To attempt to resolve this, I now replace all instances of
phContext As SCARDCONTEXT
with
phContext As long
and give it another go
This gives the same "Bad DLL calling convention" error
So perhaps it really needed that SCARDCONTEXT type variable and looking at it again, I changed the type of ReaderName from Byte to String at some point
So I change the type declaration back to
Public Type SCARDCONTEXT
CardContext1 As Long
ReaderName As Byte
End Type
And I change back all phContext As long to phContext As SCARDCONTEXT and still I get the "Bad DLL calling convention" error !!
So I went back to the SCardEstablishContext function documentation for clues on the structure of that "LPSCARDCONTEXT phContext"
At this point I am stuck, I can't find how to properly declare this SCARDCONTEXT type or if that really is my error.
I hope you can find where I went wrong before and I also hope that this charts some of the road to working with smartcards in VBA for others.
thanks for reading, bye !
Here is some code that requests a user select a smartcard and returns the name of the card.
Option Explicit
Option Compare Database
Private Const CRYPTUI_SELECT_LOCATION_COLUMN = 16
Private Const CERT_NAME_SIMPLE_DISPLAY_TYPE = 4
Private Const CERT_NAME_FRIENDLY_DISPLAY_TYPE = 5
Private Const CERT_EKU_EMAIL = "1.3.6.1.5.5.7.3.4"
Private Const CERT_EKU_LOGON = "1.3.6.1.4.1.311.20.2.2"
Public Enum CERT_USAGE
CERT_DATA_ENCIPHERMENT_KEY_USAGE = &H10
CERT_DIGITAL_SIGNATURE_KEY_USAGE = &H80
CERT_KEY_AGREEMENT_KEY_USAGE = &H8
CERT_KEY_CERT_SIGN_KEY_USAGE = &H4
CERT_KEY_ENCIPHERMENT_KEY_USAGE = &H20
CERT_NON_REPUDIATION_KEY_USAGE = &H40
CERT_OFFLINE_CRL_SIGN_KEY_USAGE = &H2
End Enum
Public Enum CERT_SELECT_MODE
SHOW_NO_SELECTION = 0
SHOW_ALL_ID_SELECT_LAST_LOGON = 1
SHOW_ID = 2
SHOW_LOGON = 3
SHOW_ALL_SELECT_LAST_LOGON = 4
SHOW_ALL = 5
SHOW_ADLS_FRIENDLY = 6
End Enum
Private Type CERT_REVOCATION_STATUS
cbSize As Long
dwIndex As Long
dwError As Long
dwReason As Long
fHasFreshnessTime As Boolean
dwFreshnessTime As Long
End Type
Private Type FILE_TIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type CRYPT_INTEGER_BLOB
cbData As Long
pbData As LongPtr
End Type
Private Type CRYPT_BIT_BLOB
cbData As Long
pbData() As Byte
cUnusedBits As Long
End Type
Private Type CRYPT_ALGORITHM_IDENTIFIER
pszObjId As LongPtr
Parameters As CRYPT_INTEGER_BLOB
End Type
Private Type CERT_PUBLIC_KEY_INFO
Algorithm As CRYPT_ALGORITHM_IDENTIFIER
PublicKey As CRYPT_BIT_BLOB
End Type
Private Type CERT_INFO
dwVersion As Long
SerialNumber As CRYPT_INTEGER_BLOB
SignatureAlgorithm As CRYPT_ALGORITHM_IDENTIFIER
Issuer As CRYPT_INTEGER_BLOB
NotBefore As Currency
NotAfter As Currency
Subject As CRYPT_INTEGER_BLOB
SubjectPublicKeyInfo As CERT_PUBLIC_KEY_INFO
IssuerUniqueId As CRYPT_BIT_BLOB
SubjectUniqueId As CRYPT_BIT_BLOB
cExtension As Long
rgExtension As LongPtr
End Type
Private Type CRYPTUI_SELECTCERTIFICATE_STRUCTA
dwSize As Long
hWndParent As LongPtr ' OPTIONAL*/
dwFlags As Long ' OPTIONAL*/
szTitle As String ' OPTIONAL*/
dwDontUseColumn As Long ' OPTIONAL*/
szDisplayString As String ' OPTIONAL*/
pFilterCallback As LongPtr ' OPTIONAL*/
pDisplayCallback As LongPtr ' OPTIONAL*/
pvCallbackData As LongPtr ' OPTIONAL*/
cDisplayStores As Long
rghDisplayStores As LongPtr
cStores As Long ' OPTIONAL*/
rghStores As LongPtr ' OPTIONAL*/
cPropSheetPages As Long ' OPTIONAL*/
rgPropSheetPages As LongPtr ' OPTIONAL*/
hSelectedCertStore As LongPtr ' OPTIONAL*/
End Type
Public Type Cert_Context
dwCertEncodingType As Long
pbCertEncoded() As Byte
cbCertEncoded As Long
pCertInfo As LongPtr
hCertStore As LongPtr
End Type
Private Declare PtrSafe Function CryptUIDlgSelectCertificateFromStore Lib _
"Cryptui.dll" ( _
ByVal hCertStore As LongPtr, _
ByVal hWnd As LongPtr, _
ByVal pwszTitle As String, _
ByVal pwszDisplayString As String, _
ByVal dwDontUseColumn As Long, _
ByVal dwFlags As Long, _
ByVal pvReserved As Any _
) As LongPtr
Private Declare PtrSafe Function CryptUIDlgSelectCertificate Lib _
"Cryptui.dll" Alias "CryptUIDlgSelectCertificateW" ( _
ByRef pcsc As CRYPTUI_SELECTCERTIFICATE_STRUCTA _
) As LongPtr
Private Declare PtrSafe Function CryptUIDlgSelectCertificate2 Lib _
"Cryptui.dll" Alias "CryptUIDlgSelectCertificateW" ( _
ByRef pcsc As CRYPTUI_SELECTCERTIFICATE_STRUCTA _
) As Cert_Context
Private Declare PtrSafe Function CertOpenSystemStore Lib _
"crypt32.dll" Alias "CertOpenSystemStoreA" ( _
ByVal hProv As LongPtr, _
ByVal szSubsystemProtocol As String _
) As LongPtr
Private Declare PtrSafe Function CertEnumCertificatesInStore Lib _
"crypt32.dll" ( _
ByVal hCertStore As LongPtr, _
ByVal pPrevCertContext As LongPtr _
) As LongPtr
Private Declare PtrSafe Function CertGetNameString Lib _
"crypt32.dll" Alias "CertGetNameStringW" ( _
ByVal pCertContext As LongPtr, _
ByVal dwType As Long, _
ByVal dwFlags As Long, _
pvTypePara As Any, _
ByVal pszNameString As LongPtr, _
ByVal cchNameString As Long _
) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cbCopy As Long)
Private Function GetNameString(hCert_Context As LongPtr, Friendly As Boolean) As String
Dim nPtr As LongPtr, bPtr As LongPtr
Dim strNameString As String
Dim szNameString As Long
Dim nullBfr As String
Dim constType As Long
On Error GoTo erh
If Friendly = True Then
constType = CERT_NAME_FRIENDLY_DISPLAY_TYPE
Else
constType = CERT_NAME_SIMPLE_DISPLAY_TYPE
End If
nullBfr = String(1, vbNullChar)
nPtr = StrPtr(nullBfr)
szNameString = CertGetNameString(hCert_Context, _
constType, _
0&, _
0, _
nPtr, _
0& _
)
If szNameString = 1 Then Err.Raise 4004, , "Certificate name contains no data."
strNameString = String(szNameString, vbNullChar)
bPtr = StrPtr(strNameString)
szNameString = CertGetNameString(hCert_Context, _
constType, _
0&, _
0&, _
bPtr, _
szNameString& _
)
GetNameString = Mid(strNameString, 1, szNameString - 1)
strNameString = String(szNameString, vbNullChar)
Exit Function
erh:
Debug.Print "SCard::Error getting certificate name: " + _
Err.Description
End Function
Private Function GetCertificate(Optional bSelect As Boolean = False, _
Optional bShowInfo As Boolean = False, _
Optional CertMode As CERT_SELECT_MODE = SHOW_LOGON, _
Optional ByRef CertStore As LongPtr, _
Optional NoCache As Boolean = False, _
Optional bSelectFirst As Boolean = False, _
Optional CertSelectPrompt As String = "") _
As LongPtr
Dim hCert_Context As LongPtr
Dim rghSystemStore As LongPtr
Dim pszStoreName As String
Dim pcsc As CRYPTUI_SELECTCERTIFICATE_STRUCTA
Dim CertType As String, CertUsage As CERT_USAGE
Dim PFNCOption As Long
Dim CertCheckEKU As Boolean
Dim strPrompt As String
On Error GoTo erh
Select Case CertMode
Case CERT_SELECT_MODE.SHOW_ALL_ID_SELECT_LAST_LOGON
'///OPTION 1: SHOW ALL ID CERTS AND SELECT LAST LOGON CERT
CertType = CERT_EKU_LOGON
CertCheckEKU = True
PFNCOption = 1
Case CERT_SELECT_MODE.SHOW_ID '///OPTION 2: SHOW JUST ID CERTS
CertType = CERT_EKU_EMAIL
CertCheckEKU = True
PFNCOption = 2
Case CERT_SELECT_MODE.SHOW_LOGON '///OPTION 3: SHOW ONLY LOGON CERTS
CertType = CERT_EKU_LOGON
CertCheckEKU = True
PFNCOption = 3
Case CERT_SELECT_MODE.SHOW_ALL_SELECT_LAST_LOGON
'///OPTION 4: SHOW ALL CERTS, SELECT LAST LOGON CERT
bSelect = True
CertType = CERT_EKU_LOGON
CertCheckEKU = True
PFNCOption = 4
Case CERT_SELECT_MODE.SHOW_ALL '///OPTION 5: SHOW ALL CERTS
bSelect = True
PFNCOption = 5
Case CERT_SELECT_MODE.SHOW_ADLS_FRIENDLY
'///OPTION 5: SHOW CERTS with digital signature
' and no secure email EKU
bSelect = False
CertUsage = CERT_DIGITAL_SIGNATURE_KEY_USAGE
CertCheckEKU = False
PFNCOption = 6
End Select
If CertSelectPrompt = "" Then
strPrompt = "Select a certificate."
Else
strPrompt = CertSelectPrompt
End If
'open the personal certificate store
pszStoreName = "MY"
rghSystemStore = CertOpenSystemStore(0&, pszStoreName)
If rghSystemStore = 0 Then Err.Raise 4001, , "Failed to open the certificate store."
CertStore = rghSystemStore
hCert_Context = 0
If GETTEMP("CACHED_CERT") <> "" And NoCache = False Then
Do
hCert_Context = CertEnumCertificatesInStore(rghSystemStore, _
hCert_Context)
If GetSerialNumberAndHash(hCert_Context) = _
GETTEMP("CACHED_CERT") Then
GetCertificate = hCert_Context
Exit Function
End If
Loop Until hCert_Context = 0&
End If
'///OPTIONS FOR CERTIFICATE SELECTION:
'////OPTION 1: SHOW SELECTION DIALOG OF LOGON CERTIFICATES
If bSelect Then
select_cert:
pcsc.dwSize = LenB(pcsc)
pcsc.rghDisplayStores = VarPtr(rghSystemStore)
pcsc.cDisplayStores = 1
pcsc.szTitle = StrConv("Please select a certificate:", vbUnicode)
pcsc.szDisplayString = StrConv("", vbUnicode)
pcsc.dwDontUseColumn = CRYPTUI_SELECT_LOCATION_COLUMN
pcsc.pFilterCallback = GetCallBack(AddressOf PFNCFILTERPROC)
pcsc.pvCallbackData = VarPtr(PFNCOption)
pcsc.dwFlags = 0&
pcsc.hWndParent = Application.hWndAccessApp
hCert_Context = CryptUIDlgSelectCertificate(pcsc)
Else
'////OPTION 2:SELECT LOGON CERTIFICATE IN STORE BY DEFAULT
If bSelectFirst Then
Do
hCert_Context = CertEnumCertificatesInStore(rghSystemStore, _
hCert_Context)
If CertCheckEKU Then
If GetCertificateEKU(hCert_Context, CertType) Then Exit Do
Else
If GetCertificateUsage2(hCert_Context, CertUsage) Then Exit Do
End If
Loop Until hCert_Context = 0&
ElseIf (CertCheckEKU And (CountOfCertificatesByEKU(CertType) <> 1)) And Not bSelectFirst Then
GoTo select_cert
ElseIf (Not CertCheckEKU And (CountOfCertificatesByUsage(CertUsage) <> 1)) And Not bSelectFirst Then
GoTo select_cert
End If
End If
If hCert_Context = 0& Then Err.Raise 4002, , _
"Failed to acquire a valid certificate context or the " + _
"user pressed cancel."
'///END OPTIONS
GetCertificate = hCert_Context
Exit Function
erh:
Debug.Print "DB_SCard::Error while getting certificate: " + _
Err.Description
GetCertificate = 0
End Function
Private Function GetSerialNumberAndHash(hContext As LongPtr) As String
On Error GoTo erh
GetSerialNumberAndHash = StrConv(CertGetProperty(hContext, CERT_ISSUER_SERIAL_NUMBER_MD5_HASH_PROP_ID), vbUnicode)
Exit Function
erh:
Debug.Print _
"DB_SCard::Error while retrieving serial number and hash: " + _
Err.Description
End Function
Private Function GetCallBack(funcAddr As LongPtr) As LongPtr
GetCallBack = funcAddr
End Function
Private Function GetCertificateUsage2(ByRef cContext As LongPtr, Usage As CERT_USAGE) As Boolean
Dim pbKeyUsage As LongPtr
Dim oBfr As Long
Dim rtn As Boolean
Dim bBfr(0 To 7) As Boolean
Dim GLE As Long
Dim certcontext As Cert_Context
Dim certinfo As CERT_INFO
On Error Resume Next
If cContext <> 0 Then
CopyMemory VarPtr(certcontext), cContext, LenB(certcontext)
End If
If certcontext.pCertInfo <> 0 Then
CopyMemory VarPtr(certinfo), certcontext.pCertInfo, LenB(certinfo)
End If
pbKeyUsage = VarPtr(oBfr)
rtn = CertGetIntendedKeyUsage(X509_ASN_ENCODING, _
VarPtr(certinfo), _
pbKeyUsage, _
4& _
)
GLE = Err.LastDllError
If rtn Then
BitBreak oBfr, bBfr
If bBfr(Log2(Usage)) = True Then GetCertificateUsage2 = True
ElseIf oBfr = 0 Then
GetCertificateUsage2 = False
Else
Debug.Print _
"DB_SCard::Error getting certificate usage: " + GLEtx(GLE)
End If
End Function
Private Function GetCertificateEKU(ByVal pContext As LongPtr, eUsage As String) As Boolean
Dim oBfr As CERT_ENHKEY_USAGE
Dim oBfrsz As Long
Dim rtn As Boolean
Dim iter1 As Long
Dim nArray() As Variant
Dim GLE As Long
On Error Resume Next
If pContext = 0 Then Exit Function
oBfrsz = Len(oBfr)
rtn = CertGetEnhancedKeyUsage(pContext, 0&, VarPtr(oBfr), VarPtr(oBfrsz))
GLE = Err.LastDllError
If rtn Then
If oBfr.cUsageIdentifier = 0 Then
GetCertificateEKU = False
Else
nStrToArray StrConv(oBfr.rgpszUsageIdentifier, vbUnicode), nArray
For iter1 = 1 To UBound(nArray)
If eUsage = nArray(iter1) Then If VerifyRevocation(pContext) Then GetCertificateEKU = True
Next iter1
End If
Else
Debug.Print _
"DB_SCard::Error getting enhanced certificate usage: " + GLEtx(GLE)
End If
End Function
Public Function PFNCFILTERPROC( _
ByRef pCertContext As Cert_Context, _
ByVal pfInitialSelectedCert As Long, _
ByVal pvCallbackData As LongPtr _
) As Long
Dim certName As String
certName = GetNameString(VarPtr(pCertContext), True)
If Right(certName, 10) = Left(Environ("username"), 10) Then
PFNCFILTERPROC = 1
Else
PFNCFILTERPROC = 0
End If
End Function
Private Function CountOfCertificatesByEKU(ByVal Usage As String) As Long
Dim hCert_Context As LongPtr
Dim rghSystemStore As LongPtr
Dim pszStoreName As String
Dim CT As Long
On Error GoTo erh
pszStoreName = "MY"
rghSystemStore = CertOpenSystemStore(0&, pszStoreName)
If rghSystemStore = 0 Then Err.Raise 4001, , "Failed to open the certificate store."
hCert_Context = 0
CT = 0
Do Until hCert_Context = 0
hCert_Context = CertEnumCertificatesInStore(rghSystemStore, _
hCert_Context)
If GetCertificateEKU(hCert_Context, Usage) Then CT = CT + 1
Loop
Debug.Print "DB_SCard::Count of certificates matching EKU " + Usage; ": " '+ cstr(CT)
CountOfCertificatesByEKU = CT
out:
CertFreeCertificateContext hCert_Context
CertCloseStore rghSystemStore, 0&
Exit Function
erh:
Debug.Print _
"DB_SCard::Error while enumerating certificates by EKU: " + _
Err.Description
GoTo out
End Function
Private Function CountOfCertificatesByUsage(ByVal Usage As CERT_USAGE) As Long
Dim hCert_Context As LongPtr
Dim rghSystemStore As LongPtr
Dim pszStoreName As String
Dim CT As Long
On Error GoTo erh
pszStoreName = "MY"
rghSystemStore = CertOpenSystemStore(0&, pszStoreName)
If rghSystemStore = 0 Then Err.Raise 4001, , "Failed to open the certificate store."
hCert_Context = 0
CT = 0
Do Until hCert_Context = 0
hCert_Context = CertEnumCertificatesInStore(rghSystemStore, _
hCert_Context)
If GetCertificateUsage2(hCert_Context, Usage) Then CT = CT + 1
Loop
CountOfCertificatesByUsage = CT
out:
CertFreeCertificateContext hCert_Context
CertCloseStore rghSystemStore, 0&
Exit Function
erh:
Debug.Print _
"DB_SCard::Error while enumerating certificates by usage: " + Err.Description
GoTo out
End Function
Public Function GetLongFromPointer(ByVal lPointer As LongPtr) As Long
On Error Resume Next
Dim outLng As Long
If lPointer > 0 Then CopyMemory VarPtr(outLng), lPointer, 4
GetLongFromPointer = outLng
End Function
Public Function GetCertFromContext(ByVal hCert_Context As LongPtr) As Cert_Context
On Error Resume Next
Dim pcc As Cert_Context
CopyMemory VarPtr(pcc), hCert_Context, LenB(pcc)
GetCertFromContext = pcc
End Function
Private Function GETTEMP(ByVal testIt As String) As String
GETTEMP = ""
End Function
Private Function GLEtx(GLE) As String
GLEtx = CStr(GLEtx)
End Function
Public Function testCert() As LongPtr
Dim rghSystemStore As LongPtr, pszStoreName As String, CertStore As LongPtr, hCert_Context As LongPtr, emptyS As LongPtr
pszStoreName = "MY"
rghSystemStore = CertOpenSystemStore(emptyS, pszStoreName)
testCert = GetCertificate(True, False, 3, rghSystemStore, True, False, "Please choose a certificate to use")
End Function
Public Function testFuncs() As String
Dim blargh As Long
blargh = testCert
testFuncs = GetNameString(blargh, True)
End Function

64bit version of DeviceCapabilities Lib "winspool.drv"

Is there a 64bit version of the Function DeviceCapabilities in the winspool.drv library? What I'm looking for is a conversion of:
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal dev As Long) As Long
Clearly I change Declare Function to Declare PtrSafe Function but which of the Long variable change and do they change to LongLong or LongPtr? Strange that a trawl of the internet over the last hour hasn't turned up any reference to this?
Programmatically retrieve printer capabilities
I modified this linked code in Microsoft Access to work with 64-bit.
And, by executing Reference Setting "Microsoft ACCESS XX.0 Object Library", I modified the following code to work in Microsoft Excel.
However, the following code is one different: That is the original code
For lngCounter = 1 To lngPaperCount
However, this code will cause an error.
The occurrence of this error is avoided by performing minus one.
For lngCounter = 1 To lngPaperCount -1
You may think such a following code, but code will cause an error, too.
For lngCounter = 0 To lngPaperCount
I don't know if my printer is causing the error or my 64bit Microsoft Office is causing the error.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpsDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal lpDevMode As Long) As Long
#Else
' Declaration for the DeviceCapabilities function API call.
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpsDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal lpDevMode As Long) As Long
#End If
' DeviceCapabilities function constants.
Private Const DC_PAPERNAMES = 16
Private Const DC_PAPERS = 2
Private Const DC_BINNAMES = 12
Private Const DC_BINS = 6
Private Const DEFAULT_VALUES = 0
Sub GetPaperList()
Dim lngPaperCount As Long
Dim lngCounter As Long
Dim hPrinter As Long
Dim strDeviceName As String
Dim strDevicePort As String
Dim strPaperNamesList As String
Dim strPaperName As String
Dim intLength As Integer
Dim strMsg As String
Dim aintNumPaper() As Integer
On Error GoTo GetPaperList_Err
' Get the name and port of the default printer.
strDeviceName = Access.Application.Printer.DeviceName
strDevicePort = Access.Application.Printer.Port
' Get the count of paper names supported by the printer.
lngPaperCount = DeviceCapabilities(lpsDeviceName:=strDeviceName, _
lpPort:=strDevicePort, _
iIndex:=DC_PAPERNAMES, _
lpOutput:=ByVal vbNullString, _
lpDevMode:=DEFAULT_VALUES)
' Re-dimension the array to the count of paper names.
ReDim aintNumPaper(1 To lngPaperCount)
' Pad the variable to accept 64 bytes for each paper name.
strPaperNamesList = String(64 * lngPaperCount, 0)
' Get the string buffer of all paper names supported by the printer.
lngPaperCount = DeviceCapabilities(lpsDeviceName:=strDeviceName, _
lpPort:=strDevicePort, _
iIndex:=DC_PAPERNAMES, _
lpOutput:=ByVal strPaperNamesList, _
lpDevMode:=DEFAULT_VALUES)
' Get the array of all paper numbers supported by the printer.
lngPaperCount = DeviceCapabilities(lpsDeviceName:=strDeviceName, _
lpPort:=strDevicePort, _
iIndex:=DC_PAPERS, _
lpOutput:=aintNumPaper(1), _
lpDevMode:=DEFAULT_VALUES)
' List the available paper names.
strMsg = "Papers available for " & strDeviceName & vbCrLf
For lngCounter = 1 To lngPaperCount
' Parse a paper name from the string buffer.
strPaperName = VBA.Mid(String:=strPaperNamesList, _
Start:=64 * (lngCounter - 1) + 1, Length:=64)
intLength = VBA.InStr(Start:=1, String1:=strPaperName, String2:=Chr(0)) - 1
strPaperName = VBA.Left(String:=strPaperName, Length:=intLength)
' Add a paper number and name to text string for the message box.
strMsg = strMsg & vbCrLf & aintNumPaper(lngCounter) _
& vbTab & strPaperName
Next lngCounter
' Show the paper names in a message box.
MsgBox Prompt:=strMsg
GetPaperList_End:
Exit Sub
GetPaperList_Err:
MsgBox Prompt:=Err.Description, Buttons:=vbCritical & vbOKOnly, _
Title:="Error Number " & Err.Number & " Occurred"
Resume GetPaperList_End
End Sub
I have now used the above function by declaring as follows:
Private Declare PtrSafe Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal dev As Long) As Long
For the function to work the API code line
sCurrentPrinter = Trim$(Left$(ActivePrinter, InStr(ActivePrinter, " on ")))
needs to be changed to
sCurrentPrinter = ActivePrinter

VBA ShellExecute forces URL to lowercase

This used to work last week. I suspect a Windows update broke something. When using ShellExecute, it is forcing the URLs into lowercase, breaking parameter values passed to a case-sensitive server!
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
Optional ByVal lpParameters As String, _
Optional ByVal lpDirectory As String, _
Optional ByVal nShowCmd As Long _
) As Long
Sub OpenBrowser()
Let RetVal = ShellExecute(0, "open", "http://yaHOO.com?UPPERCASE=lowercase")
Will open http://www.yahoo.com/?uppercase=lowercase
Version
I'm using Windows 8.1. I tried it in 3 browsers. Lowercase in Chrome, lowercase in IE, and Opera chops off the query parameter, but the host is lowercase.
Ok I solved it by creating a temporary HTML file, finding the executable associated with that, then launching the executable directly with the URL. Sheesh.
Private Const SW_SHOW = 5 ' Displays Window in its current size and position
Private Const SW_SHOWNORMAL = 1 ' Restores Window if Minimized or Maximized
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
Optional ByVal lpParameters As String, _
Optional ByVal lpDirectory As String, _
Optional ByVal nShowCmd As Long _
) As Long
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" ( _
ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String _
) As Long
Private Declare Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" ( _
ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" _
Alias "GetTempFileNameA" ( _
ByVal lpszPath As String, _
ByVal lpPrefixString As String, _
ByVal wUnique As Long, _
ByVal lpTempFileName As String) As Long
Public Function GetTempFileNameVBA( _
Optional sPrefix As String = "VBA", _
Optional sExtensao As String = "") As String
Dim sTmpPath As String * 512
Dim sTmpName As String * 576
Dim nRet As Long
Dim F As String
nRet = GetTempPath(512, sTmpPath)
If (nRet > 0 And nRet < 512) Then
nRet = GetTempFileName(sTmpPath, sPrefix, 0, sTmpName)
If nRet <> 0 Then F = Left$(sTmpName, InStr(sTmpName, vbNullChar) - 1)
If sExtensao > "" Then
Kill F
If Right(F, 4) = ".tmp" Then F = Left(F, Len(F) - 4)
F = F & sExtensao
End If
GetTempFileNameVBA = F
End If
End Function
Sub Test_GetTempFileNameVBA()
Debug.Print GetTempFileNameVBA("BR", ".html")
End Sub
Private Sub LaunchBrowser()
Dim FileName As String, Dummy As String
Dim BrowserExec As String * 255
Dim RetVal As Long
Dim FileNumber As Integer
FileName = GetTempFileNameVBA("BR", ".html")
FileNumber = FreeFile ' Get unused file number
Open FileName For Output As #FileNumber ' Create temp HTML file
Write #FileNumber, "<HTML> <\HTML>" ' Output text
Close #FileNumber ' Close file
' Then find the application associated with it
RetVal = FindExecutable(FileName, Dummy, BrowserExec)
Kill FileName ' delete temp HTML file
BrowserExec = Trim(BrowserExec)
' If an application is found, launch it!
If RetVal <= 32 Or IsEmpty(BrowserExec) Then ' Error
MsgBox "Could not find associated Browser", vbExclamation, "Browser Not Found"
Else
RetVal = ShellExecute(0, "open", BrowserExec, "http://www.yaHOO.com?case=MATTERS", Dummy, SW_SHOWNORMAL)
If RetVal <= 32 Then ' Error
MsgBox "Web Page not Opened", vbExclamation, "URL Failed"
End If
End If
End Sub
Use FileProtocolHandler instead of ShellExecute:
Public Declare Function FileProtocolHandler Lib "url.dll" _
Alias "FileProtocolHandlerA" (ByVal hwnd As Long, ByVal hinst As Long, _
ByVal lpszCmdLine As String, ByVal nShowCmd As Long) As Long
Public Sub OpenHyperlink(ByVal Url)
FileProtocolHandler 0, 0, Url, 1
End Sub
With FileProtocolHandler, the lowercase conversion does not occur.
I have this problem under Windows 8.1, but not under Windows 7.
In my case using a temp ".html" file wasn't an option because those are linked to gedit so i can edit them.
I can't say if it works on the domain part, but i needed case sensitivity for the GET parameters.
I accomplished that by simple encoding everything in hex. Not just characters like "/" but everything.

Enumerating the list of DSN's set up on a computer

I have an Excel application in which I want to present the user with a list of the Data Source Names (ie: DSN's), whereby s/he can choose what data source to use.
Hopefully once I've got the list, I can easily access the DSN properties to connect to the appropriate database.
Please note, I do not want to use a DSN-less connection.
The DSN entries are stored in the registry in the following keys.
HKEY_CURRENT_USER\Software\ODBC\ODBC.INI\ODBC Data Sources
HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources
This contains the list of all defined DSN. This acts as an global index and the specific details for each DSN are stored in a key with the DSN name under:
HKEY_CURRENT_USER\Software\ODBC\ODBC.INI
HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI
Create some entries in both User DSN and System DSN tabs from Data Sources (ODBC) control panel applet and check how these values are stored in the registry.
The following example enumerate the DSN defined for the user trough Control Panel > Administrative Tools > Data Sources (ODBC) [User Dsn Tab].
http://support.microsoft.com/kb/178755
Option Explicit
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" _
(ByVal hKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
lpcbValueName As Long, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const ERROR_SUCCESS = 0&
Const SYNCHRONIZE = &H100000
Const STANDARD_RIGHTS_READ = &H20000
Const STANDARD_RIGHTS_WRITE = &H20000
Const STANDARD_RIGHTS_EXECUTE = &H20000
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const STANDARD_RIGHTS_ALL = &H1F0000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or _
KEY_NOTIFY) And _
(Not SYNCHRONIZE))
Const REG_DWORD = 4
Const REG_BINARY = 3
Const REG_SZ = 1
Private Sub Command1_Click()
Dim lngKeyHandle As Long
Dim lngResult As Long
Dim lngCurIdx As Long
Dim strValue As String
Dim lngValueLen As Long
Dim lngData As Long
Dim lngDataLen As Long
Dim strResult As String
lngResult = RegOpenKeyEx(HKEY_CURRENT_USER, _
"SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", _
0&, _
KEY_READ, _
lngKeyHandle)
If lngResult <> ERROR_SUCCESS Then
MsgBox "Cannot open key"
Exit Sub
End If
lngCurIdx = 0
Do
lngValueLen = 2000
strValue = String(lngValueLen, 0)
lngDataLen = 2000
lngResult = RegEnumValue(lngKeyHandle, _
lngCurIdx, _
ByVal strValue, _
lngValueLen, _
0&, _
REG_DWORD, _
ByVal lngData, _
lngDataLen)
lngCurIdx = lngCurIdx + 1
If lngResult = ERROR_SUCCESS Then
strResult = strResult & lngCurIdx & ": " & Left(strValue, lngValueLen) & vbCrLf
End If
Loop While lngResult = ERROR_SUCCESS
Call RegCloseKey(lngKeyHandle)
Call MsgBox(strResult, vbInformation)
End Sub
You can use the SQLDataSources function of the ODBC API. See MSDN documentation.
Extremely cool solution. I ran into an issue where CURRENT_USER wasn't showing all the DSN's, certainly not the one I needed. I changed it to LOCAL_MACHINE and saw all DSN's that showed up in the Connection Manager, including the subset that showed up under CURRENT_USER.
http://msdn.microsoft.com/en-us/library/windows/desktop/ms712603(v=vs.85).aspx