Access Hide Windows, but form in window's taskbar - ms-access

like the title said, i would like to hide access's windows application but see the item of form in my windows's taskbar.
I already find to hide the access windows with this API:
Const SW_HIDE = 0
Const SW_NORMAL = 1
Private Declare PtrSafe Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, ByVal FHCmdShow As Long) As Long
And: ShowWindow Application.hWndAccessApp, 0 for hiding the windows.
And i find this for the item in taskbar:
Public Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long
Public Sub AppTasklist(frmHwnd)
Dim WStyle As Long
Dim Result As Long
WStyle = GetWindowLong(frmHwnd, GWL_EXSTYLE)
WStyle = WStyle Or WS_EX_APPWINDOW
Result = SetWindowPos(frmHwnd, HWND_TOP, 0, 0, 0, 0, _
SWP_NOMOVE Or _
SWP_NOSIZE Or _
SWP_NOACTIVATE Or _
SWP_HIDEWINDOW)
Result = SetWindowLong(frmHwnd, GWL_EXSTYLE, WStyle)
Debug.Print Result
Result = SetWindowPos(frmHwnd, HWND_TOP, 0, 0, 0, 0, _
SWP_NOMOVE Or _
SWP_NOSIZE Or _
SWP_NOACTIVATE Or _
SWP_SHOWWINDOW)
End Sub
But i don't know how to make this work, i've tried fews things but nothing work.
Anyone have already use it or can help me?

Related

Prevent Linked Table to SQL Server Showing Actual Values for Binary

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.

Can't Create directory with 'FtpCreateDirectory'

here is wininet.dll declare functions:
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _
(ByVal sAgent As String, _
ByVal lAccessType As Long, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" _
(ByVal hInternetSession As Long, _
ByVal sServerName As String, _
ByVal nServerPort As Integer, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lContext As Long) As Long
Private Declare Sub FtpCreateDirectory Lib "wininet.dll" _
Alias "FtpCreateDirectoryA" _
(ByVal hConnect As Long, _
ByVal lpszDirectory As String)
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" _
(ByVal hConnect As Long, _
ByVal lpszDirectory As String) As Boolean
this is my code:
If FtpSetCurrentDirectory(hConnect, sDir) = False Then
j = CountOccurrences(sDir, "/")
Debug.Print "dir = " & sDir
Debug.Print "j = " & j
For i = 1 To j
If i = 1 Then
intOccChar = InStr(1, sDir, "/")
Else
intOccChar = InStr(intOccChar + 1, sDir, "/")
End If
Debug.Print "for i=" & i & " intOccChar = " & intOccChar
Debug.Print Left(sDir, intOccChar)
Debug.Print FtpSetCurrentDirectory(hConnect, Left(sDir,(intOccChar)))
If FtpSetCurrentDirectory(hConnect, Left(sDir, (intOccChar))) = False Then
Call FtpCreateDirectory(hConnect, Left(sDir, (intOccChar)))
End If
Next
End If
Call FtpSetCurrentDirectory(hConnect, sDir)
problem is: when there is no directory on ftp server, code works well but when first directory exist then sub directory not created
This is Immediate windows output:
dir = AkhzaBank/80/2/Credit/
j = 4
for i=1 intOccChar = 10
AkhzaBank/
False
for i=2 intOccChar = 13
AkhzaBank/80/
False
for i=3 intOccChar = 15
AkhzaBank/80/2/
False
for i=4 intOccChar = 22
AkhzaBank/80/2/Credit/
False
note: the code works with ftp upload and download, the only problem is create directory on ftp server
Thanks in advance
update!!!!!!!!!!!!!!
I find a solution form my question
i don't know why, but somehow this line
If FtpSetCurrentDirectory(hConnect, Left(sDir, (intOccChar))) = False Then
prevents create directory in subfolder. i simply delete this line and code works.
true solution
My mistake is in these lines:
Private Declare Sub FtpCreateDirectory Lib "wininet.dll" _
Alias "FtpCreateDirectoryA" _
(ByVal hConnect As Long, _
ByVal lpszDirectory As String)
i must Declare FtpCreateDirectory as Boolean Function not as Sub! so the true declare function is:
Private Declare Function FtpCreateDirectory Lib "wininet.dll" _
Alias "FtpCreateDirectoryA" _
(ByVal hConnect As Long, _
ByVal lpszDirectory As String) As Boolean

Visual Basic & MoveWindow sending external app window way off screen

I'm trying to position a couple of external windows from within my application but either end up with just a piece of the title bar on screen near the top left or the window goes far to the right and ends up at x = 32767
The function declarations are in a module and the Move_Notepad Sub is part of a form.
Option Explicit On
Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function MoveWindow Lib "user32.dll" Alias "MoveWindow" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Public Sub Move_Notepad()
'Move NotePad to 1,1 and set its Width and height to 800,720 (pixels)
Dim GoWindow As Long
hWinHand = FindWindow(vbNullString, "Untitled - Notepad")
GoWindow = MoveWindow(hWinHand, 1, 1, 800, 720, 1)
End Sub
Private Sub bMove_Notepad_Click(sender As Object, e As EventArgs) Handles bMove_Notepad.Click
Move_Notepad()
End Sub
I installed the PInvoke.net Visual Studio Extension extension and got the following code which finallyworked for me:
<DllImport("user32.dll")>
Public Function MoveWindow(ByVal hWnd As IntPtr, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal bRepaint As Boolean) As Boolean
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
Public Function FindWindow(
ByVal lpClassName As String,
ByVal lpWindowName As String) As IntPtr
End Function

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.