Prevent Linked Table to SQL Server Showing Actual Values for Binary - ms-access

We have a user table in a SQL Server 2014 that I link to in an Access database front end and the password is in binary 64 so that the password cannot be seen if someone were to open the table somehow in SSMS.
But Access knows all this and completely converts it to the actual password. How do I get around this yet still use it to validate data entered into a login form?

You hash the password. Storing passwords as plaintext without hashing is a major bad practice.
Read more about hashing on Wikipedia. The short version it's a one-way operation: if you have the password, you can create the hash, but if you have the hash, there's no way to get the password except trying to hash random passwords and see if they're the same.
However, hashing in VBA is rather complicated. There are more simple answers that use .Net hashing objects, but I use the CNG API, which has numerous advantages such as hardware crypto support, zero dependencies and flexibility in the choice of algorithm:
Public Declare PtrSafe Function BCryptOpenAlgorithmProvider Lib "BCrypt.dll" (ByRef phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptCloseAlgorithmProvider Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptCreateHash Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef phHash As LongPtr, pbHashObject As Any, ByVal cbHashObject As Long, ByVal pbSecret As LongPtr, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptHashData Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, Optional ByVal dwFlags As Long = 0) As Long
Public Declare PtrSafe Function BCryptFinishHash Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptDestroyHash Lib "BCrypt.dll" (ByVal hHash As LongPtr) As Long
Public Declare PtrSafe Function BCryptGetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dfFlags As Long) As Long
Public Function NGHash(pData As LongPtr, lenData As Long, Optional HashingAlgorithm As String = "SHA1") As Byte()
'Erik A, 2019
'Hash data by using the Next Generation Cryptography API
'Loosely based on https://learn.microsoft.com/en-us/windows/desktop/SecCNG/creating-a-hash-with-cng
'Allowed algorithms: https://learn.microsoft.com/en-us/windows/desktop/SecCNG/cng-algorithm-identifiers. Note: only hash algorithms, check OS support
'Error messages not implemented
On Error GoTo VBErrHandler
Dim errorMessage As String
Dim hAlg As LongPtr
Dim algId As String
'Open crypto provider
algId = HashingAlgorithm & vbNullChar
If BCryptOpenAlgorithmProvider(hAlg, StrPtr(algId), 0, 0) Then GoTo ErrHandler
'Determine hash object size, allocate memory
Dim bHashObject() As Byte
Dim cmd As String
cmd = "ObjectLength" & vbNullString
Dim Length As Long
If BCryptGetProperty(hAlg, StrPtr(cmd), Length, LenB(Length), 0, 0) <> 0 Then GoTo ErrHandler
ReDim bHashObject(0 To Length - 1)
'Determine digest size, allocate memory
Dim hashLength As Long
cmd = "HashDigestLength" & vbNullChar
If BCryptGetProperty(hAlg, StrPtr(cmd), hashLength, LenB(hashLength), 0, 0) <> 0 Then GoTo ErrHandler
Dim bHash() As Byte
ReDim bHash(0 To hashLength - 1)
'Create hash object
Dim hHash As LongPtr
If BCryptCreateHash(hAlg, hHash, bHashObject(0), Length, 0, 0, 0) <> 0 Then GoTo ErrHandler
'Hash data
If BCryptHashData(hHash, ByVal pData, lenData) <> 0 Then GoTo ErrHandler
If BCryptFinishHash(hHash, bHash(0), hashLength, 0) <> 0 Then GoTo ErrHandler
'Return result
NGHash = bHash
ExitHandler:
'Cleanup
If hAlg <> 0 Then BCryptCloseAlgorithmProvider hAlg, 0
If hHash <> 0 Then BCryptDestroyHash hHash
Exit Function
VBErrHandler:
errorMessage = "VB Error " & Err.Number & ": " & Err.Description
ErrHandler:
If errorMessage <> "" Then MsgBox errorMessage
Resume ExitHandler
End Function
Public Function HashBytes(Data() As Byte, Optional HashingAlgorithm As String = "SHA512") As Byte()
HashBytes = NGHash(VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, HashingAlgorithm)
End Function
Public Function HashString(str As String, Optional HashingAlgorithm As String = "SHA512") As Byte()
HashString = NGHash(StrPtr(str), Len(str) * 2, HashingAlgorithm)
End Function
You can now use the HashString function to hash passwords. When someone enters a password, always use HashString(password) to look up the password or store a hashed password. You never store an actual unhashed password.
Of course, this also means that even you can not view passwords of users, only their hashes.
If you want to improve this further, you can use a salt to avoid rainbow table attacks. But only adding a hash will already substantially improve security.

Related

in VBA (msaccess) , how to open a file with default program when I have unicode folder/file names

