Geek asks and answers

Passing the LPCTSTR parameter to an API call from VBA in safe mode PTRSAFE and UNICODE

I struggled with this for a good week. I'm having difficulty passing string pointers to a DLL function.

Background

We just started migrating to Office 2010 starting with Office 2003. Some people will continue to have only Office 2003 for the next few years. Some people will use the 64-bit version of Office 2010 (why I don’t know, but that’s another question).

For me - I need to make a code that will work on all versions. I found this feature on the Internet a few years ago and used it. When I went to rewrite in my library, I noticed that there was a complete mixture of Unicode and ANSI calls .. and the function did not directly work in Access 2010. So I went to rewrite it. I think I'm close, but I noticed that the dll calls do not return the correct values.

What I did to try to solve the problem

  • I made sure I read the information about the ByRef and ByVal parameters.
  • I read the difference between varptr () and strptr (). I believe that I use them correctly.
  • I tried declaring lpctstr as a string, but I am not comfortable with this approach, since I'm not sure how this will happen on a 64-bit system or on a Unicode system.
    • - DB
    • , - , , - .

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

, , . . ...

Foo
  : 0   : T:\TEST\
  : T:\TEST\

, .. 1. - ​​ .

( )

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 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

?

+3
2

, , , (... , , , ).

.

, WrappedString ( , 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

, : . , .

:

Public Function ToWrappedString(s As String) As WrappedString
  Set ToWrappedString = New WrappedString
  ToWrappedString.Init s
End Function

:

lResult = PathIsNetworkPath(ToWrappedString("T:\TEST\").Pointer)

, :

, declare .
, declare d (.. Public Function PathSkipRoot (...) As String, Public Function PathRemoveBackslash (...) As String ..) declare d WrappedString. < > String.

0

, - .

Gserg, , , Unicode. CopyMemory .

factory .

Access 2003 Access 2010. 32- 64- .

: 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

: 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

.

+1

More articles:


All Articles