64bit version of DeviceCapabilities Lib "winspool.drv" - vba

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

Related

Function HdNum() is creating an Error of DLL

I found one the function of VBA EXCEL which gives me My System's HardDrive Serial No. in hex format.
okay, I have active Microsoft Excel 16.0 Object Library on my system.
when I have run the same code on my friend's system, I got an error of
Error Loading DLL
While checking his systems references, I found He has Active Microsoft Excel 12.0 Object Library. Which is a clear case of Late Binding and Early Binding? (I thought So....!)
Here's the Code of the function that I have got from the random forum,
Function HdNum() As String
Dim fsObj As Object
Dim drv As Object
Set fsObj = CreateObject("Scripting.FileSystemObject")
Set drv = fsObj.Drives("C")
HdNum = VBA.Hex(drv.serialnumber)
End Function
can u please guide me what is the problem actually?
Anyhow, I got the solution to this problem.
The problem I was facing because my friend has installed 64bit Version of MS Office. and to we all have an idea how coding differs in VB7 which is implied to the 64bit version of MS office.
Here below I'm providing the code to this facility to generate HardDisk Serial no. from any of the version of Office.
In the module paste this following code
#If VBA7 Then
Private Declare PtrSafe Function GetVolumeInformation Lib _
"kernel32.dll" Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Integer, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
#Else
Private Declare Function GetVolumeInformation Lib _
"kernel32.dll" Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Integer, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
#End If
Public Function DriveSerialNumber(ByVal Drive As String) As Long
Dim lAns As Long
Dim lRet As Long
Dim sVolumeName As String, sDriveType As String
Dim sDrive As String
sDrive = Drive
If Len(sDrive) = 1 Then
sDrive = sDrive & ":\"
ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" Then
sDrive = sDrive & "\"
End If
sVolumeName = VBA.String$(255, Chr$(0))
sDriveType = VBA.String$(255, Chr$(0))
lRet = GetVolumeInformation(sDrive, sVolumeName, 255, lAns, 0, 0, sDriveType, 255)
DriveSerialNumber = lAns
End Function
Function HdNum() As String
HdNum = VBA.Hex(DriveSerialNumber("C:\"))
End Function
Sub HD()
MsgBox HdNum
End Sub
Thank you Guys.

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

Environ("USERNAME") in VBA returns "User" after Windows 8 upgrade

I have an Access database that needs to check the username of the user using Environ("USERNAME").
While this works for my users who are using Win7, I have recently upgraded to Win8 and the code returns the text "User" on my laptop. I have also tried CreateObject("WScript.Network").Username with the same result.
Is this a windows 8 thing and will I have a problem when the other users upgrade?
Is there a way that I can change/configure this "User" text? My laptop is not connected to the corporate network that the other users are using so it may be that when they upgrade to Win8 their laptops will return the correct network username.
I would use this Windows API call:
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long
Public Function GetWindowsUserName() As String
Dim strUserName As String
strUserName = String(100, Chr$(0))
GetUserName strUserName, 100
GetWindowsUserName = Left$(strUserName, InStr(strUserName, Chr$(0)) - 1)
End Function
You should be able to do this using a WMI query.
Function GetFullName() As String
Dim computer As String
computer = "."
Dim objWMIService, colProcessList As Object
Set objWMIService = GetObject("winmgmts:\\" & computer & "\root\cimv2")
Set colProcessList = objWMIService.ExecQuery _
("SELECT TOP 1 * FROM Win32_Process WHERE Name = 'ACCESS.EXE'")
Dim uname, udomain As String
Dim objProcess As Object
For Each objProcess In colProcessList
objProcess.GetOwner uname, udomain
Next
GetFullName = UCase(udomain) & "\" & UCase(uname)
End Function
If you don't need the context, just remove "UCase(udomain) & "\" &"
I have been using the following module for a few months now. It ultimatly returns the full name of the current user, but you are ofcourse able to get all the data you need.
This code has never failed me before, including windows 8 if I'm not mistaking.
You can call the code with "GetFullNameOfLoggedUser()"
Please note that this is not my code! I have not been able to retrace where I found the code, so if someone knows, please comment to give him the credit!
Private Type ExtendedUserInfo
EUI_name As Long
EUI_password As Long ' Null, only settable
EUI_password_age As Long
EUI_priv As Long
EUI_home_dir As Long
EUI_comment As Long
EUI_flags As Long
EUI_script_path As Long
EUI_auth_flags As Long
EUI_full_name As Long
EUI_usr_comment As Long
EUI_parms As Long
EUI_workstations As Long
EUI_last_logon As Long
EUI_last_logoff As Long
EUI_acct_expires As Long
EUI_max_storage As Long
EUI_units_per_week As Long
EUI_logon_hours As Long
EUI_bad_pw_count As Long
EUI_num_logons As Long
EUI_logon_server As Long
EUI_country_code As Long
EUI_code_page As Long
End Type
'Windows API function declarations
Private Declare Function apiNetGetDCName Lib "netapi32.dll" _
Alias "NetGetDCName" (ByVal servername As Long, _
ByVal DomainName As Long, _
bufptr As Long) As Long
' function frees the memory that the NetApiBufferAllocate function allocates.
Private Declare Function apiNetAPIBufferFree Lib "netapi32.dll" _
Alias "NetApiBufferFree" (ByVal buffer As Long) As Long
' Retrieves the length of the specified Unicode string.
Private Declare Function apilstrlenW Lib "kernel32" _
Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function apiNetUserGetInfo Lib "netapi32.dll" _
Alias "NetUserGetInfo" (servername As Any, _
username As Any, _
ByVal level As Long, _
bufptr As Long) As Long
' moves memory either forward or backward, aligned or unaligned,
' in 4-byte blocks, followed by any remaining bytes
Private Declare Sub sapiCopyMem Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function apiGetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Const MAXCOMMENTSZ = 256
Private Const NERR_SUCCESS = 0
Private Const ERROR_MORE_DATA = 234&
Private Const MAX_CHUNK = 25
Private Const ERROR_SUCCESS = 0&
Function GetFullNameOfLoggedUser(Optional strUserName As String) As String
'
' Returns the full name for a given network username (NT/2000/XP only)
' Omitting the argument will retrieve the full name for the currently logged on user
'
On Error GoTo Err_GetFullNameOfLoggedUser
Dim pBuf As Long
Dim dwRec As Long
Dim pTmp As ExtendedUserInfo
Dim abytPDCName() As Byte
Dim abytUserName() As Byte
Dim lngRet As Long
Dim i As Long
' Unicode
abytPDCName = GetDCName() & vbNullChar
If (Len(strUserName) = 0) Then
strUserName = GetUserName()
End If
abytUserName = strUserName & vbNullChar
' Level 2
lngRet = apiNetUserGetInfo(abytPDCName(0), abytUserName(0), 2, pBuf)
If (lngRet = ERROR_SUCCESS) Then
Call sapiCopyMem(pTmp, ByVal pBuf, Len(pTmp))
GetFullNameOfLoggedUser = StrFromPtrW(pTmp.EUI_full_name)
gvusername = abytUserName
End If
Call apiNetAPIBufferFree(pBuf)
Exit_GetFullNameOfLoggedUser:
Exit Function
Err_GetFullNameOfLoggedUser:
MsgBox Err.Description, vbExclamation
GetFullNameOfLoggedUser = vbNullString
Resume Exit_GetFullNameOfLoggedUser
End Function
Private Function GetUserName() As String
' Returns the network login name
Dim lngLen As Long, lngRet As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngRet = apiGetUserName(strUserName, lngLen)
If lngRet Then
GetUserName = Left$(strUserName, lngLen - 1)
End If
End Function
Function GetDCName() As String
Dim pTmp As Long
Dim lngRet As Long
Dim abytBuf() As Byte
lngRet = apiNetGetDCName(0, 0, pTmp)
If lngRet = NERR_SUCCESS Then
GetDCName = StrFromPtrW(pTmp)
End If
Call apiNetAPIBufferFree(pTmp)
End Function
Private Function StrFromPtrW(pBuf As Long) As String
Dim lngLen As Long
Dim abytBuf() As Byte
' Get the length of the string at the memory location
lngLen = apilstrlenW(pBuf) * 2
' if it's not a ZLS
If lngLen Then
ReDim abytBuf(lngLen)
' then copy the memory contents
' into a temp buffer
Call sapiCopyMem(abytBuf(0), ByVal pBuf, lngLen)
' return the buffer
StrFromPtrW = abytBuf
End If
End Function

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.

Visual Basic Compile Error - Invalid Character

I got a VB SCRIPT off the internet to create new mail alerts for secondary email accounts in Outlook(2010).
Now this is the first part of the code, and when running Outlook, it gives me the following error:
"Compile Error: Invalid Character"
The debugger underlines the _ character in the following line: "sndPlaySoundA" _
'On the next line change the file name and path of the sound you want to play.'
Public Const SOUND_TO_PLAY = "C:\Windows\Media\Speech On.wav"
Public Const SND_ASYNC = &H1
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Public Declare Function MessageBox _
Lib "User32" Alias "MessageBoxA" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) _
As Long
Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
' Purpose: Opens an Outlook folder from a folder path.'
' Written: 4/24/2009'
' Author: BlueDevilFan'
' Outlook: All versions'
Dim arrFolders As Variant, _
varFolder As Variant, _
bolBeyondRoot As Boolean
On Error Resume Next
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
Do While Left(strFolderPath, 1) = "\"
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
Loop
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
Select Case bolBeyondRoot
Case False
Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
bolBeyondRoot = True
Case True
Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
End Select
If Err.Number <> 0 Then
Set OpenOutlookFolder = Nothing
Exit For
End If
Next
End If
On Error GoTo 0
End Function
UPDATE: A new error has risen: (After I fixed the New line issue on line 1 after "sndPlaySoundA") as refered to by Adrian below)
"Compile Error Expected: End of statement" and the following word is highlighted: "Public"
UPDATE2: Next error:
Compile Error: User defined type not defined(For "Mailbox - supportdesk\Inbox")
Dim objFM1 As FolderMonitor
Private Sub Application_Quit()
Set objFM1 = Nothing
End Sub
Private Sub Application_Startup()
Set objFM1 = New FolderMonitor
'Edit the folder path on the next line as needed.'
objFM1.FolderToWatch OpenOutlookFolder("Mailbox - supportdesk\Inbox")
End Sub
According to the code sample you've provided there you need a new line immediately after the _. The underscore character is a line continuation in VBA (which is what you're using, not VBScript. Slightly different beasts) and so requires that you continue on the next line, not the same line. So instead of
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _ (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Public Declare Function MessageBox _
Lib "User32" Alias "MessageBoxA" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) _
As Long
you should have
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Declare Function MessageBox _
Lib "User32" Alias "MessageBoxA" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) _
As Long
EDIT: I obviously didn't read all the way to the end of that example line, or else I would have seen that the example somehow managed to mash two function declarations onto one line as well as using the invalid positioning of the line separator. I've fixed that up now.