In MSAccess vba, I want to do something like import ShellExecute to open files with their default program.
But I must allow unicode characters in folder or file names (such as Chinese, Korean, Russian, Arabic).
There are good examples of ShellExecute
such as here: https://stackoverflow.com/a/20441268/1518460
or here: https://stackoverflow.com/a/32013971/1518460
And it's good to know to ignore the "?????" in strings in the UI in Access VBA. It makes it look like variables lost the Unicode values but actually the UI can't display Unicode. If the values came direct from the db, they should be fine. (see this).
But paths with Chinese or Korean still won't open, while paths with all ansi will.
I'm trying to use the same declare ShellExecute as in the first example above, taking paths from a linked table in my current Access app:
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal lpnShowCmd As Long) As Long
Private Sub btnLaunchFunVid1_Click()
Dim strFileFolder As String
Dim strFilename As String
Dim strFullFilepath As String
Dim rst As Recordset
Dim qt As String
qt = "select folderPath, filename from ClassAdmin_Videos where rowid = " & CStr(Me.cmbFunVideo1.Value)
Set rst = CurrentDb.OpenRecordset(qt)
strFileFolder = rst.Fields("folderPath")
strFilename = rst.Fields("filename")
strFullFilepath = strFileFolder & strFilename
OpenFunVideoFileWithImportedShellExecute strFullFilepath
End Sub
Public Sub OpenFunVideoFileWithImportedShellExecute(ByVal Path As String)
If Dir(Path) > "" Then
ShellExecute 0, "open", Path, "", "", 0
End If
End Sub
Is there an option I can set to allow Unicode?
Or is there a better function?
Yes, there is a better function.
Note the function you're actually importing: "ShellExecuteA".
Guess what the "A" stand for... it's the ansi version of the function.
There is a "W" == wide == unicode version.
A great basic example can be found here:
http://www.vbforums.com/showthread.php?511136-how-to-use-shellexecute&p=4877907&viewfull=1#post4877907
Using the same in your code would give:
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteW" (ByVal hwnd As Long, ByVal lpOperation As Long, ByVal lpFile As Long, ByVal lpParameters As Long, ByVal lpDirectory As Long, ByVal nShowCmd As Long) As Long
'...
' [no need to change the function getting the path]
'...
Public Sub OpenFunVideoFileWithImportedShellExecute(ByVal Path As String)
If Dir(Path) > "" Then
ShellExecute 0, StrPtr("Open"), StrPtr(Path), 0, 0, 1
End If
End Sub

use AddressOf in VBA in win x64

