Передача параметра LPCTSTR вызову API из VBA в PTRSAFE и UNICODE безопасным способом
Я боролся с этим целую неделю. У меня возникли трудности при передаче строковых указателей на функцию DLL.
Фон
Мы только что начали миграцию в Office 2010 из Office 2003. Некоторые люди будут иметь Office 2003 только в течение следующих нескольких лет. Некоторые люди будут использовать Office 2010 64-разрядный (почему я не знаю - но это другая тема).
Для меня-мне нужно сделать некоторый код, который будет работать на всех версиях. Я нашел ... эта функция появилась в интернете несколько лет назад и пользовалась ею. Когда я пошел переписывать свою библиотеку, я заметил, что там была полная смесь Unicode и ANSI вызовов .. и функция откровенно не работала на Access 2010. Поэтому я решил переписать ее заново. Я думаю, что я близок - но я замечаю, что вызовы dll не возвращают правильные значения.
Что я сделал, чтобы попытаться решить эту проблему
- я убедился, что прочитал о передаче параметров ByRef и ByVal.
- я читал о разнице между varptr() и strptr(). Я считаю, что использую их правильно.
- я пытался объявить lpctstr строкой, но мне неудобен этот подход, так как я не уверен, как он будет играть на 64-битной системе или на системе Unicode.
- при работе с указателями-такие оплошности приведут к сбою и потенциально повредят БД
- использование указателей означает, что мне не нужно конвертировать в и из Unicode-its либо в Юникоде или нет-и операторы условной компиляции обеспечивают ссылки на соответствующие функции.
Краткий Краткий Пример
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
Это, по-моему, должно сработать. Я передаю указатель на строку. Но...
результаты
Фу
Возвращено: 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'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
Что я упускаю?
2 ответов:
Итак, то, что вы сделали, - это небольшая абстракция, чтобы притвориться, что строки всегда являются указателями (хм... на самом деле, это обратная абстракция, чтобы удалить встроенную абстракцию, что указатели являются строками).
Теперь вам нужен простой способ использовать эту абстракцию.Есть класс,
WrappedString(не проверено, нет офиса 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и сделайте их частными.
Тогда есть публичные функции в этом модуле, по одной для каждой функцииdeclared (то есть,Public Function PathSkipRoot (...) As String,Public Function PathRemoveBackslash (...) As Stringи т.д., и сделать каждую из этих публичных оболочек, чтобы вызватьdeclared функции, использующиеWrappedString.
Тогда остальная часть кода будет видеть только простыеStringверсии функций.
Вот конечный продукт, который я придумал - не стесняйтесь предлагать критику.
Как было отмечено Gserg, мне не нужно беспокоиться о том, хранятся ли строки в виде однобайтовых символов в памяти, поскольку каждый современный компьютер теперь будет использовать Unicode. Благодаря этому я смог исключить использование функции CopyMemory и вместо нее использовать арифметику указателей.Я отказался от использования оболочки фабрики объектов и вместо этого контролировал инициализацию класса себя.
Это было протестировано на 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Спасибо за помощь.
Comments