I use this program in winx86 without any error but when i try use it in win x64 my problems started.
I use ptrsafe in my code to let me run in win 7 64bit, I'll add that this module have more code but for limitations of this site i had delete that. if need to now that lines of my code tell me to put them here.
please help me and tell me Why my code produce an error:
'UDT for passing data through the hook
Private Type MSGBOX_HOOK_PARAMS
hwndOwner As Long
hHook As Long
End Type
Private MSGHOOK As MSGBOX_HOOK_PARAMS
#If VBA7 Then
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
#Else
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
#End If
Public Function MsgBoxHookProc(ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
If uMsg = HCBT_ACTIVATE Then
SetDlgItemText wParam, vbYes, "بلـي"
SetDlgItemText wParam, vbNo, "خـير"
SetDlgItemText wParam, vbIgnore, "انصـراف"
SetDlgItemText wParam, vbOK, "تـــاييد"
UnhookWindowsHookEx MSGHOOK.hHook
End If
MsgBoxHookProc = False
End Function
Public Function MsgBoxFa(Prompt, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Tiltle = "", Optional HelpFile, Optional Context) As Long
'Wrapper function for the MessageBox API
Dim hwndThreadOwner As Long
Dim frmCurrentForm As Form
Set frmCurrentForm = Screen.ActiveForm
hwndThreadOwner = frmCurrentForm.hwnd
Dim hInstance As Long
Dim hThreadId As Long
Dim hwndOwner As Long
hwndOwner = GetDesktopWindow()
hInstance = GetWindowLong(hwndThreadOwner, GWL_HINSTANCE)
hThreadId = GetCurrentThreadId()
With MSGHOOK
.hwndOwner = hwndOwner
'in next line the error produced******************************
.hHook = SetWindowsHookEx(WH_CBT, _
AddressOf MsgBoxHookProc, _
hInstance, hThreadId)
End With
MsgBoxFa = MessageBox(hwndThreadOwner, Prompt, Tiltle, Buttons)
End Function

Passing a LPCTSTR parameter to an API call from VBA in a PTRSAFE and UNICODE safe manner

I've been fighting with this for a good week. I am having difficulties when passing string pointers to a DLL function.
Background
We have just started migrating to Office 2010, from Office 2003. Some people will continue to only have Office 2003 for the next few years. Some people will be using Office 2010 64-bit (why I don't know - but that's a different subject).
For me - I need to make some code that will work on all versions. I had found this function on the internet some years back and was using it. When I went to do a rewrite on my library, I noticed that there was a total mixture of Unicode vs ANSI calls .. and the function outright did not work on Access 2010. So I went to re-write it. I think I'm close - but I notice that the dll calls are not returning the proper values.
What I've done to attempt to solve the problem
I have made sure I read up on ByRef and ByVal parameter passing.
I've read up on the difference between varptr() and strptr(). I believe I am using them correctly.
I've tried declaring the lpctstr as a string but am uncomfortable with this approach since I am unsure how it will play out on a 64-Bit system, or on a Unicode system.
When working with pointers - such oversights will crash and potentially corrupt a DB
Using pointers means I don't have to convert to and from Unicode - its either in Unicode or it isn't - and the conditional compilation statements ensure the proper functions are referenced.
Short Summary Example
Public Sub foo()
 Dim strA As String
 Dim strCB As String
#If VB7 Then
 Dim lptstrA As LongPtr
 Dim lResult As LongPtr
#Else
 Dim lptstrA As Long
 Dim lResult As Long
#End If
 
 strA = "T:\TEST\"
 lptstrA = StrPtr(strA)
 strCB = String$(255, vbNullChar)
 lResult = PathIsNetworkPath(lptstrA)
#If UNICODE Then
 CopyMemory StrPtr(strCB), lptstrA, (Len(strA))
#Else
 CopyMemory StrPtr(strCB), lptstrA, (Len(strA) * 2)
#End If
 Debug.Print "Returned: " & lResult
 Debug.Print "Buffer: " & strCB
 Debug.Print "Result: " & strA
End Sub
This, in my mind should work. I'm passing the pointer to the string. But...
Results
foo
Returned: 0
Buffer: T:\TEST\
Result: T:\TEST\
So the function is returning zero .. it should return 1. But if we examine the contents of the memory at the pointer - it clearly has the data in it.
Full Code
(Doesn't Work)
Option Explicit
'
' WNetGetConnection Return Result Constants
Private Const ERROR_SUCCESS As Long = 0&
Private Const ERROR_BAD_DEVICE As Long = 1200&
Private Const ERROR_NOT_CONNECTED = 2250&
Private Const ERROR_MORE_DATA = 234&
Private Const ERROR_CONNECTION_UNAVAIL = 1201&
Private Const ERROR_NO_NETWORK = 1222&
Private Const ERROR_EXTENDED_ERROR = 1208&
Private Const ERROR_NO_NET_OR_BAD_PATH = 1203&
'
' WNetGetConnection function retrieves the name of the network resource
' associated with a local device.
' > msdn.microsoft.com/en-us/library/windows/desktop/aa385453(v=vs.85).aspx
' - If the function succeeds, the return value is NO_ERROR.
' - If the function fails, the return value is a system error code, such as
' one of the following values.
'
' PathIsUNC function determines if the string is a valid Universal Naming
' Convention (UNC) for a server and share path.
' > msdn.microsoft.com/en-us/library/windows/desktop/bb773712(v=vs.85).aspx
' - Returns TRUE if the string is a valid UNC path, or FALSE otherwise.
'
' PathIsNetworkPath function determines whether a path string represents a
' network resource.
' > msdn.microsoft.com/en-us/library/windows/desktop/bb773640(v=vs.85).aspx
' - Returns TRUE if the string represents a network resource, or FALSE
' otherwise.
'
' PathStripToRoot function removes all parts of the path except for the root
' information.
' > msdn.microsoft.com/en-us/library/windows/desktop/bb773757(v=vs.85).aspx
' - Returns TRUE if a valid drive letter was found in the path, or FALSE
' otherwise.
'
' PathSkipRoot function parses a path, ignoring the drive letter or Universal
' Naming Convention (UNC) server/share path elements.
' > msdn.microsoft.com/en-us/library/windows/desktop/bb773754(v=vs.85).aspx
' - Returns the address of the beginning of the subpath that follows the root
' (drive letter or UNC server/share).
'
' PathRemoveBackslash function removes the trailing backslash from a given
' path.
' > msdn.microsoft.com/en-us/library/windows/desktop/bb773743(v=vs.85).aspx
' - Returns the address of the NULL that replaced the backslash, or the
' address of the last character if it's not a backslash.
' For Access 2010 64-Bit Support, as well as backward compatibility
#If VBA7 Then
#If UNICODE Then
Public Declare PtrSafe Function WNetGetConnection _
Lib "mpr.dll" Alias "WNetGetConnectionW" ( _
ByVal lpLocalName As LongPtr, _
ByVal lpRemoteName As LongPtr, _
lpnLength As Long _
) As Long
Public Declare PtrSafe Function PathIsUNC _
Lib "shlwapi.dll" Alias "PathIsUNCW" ( _
ByVal pszPath As LongPtr _
) As Long
Public Declare PtrSafe Function PathIsNetworkPath _
Lib "shlwapi.dll" Alias "PathIsNetworkPathW" ( _
ByVal pszPath As LongPtr _
) As Long
Public Declare PtrSafe Function PathStripToRoot _
Lib "shlwapi.dll" Alias "PathStripToRootW" ( _
ByVal pPath As LongPtr _
) As Long
Public Declare PtrSafe Function PathSkipRoot _
Lib "shlwapi.dll" Alias "PathSkipRootW" ( _
ByVal pPath As LongPtr _
) As Long
Public Declare PtrSafe Function PathRemoveBackslash _
Lib "shlwapi.dll" Alias "PathRemoveBackslashW" ( _
ByVal strPath As LongPtr _
) As LongPtr
Public Declare PtrSafe Function lStrLen _
Lib "kernel32" Alias "lstrlenW" ( _
ByVal lpString as longptr _
) As Integer
#Else
Public Declare PtrSafe Function WNetGetConnection _
Lib "mpr.dll" Alias "WNetGetConnectionA" ( _
ByVal lpLocalName As LongPtr, _
ByVal lpRemoteName As LongPtr, _
ByVal lpnLength As Long _
) As Long
Public Declare PtrSafe Function PathIsUNC _
Lib "shlwapi.dll" Alias "PathIsUNCA" ( _
ByVal pszPath As LongPtr _
) As Long
Public Declare PtrSafe Function PathIsNetworkPath _
Lib "shlwapi.dll" Alias "PathIsNetworkPathA" ( _
ByVal pszPath As LongPtr _
) As Long
Public Declare PtrSafe Function PathStripToRoot _
Lib "shlwapi.dll" Alias "PathStripToRootA" ( _
ByVal pPath As LongPtr _
) As Long
Public Declare PtrSafe Function PathSkipRoot _
Lib "shlwapi.dll" Alias "PathSkipRootA" ( _
ByVal pPath As LongPtr _
) As Long
Public Declare PtrSafe Function PathRemoveBackslash _
Lib "shlwapi.dll" Alias "PathRemoveBackslashA" ( _
ByVal strPath As LongPtr _
) As LongPtr
Public Declare PtrSafe Function lStrLen _
Lib "kernel32" Alias "lstrlenA" ( _
ByVal lpString As LongPtr _
) As Integer
#End If
Public Declare Sub CopyMemory _
Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal Destination As LongPtr, _
ByVal Source As LongPtr, _
ByVal Length As Long _
)
#Else
#If UNICODE Then
Public Declare Function WNetGetConnection _
Lib "mpr.dll" Alias "WNetGetConnectionW" ( _
ByVal lpLocalName As Long, _
ByVal lpRemoteName As Long, _
lpnLength As Long _
) As Long
Public Declare Function PathIsUNC _
Lib "shlwapi.dll" Alias "PathIsUNCW" ( _
ByVal pszPath As Long _
) As Long
Public Declare Function PathIsNetworkPath _
Lib "shlwapi.dll" Alias "PathIsNetworkPathW" ( _
ByVal pszPath As Long _
) As Long
Public Declare Function PathStripToRoot _
Lib "shlwapi.dll" Alias "PathStripToRootW" ( _
ByVal pPath As Long _
) As Long
Public Declare Function PathSkipRoot _
Lib "shlwapi.dll" Alias "PathSkipRootW" ( _
ByVal pPath As Long _
) As Long
Public Declare Function PathRemoveBackslash _
Lib "shlwapi.dll" Alias "PathRemoveBackslashW" ( _
ByVal strPath As Long _
) As Long
Public Declare Function lStrLen _
Lib "kernel32" Alias "lstrlenW" ( _
ByVal lpString As Long _
) As Integer
#Else
Public Declare Function WNetGetConnection _
Lib "mpr.dll" Alias "WNetGetConnectionA" ( _
ByVal lpLocalName As Long, _
ByVal lpRemoteName As Long, _
ByVal lpnLength As Long _
) As Long
Public Declare Function PathIsUNC _
Lib "shlwapi.dll" Alias "PathIsUNCA" ( _
ByVal pszPath As Long _
) As Long
Public Declare Function PathIsNetworkPath _
Lib "shlwapi.dll" Alias "PathIsNetworkPathA" ( _
ByVal pszPath As Long _
) As Long
Public Declare Function PathStripToRoot _
Lib "shlwapi.dll" Alias "PathStripToRootA" ( _
ByVal pPath As Long _
) As Long
Public Declare Function PathSkipRoot _
Lib "shlwapi.dll" Alias "PathSkipRootA" ( _
ByVal pPath As Long _
) As Long
Public Declare Function PathRemoveBackslash _
Lib "shlwapi.dll" Alias "PathRemoveBackslashA" ( _
ByVal strPath As Long _
) As Long
Public Declare Function lStrLen _
Lib "kernel32" Alias "lstrlenA" ( _
ByVal lpString As Long _
) As Integer
#End If
Public Declare Sub CopyMemory _
Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal Destination As Long, _
ByVal Source As Long, _
ByVal Length As Long _
)
#End If
Public Function GetUncPath(tsLocal As String) As String
Dim tsRoot As String
Dim tsPath As String
Dim tsRemoteRoot As String
Dim tsRemote As String
Dim tcbTemp As String
#If VBA7 Then
Dim lptsLocal As LongPtr
Dim lptsRoot As LongPtr
Dim lptsPath As LongPtr
Dim lptsRemote As LongPtr
Dim lptcbTemp As LongPtr
Dim lpResult As LongPtr
#Else
Dim lptsLocal As Long
Dim lptsRoot As Long
Dim lptsPath As Long
Dim lptsRemote As Long
Dim lptcbTemp As Long
Dim lpResult As Long
#End If
Dim lResult As Long
' Initialize strings. Since Strings are essentially a pointer to
' a pointer, we use StrPtr() instead of VarPtr()
'
tsLocal = tsLocal & vbNullChar ' Just in case
tsRoot = String(255, vbNullChar) ' Path Root / Drive Letter
tsPath = String(255, vbNullChar) ' Path Without Root
tsRemote = String(255, vbNullChar) ' Remote Path + Root, Resolved
tcbTemp = String(255, vbNullChar) ' Temporary Copy Buffer
lptsLocal = StrPtr(tsLocal) ' Pointer to Local Path
lptsRoot = StrPtr(tsRoot) ' Pointer to Root
lptsPath = StrPtr(tsPath) ' Pointer to Path
lptsRemote = StrPtr(tsRemote) ' Pointer to Remote
' Check is already in UNC Format
lResult = PathIsUNC(lptsLocal)
If (lResult <> 0) Then
GetUncPath = tsLocal
Exit Function
End If
' Check if its a local path or network. If Local - use that path.
lResult = PathIsNetworkPath(lptsLocal)
>! PathIsNetworkPath(lptsLocal) always returns 0
If lResult = 0 Then
GetUncPath = tsLocal
Exit Function
End If
' Extract our root from path (ie. Drive letter)
' ### lStrLen(lptsLocal returns 1 ?? ###
CopyMemory lptsRoot, lptsLocal, lStrLen(lptsLocal)
>! lStrLen(lptsLocal) always returns 1 -- unsure why
lResult = PathStripToRoot(lptsRoot)
If (lResult = 0) Then
' An error has occurred
GetUncPath = ""
Exit Function
End If
' Strip Backslash
lpResult = PathRemoveBackslash(lptsRoot)
' Find our Path portion
CopyMemory lptsPath, lptsLocal, lStrLen(lptsLocal)
lptsPath = PathSkipRoot(lptsPath)
' Strip Backslash
lpResult = PathRemoveBackslash(lptsPath)
' Convert our Root to a UNC Network format
lResult = WNetGetConnection(lptsRemote, lptsRoot, lStrLen(lptsRoot))
If lResult = ERROR_SUCCESS Then
tsRemote = tsRemote & tsPath ' Add Remote + Path to build UNC path
GetUncPath = tsRemote ' Return resolved path
Else
' Errors have occurred
GetUncPath = ""
End If
End Function
What am I missing?
Here is the final product I came up with - feel free to suggest critiques.
As it was pointed out by Gserg, I don't need to worry about whether strings are stored as single-byte characters within memory, since every modern computer will now be using Unicode. Due to this, I was able to eliminate use of the CopyMemory function and use pointer arithmetic instead.
I opted out from using an object factory wrapper and instead controlled the class initilization myself.
This has been tested on Access 2003 and Access 2010. It is 32-bit and 64-bit compatible.
Module: GetUNC
Option Compare Database
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionW" (ByVal lpLocalName As LongPtr, ByVal lpRemoteName As Long, lpnLength As Long) As Long
Private Declare PtrSafe Function PathIsUNC Lib "shlwapi.dll" Alias "PathIsUNCW" (ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function PathIsNetworkPath Lib "shlwapi.dll" Alias "PathIsNetworkPathW" (ByVal pszPath As LongPtr) As Long
Private Declare PtrSafe Function PathStripToRoot Lib "shlwapi.dll" Alias "PathStripToRootW" (ByVal pPath As LongPtr) As LongPtr
Private Declare PtrSafe Function PathSkipRoot Lib "shlwapi.dll" Alias "PathSkipRootW" (ByVal pPath As LongPtr) As Long
Private Declare PtrSafe Function PathRemoveBackslash Lib "shlwapi.dll" Alias "PathRemoveBackslashW" (ByVal strPath As LongPtr) As LongPtr
#Else
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionW" (ByVal lpLocalName As Long, ByVal lpRemoteName As Long, lpnLength As Long) As Long
Private Declare Function PathIsUNC Lib "shlwapi.dll" Alias "PathIsUNCW" (ByVal pszPath As Long) As Long
Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" Alias "PathIsNetworkPathW" (ByVal pszPath As Long) As Long
Private Declare Function PathStripToRoot Lib "shlwapi.dll" Alias "PathStripToRootW" (ByVal pPath As Long) As Long
Private Declare Function PathSkipRoot Lib "shlwapi.dll" Alias "PathSkipRootW" (ByVal pPath As Long) As Long
Private Declare Function PathRemoveBackslash Lib "shlwapi.dll" Alias "PathRemoveBackslashW" (ByVal strPath As Long) As Long
#End If
Public Function GetUNCPath(sLocalPath As String) As String
Dim lResult As Long
#If VBA7 Then
Dim lpResult As LongPtr
#Else
Dim lpResult As Long
#End If
Dim ASLocal As APIString
Dim ASPath As APIString
Dim ASRoot As APIString
Dim ASRemoteRoot As APIString
Dim ASTemp As APIString
Set ASLocal = New APIString
ASLocal.Value = sLocalPath
If ASLocal.Pointer > 0 Then
lResult = PathIsUNC(ASLocal.Pointer)
End If
If lResult <> 0 Then
GetUNCPath = ASLocal.Value
Exit Function
End If
If ASLocal.Pointer > 0 Then
lResult = PathIsNetworkPath(ASLocal.Pointer)
End If
If lResult = 0 Then
GetUNCPath = ASLocal.Value
Exit Function
End If
' Extract Root
Set ASRoot = New APIString
ASRoot.Value = sLocalPath
If ASRoot.Length = 2 And Mid(ASRoot.Value, 2, 1) = ":" Then
' We have a Root with no Path
Set ASPath = New APIString
ASPath.Value = ""
Else
If ASRoot.Pointer > 0 Then
lpResult = PathStripToRoot(ASRoot.Pointer)
End If
ASRoot.TruncToNull
If ASRoot.Pointer > 0 And Mid(ASRoot.Value, ASRoot.Length) = "\" Then
lpResult = PathRemoveBackslash(ASRoot.Pointer)
ASRoot.TruncToPointer lpResult
End If
' Extract Path
Set ASPath = New APIString
ASPath.Value = sLocalPath
lpResult = PathSkipRoot(ASPath.Pointer)
ASPath.TruncFromPointer lpResult
If ASPath.Length > 0 Then
If ASPath.Pointer > 0 And Mid(ASPath.Value, ASPath.Length) = "\" Then
lpResult = PathRemoveBackslash(ASPath.Pointer)
ASPath.TruncToPointer lpResult
End If
End If
End If
' Resolve Local Root into Remote Root
Set ASRemoteRoot = New APIString
ASRemoteRoot.Init 255
If ASRoot.Pointer > 0 And ASRemoteRoot.Pointer > 0 Then
lResult = WNetGetConnection(ASRoot.Pointer, ASRemoteRoot.Pointer, LenB(ASRemoteRoot.Value))
End If
ASRemoteRoot.TruncToNull
GetUNCPath = ASRemoteRoot.Value & ASPath.Value
End Function
Class Module: APIString
Option Compare Database
Option Explicit
Private sBuffer As String
Private Sub Class_Initialize()
sBuffer = vbNullChar
End Sub
Private Sub Class_Terminate()
sBuffer = ""
End Sub
Public Property Get Value() As String
Value = sBuffer
End Property
Public Property Let Value(ByVal sNewStr As String)
sBuffer = sNewStr
End Property
' Truncates Length
#If VBA7 Then
Public Sub TruncToPointer(ByVal lpNewUBound As LongPtr)
#Else
Public Sub TruncToPointer(ByVal lpNewUBound As Long)
#End If
Dim lpDiff As Long
If lpNewUBound <= StrPtr(sBuffer) Then Exit Sub
lpDiff = (lpNewUBound - StrPtr(sBuffer)) \ 2
sBuffer = Mid(sBuffer, 1, lpDiff)
End Sub
' Shifts Starting Point forward
#If VBA7 Then
Public Sub TruncFromPointer(ByVal lpNewLBound As LongPtr)
#Else
Public Sub TruncFromPointer(ByVal lpNewLBound As Long)
#End If
Dim lDiff As Long
If lpNewLBound <= StrPtr(sBuffer) Then Exit Sub
If lpNewLBound >= (StrPtr(sBuffer) + LenB(sBuffer)) Then
sBuffer = ""
Exit Sub
End If
lDiff = (lpNewLBound - StrPtr(sBuffer)) \ 2
sBuffer = Mid(sBuffer, lDiff)
End Sub
Public Sub Init(Size As Long)
sBuffer = String(Size, vbNullChar)
End Sub
Public Sub TruncToNull()
Dim lPos As Long
lPos = InStr(sBuffer, vbNullChar)
If lPos = 0 Then Exit Sub
sBuffer = Mid(sBuffer, 1, lPos - 1)
End Sub
Public Property Get Length() As Long
Length = Len(sBuffer)
End Property
#If VBA7 Then
Public Property Get Pointer() As LongPtr
#Else
Public Property Get Pointer() As Long
#End If
Pointer = StrPtr(sBuffer)
End Property
Thanks for the assistance.
So what you have done is a little abstraction to pretend strings are always pointers (hmm... actually, that's a reverse abstraction to remove the built-in abstraction that pointers are strings).
You now need an easy way to use that abstraction.
Have a class, WrappedString (not tested, don't have Office 2010):
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private buf() As Byte
Friend Sub Init(s As String)
Dim len_of_s_in_bytes As Long
len_of_s_in_bytes = LenB(s)
If len_of_s_in_bytes = 0 Then Exit Sub
#If UNICODE Then
ReDim b(1 To len_of_s_in_bytes + 2) 'Adding the null terminator
CopyMemory b(LBound(b)), ByVal StrPtr(s), len_of_s_in_bytes
#Else
b = StrConv(s & vbNullChar, vbFromUnicode)
#End If
End Sub
#If VB7 Then
Public Property Get Pointer() As LongPtr
Pointer = VarPtr(b(LBound(b)))
End Property
#Else
Public Property Get Pointer() As Long
Pointer = VarPtr(b(LBound(b)))
End Property
#End If
Why you need a class and not just a conversion function: to avoid memory leaks. An allocated pointer needs to be freed, the class destructor will take care of that.
Then have a construction function in a module:
Public Function ToWrappedString(s As String) As WrappedString
Set ToWrappedString = New WrappedString
ToWrappedString.Init s
End Function
Then you can call your functions:
lResult = PathIsNetworkPath(ToWrappedString("T:\TEST\").Pointer)
Obviously, you can take this abstraction one little step further:
Have a module, put all your declares there and make them private.
Then have public functions in that module, one for each declared function (that is, Public Function PathSkipRoot (...) As String, Public Function PathRemoveBackslash (...) As String etc, and make each of those public wrappers to call the declared functions using WrappedString.
Then the rest of the code will only see plain String versions of the functions.

WriteFile() call works on x86, but not x64. Getting error code 6 -- The handle is invalid using VB.NET

I am using CreateFile, WriteFile and ReadFile API calls to write some data to a USB device. The code I have works perfectly on 32 bit systems. CreateFile gets a handle to the device, pass that handle and some data to WriteFile and read from that handle with ReadFile.
My problem is, the same code does not work on a 64 bit system. The error returned from WriteFile is 6, The handle is invalid. I've checked the handle for validity on the CreateFile call and it is a valid handle. A call to GetLastError() returns 0 after CreateFile. The "file" is being opened for overlapped communication and the overlapped init calls are also returning their proper values.
My question: is there some sort of different consideration I need to make because it's a 64 bit system? A different flag? A different call altogether?
Just to note, I did a little bit of a hack on the code to make it synchronous (took out the OVERLAPPED) and it worked, so I'm assuming the problem is in my OVERLAPPED structure or the way I'm initializing the calls.
Any help is greatly appreciated.
Edit:
Below are my API signatures and the code I am using for my OVERLAPPED implementation
Private Declare Auto Function CreateFile Lib "kernel32.dll" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Integer, _
ByVal dwShareMode As Integer, _
ByVal lpSecurityAttributes As IntPtr, _
ByVal dwCreationDisposition As Integer, _
ByVal dwFlagsAndAttributes As Integer, _
ByVal hTemplateFile As IntPtr) As IntPtr
Private Declare Auto Function WriteFile Lib "kernel32.dll" _
(ByVal hFile As IntPtr, ByVal Buffer As Byte(), _
ByVal nNumberOfBytesToWrite As Integer, _
ByRef lpNumberOfBytesWritten As Integer, _
ByRef lpOverlapped As OVERLAPPED) As Boolean
Private Declare Auto Function ReadFile Lib "kernel32.dll" _
(ByVal hFile As IntPtr, _
ByVal Buffer As Byte(), _
ByVal nNumberOfBytesToRead As Integer, _
ByRef lpNumberOfBytesRead As Integer, _
ByRef lpOverlapped As OVERLAPPED) As Boolean
Private Declare Auto Function CloseHandle Lib "kernel32.dll" (ByVal hFile As IntPtr) As Boolean
Private Declare Auto Function CancelIo Lib "kernel32.dll" (ByVal hObject As IntPtr) As Boolean
Private Declare Auto Function GetOverlappedResult Lib "kernel32.dll" ( _
ByVal hFile As IntPtr, ByRef lpOverlapped As OVERLAPPED, _
ByRef lpNumberOfBytesTransferred As Integer, _
ByVal bWait As Boolean) As Boolean
Private Declare Auto Function CreateEvent Lib "kernel32.dll" ( _
ByVal lpEventAttributes As Integer, ByVal bManualReset As Boolean, _
ByVal bInitialState As Boolean, _
<MarshalAs(UnmanagedType.LPStr)> ByVal lpName As String) As IntPtr
Private Declare Auto Function WaitForSingleObject Lib "kernel32.dll" ( _
ByVal hHandle As IntPtr, ByVal dwMilliseconds As Integer) As Integer
The following is the code for the write, where the issue occurs. It should be noted that in the read, the OVERLAPPED structure's hEvent parameter is initialized in the same fashion
Try
With IOStructure
.overlap.hEvent = CreateEvent(Nothing, True, False, Nothing)
If .overlap.hEvent = 0 Then
writeSuccess = False
Else
writeSuccess = WriteFile(.hdevice, .writeBuf, .writeBuf.Length, .bytesWritten, .overlap)
'If the write didn't succeed, check to see if it's pending
If Not writeSuccess Then
If Err.LastDllError <> ERROR_IO_PENDING Then 'The write failed
writeSuccess = False
Else ' Write is pending
Select Case WaitForSingleObject(.overlap.hEvent, .timeout * 0.1) 'Wait for the write to complete
Case 0 'The write completed, check the overlapped structure for the signalled event.
writeSuccess = GetOverlappedResult(.hdevice, .overlap, .bytesWritten, 0)
Case Else
writeSuccess = False
End Select
End If
End If
End If
CloseHandle(.overlap.hEvent)
End With
' Thread.Sleep(IOStructure.timeout * 0.3)
' End While
Catch
writeSuccess = False
End Try
I had the same problem... I found that the invalid handle error disappeared when I explicitly zeroed the overlapped structure:
Dim ovl As OVERLAPPED
static ovlRead As IntPtr = Nothing
' Marshal (allocate unmanaged) structure only once
If IsNothing(ovlRead) then
ovlRead = Marshal.AllocHGlobal(Marshal.SizeOf(ovl))
Marshal.WriteInt32(ovlRead, 0, 0)
Marshal.WriteInt32(ovlRead, 4, 0)
Marshal.WriteInt32(ovlRead, 8, 0)
Marshal.WriteInt32(ovlRead, 12, 0)
Marshal.WriteInt32(ovlRead, 16, 0)
End If
Good luck.
I had the exact same problem. Same symptoms. I fixed it by
At program start-up when I first open the port I purge the I/O buffers
I then write a 0x00 (null) character to the port itself using WriteFile to initialize it.
And BINGO it works. Haven't had problems since.
Why don't you just use NativeOverlapped? It's specifically designed for this task.

How can I make a network connection with Visual Basic from Microsoft Access?

We have a Visual Basic application inside of Microsoft Access and we need to make a network connection. With VB6, there was a handy little control called WinSock that made this possible, but I can't find anything similar for the stripped down VB version that exists inside of Microsoft Access. Any ideas?
Since I'm not getting any answers, I'll try to clarify what I need this for.
My application sends out an email, and we're currently using a built-in Outlook object to create a message and send it in the background. The drawback is that it prompts the user to approve an "outside program" to send an email, which is frustrating our users and seems unnecessary. All of the other emailing options I've been able to find online require us to either download or purchase a control, which would be too labor intensive for us to deploy to all of our users.
I was hoping to use a socket control to manually connect to the SMTP server and send a message (since this is trivial in other languages) but I can't find any way to make a TCP connection in VBA.
I just dealt with this very issue in the last month. For various reasons, CDO was not adequate, direct use of MAPI way too complex, and the Outlook prompt you complain about completely unacceptable.
I ended up using Outlook Redemption. It's widely used by Access developers, though I found it to be rather convoluted and not terribly well-documented. But it is doing the job quite well.
The email "security" feature added by Microsoft has frustrated many developers. I don't know of an elegant solution. I've used the freeware app ClickYes Express with success, but of course that's not the answer you seek.
For the specific problem mentioned in the OP, there is a better solution. 'save' mail to Outlook. Do not 'send' it. It gives the user explicit control over what is sent, and when, and does not generate pop-up dialogs. A triple win.
But since you ask....
Option Explicit
Public Const AF_INET = 2 'internetwork: UDP, TCP, etc.
Public Const SOCK_STREAM = 1 'Stream socket
Public Const SOCKET_ERROR = -1
Type sockaddr_in
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero As String * 8
End Type
#If Win32 Then
'for WSAStartup() function.
Public Const WSADESCRIPTION_LEN = 256
Public Const WSASYS_STATUS_LEN = 128
Public Const WSA_DescriptionSize = WSADESCRIPTION_LEN + 1
Public Const WSA_SysStatusSize = WSASYS_STATUS_LEN + 1
Type wsaData
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSA_DescriptionSize
szSystemStatus As String * WSA_SysStatusSize
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As String * 200
End Type
#If Not VBA7 Then
'Use this section for Excel 95
Type Hostent
h_name As Long '32 bit pointer
h_aliases As Long '32 bit pointer
h_addrtype As Integer 'String * 2 (declared as short)
h_length As Integer 'String * 2 (declared as short)
h_addr_list As Long '32 bit pointer
End Type
Public Declare Function closesocket Lib "ws2_32.dll" (ByVal s As Long) As Long
Public Declare Function connect Lib "ws2_32.dll" (ByVal sID As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Public Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer
Public Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Public Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function recvstr Lib "ws2_32.dll" (ByVal s As Long, ByVal buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function send Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long
Public Declare Function WSAStartup Lib "ws2_32.dll" (wVersionRequested As Integer, lpWSAData As wsaData) As Long
Public Declare Function WSACleanup Lib "ws2_32.dll" () As Long
'Public Declare Function setsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Public Declare Function gethostbyname Lib "ws2_32.dll" (ByVal host_name As String) As Long
#Else
'on Win64, ws2_32.dll in system32 has the file description "32-bit DLL" and uses 64bit pointers (morons)
'on Win64 as on Win32, 32-bit numbers are called int.
'on VBA7/64, as on VBA6/32, 32 bit numbers are called long.
'delete following duplicate section for Excel 95
Type Hostent
h_name As LongPtr '32/64 bit pointer
h_aliases As LongPtr '32/64 bit pointer
h_addrtype As Integer 'String * 2 (declared as short)
h_length As Integer 'String * 2 (declared as short)
h_addr_list As LongPtr '32/64 bit pointer
End Type
Public Declare PtrSafe Function closesocket Lib "ws2_32.dll" (ByVal sID As LongPtr) As Long
Public Declare PtrSafe Function connect Lib "ws2_32.dll" (ByVal sID As LongPtr, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
Public Declare PtrSafe Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer
Public Declare PtrSafe Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long
Public Declare PtrSafe Function recv Lib "ws2_32.dll" (ByVal sID As LongPtr, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function recvstr Lib "ws2_32.dll" (ByVal sID As LongPtr, ByVal buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function send Lib "ws2_32.dll" (ByVal sID As LongPtr, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare PtrSafe Function socket Lib "ws2_32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long
Public Declare PtrSafe Function WSAStartup Lib "ws2_32.dll" (wVersionRequested As Integer, lpWSAData As wsaData) As Long
Public Declare PtrSafe Function WSACleanup Lib "ws2_32.dll" () As Long
'Public Declare PtrSafe Function setsockopt Lib "ws2_32.dll" (ByVal sID As Long, ByVal level As LongPtr, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Public Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr)
Public Declare PtrSafe Function gethostbyname Lib "ws2_32.dll" (ByVal host_name As String) As LongPtr
#End If
#Else
'OSX
'delete following duplicate section for Excel 95
'No 64bit version of Excel is available yet for the OSX
Type Hostent
h_name As Long '32 bit pointer
h_aliases As Long '32 bit pointer
h_addrtype As Long '32 bit int (declared as int)
h_length As Long '32 bit int (declared as int)
h_addr_list As Long '32 bit pointer
End Type
'ssize_t is a signed type. signed version of size_t,
'used where a size may instead contain a negative error code
'size_t is the unsigned integer type of the result of the sizeof operator
'size_t is an unsigned integer type of at least 16 bit
'or libsystem.dylib ?
Public Declare Function socket Lib "libc.dylib" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long
Public Declare Function connect Lib "libc.dylib" (ByVal s As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
' or read ?
Public Declare Function recv Lib "libc.dylib" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function send Lib "libc.dylib" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
Public Declare Function htons Lib "libc.dylib" (ByVal Host_Short As Integer) As Integer 'x x x, but seems to work !!!
Public Declare Function inet_addr Lib "libc.dylib" (ByVal cp As String) As Long
Public Declare Function closesocket Lib "libc.dylib" Alias "close" (ByVal s As Long) As Long
Public Declare Function setsockopt Lib "libc.dylib" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Public Declare Function gethostbyname Lib "libc.dylib" (ByVal host_name As String) As Long
Public Declare Sub CopyMemory Lib "libc.dylib" Alias "memmove" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
#End If
Private Function MyData(I_SocketAddress As sockaddr_in, Register As Integer, dataword As Long, serr As String) As Long
Dim strSend As String
Dim count As Integer
Dim bArray() As Byte
Dim errCode As Integer
Dim socketID As Long
socketID = socket(AF_INET, SOCK_STREAM, 0)
errCode = connect(socketID, I_SocketAddress, Len(I_SocketAddress))
count = send(socketID, ByVal strSend, Len(strSend), 0)
If count <> Len(strSend) Then
errCode = -1
serr = "ERROR: network failure on send, " & Err.LastDllError()
Else
count = RecvB(socketID, bArray, maxLength)
dodata bArray
End If
DoEvents
Call closesocket(socketID)
MyData = errCode
End Function
Private Function RecvB(socketID As Long, bArray() As Byte, ByVal maxLength As Integer) As Integer
Dim c As String * 1
Dim b As Byte
Dim buf() As Byte
Dim Length As Integer
Dim count As Long
Dim i As Integer
Dim dStartTime As Variant
Dim nErr As Long
Const iFlags = 0
ReDim bArray(1 To maxLength)
ReDim buf(1 To maxLength)
dStartTime = Time
While (Length < maxLength) And (4 > DateDiff("s", dStartTime, Time))
DoEvents
count = recv(socketID, buf(1), maxLength, iFlags)
If count = SOCKET_ERROR Then '-1
nErr = Err.LastDllError()
If nErr = 0 Then
RecvB = -1
Else
RecvB = -nErr
End If
'Debug.Print "socket_error in RecvB. lastdllerror:", nErr
Exit Function '
End If '
For i = 1 To count
bArray(Length + i) = buf(i)
Next
Length = Length + count
Wend
RecvB = Length
End Function
This is TCP code, not email code. It's also includes OSX VBA TCP code, which I have not previously published.