Export data from Listbox to Excel - ms-access

I am attempting to copy all the data from a listbox into excel (ideally I would just like to copy it to the clipboard but unsure how)
Anyway, below is my code that's throws our this error:
User-defined type not defined
Code Below:
Dim oExcel As Excel.Application ' Excel Application
Set oExcel = New Excel.Application ' Start it
oExcel.Workbooks.Open "J:\Book2.xlsx" ' **** CHANGE NAME HERE **** Open it.
On Error GoTo kill_task
Col = Listbox31.ColumnCount ' Number of Columns
Row = Listbox31.ListCount ' Number of Rows
For c = 1 To UBound(Col) ' For each Column
For L = 1 To UBound(Row) ' in Each Line
oExcel.Cells(j, i) = Listbox31.List(j - 1, i - 1) ' Write the value for Line, Columns
Next L ' Next Line
Next c ' Next Col
oExcel.ActiveWorkbook.Save ' Save
oExcel.Workbooks(1).Close ' Close Workbook
oExcel.Application.Quit ' Close Application
Exit Function
kill_task:
oExcel.ActiveWorkbook.Save ' Save
oExcel.Workbooks(1).Close ' Close Workbook
oExcel.Application.Quit ' Close Application
End Function

You can copy data to the clipboard using the code below - It's not mine I found on the web some time ago. Paste it into a new module.
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _
As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _
As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat _
As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
' Allocate moveable global memory.
'-------------------------------------------
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
' Lock the block to get a far pointer
' to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)
' Copy the string to this global memory.
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
' Unlock the memory.
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
' Open the Clipboard to copy data to.
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
' Clear the Clipboard.
X = EmptyClipboard()
' Copy the data to the Clipboard.
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
To use simply put ClipBoard_SetData (strYourString) in your VBA. Make sure you don't call the module the same as the function.

Related

How to connect to OPEN workbook in another instance of Excel SAP Issue

I tried to follow up with the topic here:
How to connect to OPEN workbook in another instance of Excel
But I ran into a problem,
I am not able grab the new instance name or path.
However I know I have open Excel window in another instance (opened from a SAP system) and when I open VBA editor in that SAP generated Excel file and I type: ? Thisworkbook.Path in immediate window I get nothing, no path is given and thus this solutions does not get the instance path.
What can I do to make it work ?
My issue is that this: Set xlApp = GetObject("C:\Tmp\TestData2.xlsx") is not grabbing the workbook name (including This.workbook.name or activeworkbook.name)
Any idea how else I can make VBA code in instance 1 work with workbook in instance 2?
I only want to save it nothing more, I'm using Saveas option, or at least I try.
Have anyone had a similar issue?
Working with the Excel files downloaded from SAP is always problematic.
You can use the module below and add before the xls.Close SaveChanges:=False this line xls.SaveAs Filename:='Any name that you want after that just place a call in your code after downloading the Excel File with
Call Close_SAP_Excel("TestData2.xlsx")
And it should work fine.
Module:
#If VBA7 Then
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare PtrSafe Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, _
ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
#Else
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As Long, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
#End If
Sub Close_SAP_Excel(ParamArray FileNames())
'Procedure to close files downloaded from SAP and at the same time close the Excel application instance that will be open with them.
Dim ExcelAppSAP As Variant
Dim ExcelFile As Variant
Dim FinishedLoop As Boolean, TimeoutReached As Boolean, FileClosed As Boolean
Dim ReTry As Long
Dim i As Long, x As Long
Set ExcelAppSAP = Nothing
ReTry = 100000 'Used as Timeout 100000 = ~10 seconds
i = 1
'The following loop is executed until excel file is closed.
'Inside of this, there is a For Loop for each Excel Instance and inside of that is another loop
'for each excel inside the instance. If name matches, it is closed.
Do While Not FinishedLoop
If i > ReTry Then
TimeoutReached = True
Exit Do
End If
For Each ExcelFile In GetExcelInstances() 'Function to Get Excel Open Instances
For Each xls In ExcelFile.Workbooks
For x = LBound(FileNames()) To UBound(FileNames())
If xls.Name = FileNames(x) Then
Set ExcelAppSAP = ExcelFile 'Set Instance opened by SAP to variable
'Here add actions if needed. Reference to workbook as xls e.g.: xls.Sheets(1).Range("A1").Copy
xls.Close SaveChanges:=False
FileClosed = True
End If
Next x
Next
Next
If FileClosed Then
FinishedLoop = True
End If
i = i + 1
Loop
ThisWorkbook.Activate
If Not TimeoutReached Then
If FileClosed Then
On Error Resume Next
If ExcelAppSAP.Workbooks.Count = 0 Then
ExcelAppSAP.Quit
End If
Else
MsgBox "Excel application instance from SAP was not closed correctly. Please close it manually or try again.", , "Error"
End If
Else
MsgBox "Max timeout reached", , "Error"
End If
End Sub
Public Function GetExcelInstances() As Collection
Dim guid&(0 To 3), acc As Object, hwnd, hwnd2, hwnd3
guid(0) = &H20400
guid(1) = &H0
guid(2) = &HC0
guid(3) = &H46000000
Set GetExcelInstances = New Collection
Do
hwnd = FindWindowExA(0, hwnd, "XLMAIN", vbNullString)
If hwnd = 0 Then Exit Do
hwnd2 = FindWindowExA(hwnd, 0, "XLDESK", vbNullString)
hwnd3 = FindWindowExA(hwnd2, 0, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hwnd3, &HFFFFFFF0, guid(0), acc) = 0 Then
GetExcelInstances.Add acc.Application
End If
Loop
End Function

How can I bring my current Access DB to foreground via VBA?

I'm trying to get my access db to come to the foreground based on the couple of lines, below. I'm not sure why it isn't working though, or if there are better methods to do this.
From what I've read, this should work:
Access.Visible = False
Access.Visible = True
But doesn't actually bring the database to the front.
Edit for more info:
Private Sub Form_Open(Cancel As Integer)
getStrUserName = Environ("username")
dbName = "myDB.accdb" ' database name
versionChckDB = "versionCheckDB.accdb" ' version check db name
strServer = "C:\My\Path\to\Server" ' server location string
strDesktop = "C:\My\Path\to\Local" ' desktop location string
strVersionCheck = "C:\My\Path\to\Version" ' version check location
Static acc As Access.Application
Dim db As DAO.Database
Dim strDbName As String
If FileLocked(strDesktop & "\" & versionChckDB) Then
Dim objAccess As Access.Application
Set objAccess = GetObject(strDesktop & "\" & versionChckDB)
objAccess.Application.Quit acQuitSaveAll
Set objAccess = Nothing
DoCmd.OpenForm "frmMainMenu"
DoCmd.RunCommand acCmdAppMaximize
Access.Visible = False
Access.Visible = True
GoTo exitSub
Else
strDbName = strDesktop & "\" & versionChckDB
Set acc = New Access.Application
acc.Visible = True
Set db = acc.DBEngine.OpenDatabase(strDbName, False, False)
acc.OpenCurrentDatabase strDbName
End If
'db.Close
exitSub:
Call SetForegroundWindow(Application.hWndAccessApp) ' bringing access DB to foreground
End Sub
Usually one uses an API function for that.
From http://www.access-programmers.co.uk/forums/showthread.php?t=132129 :
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
and then
Call SetForegroundWindow(Application.hWndAccessApp)
Edit
If you want to get the newly opened Access application window to the front, you need its hWnd:
Call SetForegroundWindow(acc.hWndAccessApp)
Edit 2
This works for me. Notepad is briefly in the foreground, then the Access window.
Module:
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub TestAccessToForeground()
Sleep 300
Shell "notepad.exe", vbNormalFocus
Sleep 300
Call SetForegroundWindow(Application.hWndAccessApp)
End Sub
Form:
Private Sub Form_Open(Cancel As Integer)
Call TestAccessToForeground
End Sub

WScript Command - Run Minimized? (MSAccess/VBA)

I am performing a quick PING against the user-selected server IP to confirm it is reachable.
The following code does exactly what I need, except I would like to avoid the quick flash of the Command Shell window.
What do I need to modify to minimize that pesky CMD window?
SystemReachable (myIP)
If InStr(myStatus, "Reply") > 0 Then
' IP is Confirmed Reachable
Else
' IP is Not Reachable
End If
''''''''''''''''''''''
Function SystemReachable(ByVal strIP As String)
Dim oShell, oExec As Variant
Dim strText, strCmd As String
strText = ""
strCmd = "ping -n 1 -w 1000 " & strIP
Set oShell = CreateObject("WScript.Shell")
Set oExec = oShell.Exec(strCmd)
Do While Not oExec.StdOut.AtEndOfStream
strText = oExec.StdOut.ReadLine()
If InStr(strText, "Reply") > 0 Then
myStatus = strText
Exit Do
Else
myStatus = ""
End If
Loop
End Function
This question may be a little old but I figure that this answer may still be able to help.
(Tested with Excel VBA, have not been able to test with Access)
The WshShell.Exec Method enables the use of .StdIn, .StdOut, and .StdErr functions to write to and read from the consol window.
The WshShell.Run Method does not allow this functionality so for some purposes using Exec is required.
While it's true that there is no built in function to start the Exec method minimized or hidden you can use API's to quickly find the Exec window hwnd and minize/hide it.
My below script takes the ProcessID from the Exec object to find the window's Hwnd. With the Hwnd you can then set the window's show state.
From my testing with Excel 2007 VBA, in most cases I never even see the window... In some cases it might be visible for a few milliseconds but would only appear a quick flicker or blink... Note: I had better results using SW_MINIMIZE than I did with SW_HIDE, but you can play around with it.
I added the TestRoutine Sub to show an example of how to use the 'HideWindow' function.
The 'HideWindow' function uses the 'GetHwndFromProcess' function to get the window hwnd from the ProcessID.
Place the below into a Module...
Option Explicit
' ShowWindow() Commands
Public Const SW_HIDE = 0
Public Const SW_MINIMIZE = 6
'GetWindow Constants
Public Const GW_CHILD = 5
Public Const GW_HWNDFIRST = 0
Public Const GW_HWNDLAST = 1
Public Const GW_HWNDNEXT = 2
Public Const GW_HWNDPREV = 3
Public Const GW_OWNER = 4
' API Functions
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Sub TestRoutine()
Dim objShell As Object
Dim oExec As Object
Dim strResults As String
Set objShell = CreateObject("WScript.Shell")
Set oExec = objShell.Exec("CMD /K")
Call HideWindow(oExec.ProcessID)
With oExec
.StdIn.WriteLine "Ping 127.0.0.1"
.StdIn.WriteLine "ipconfig /all"
.StdIn.WriteLine "exit"
Do Until .StdOut.AtEndOfStream
strResults = strResults & vbCrLf & .StdOut.ReadLine
DoEvents
Loop
End With
Set oExec = Nothing
Debug.Print strResults
End Sub
Function HideWindow(iProcessID)
Dim lngWinHwnd As Long
Do
lngWinHwnd = GetHwndFromProcess(CLng(iProcessID))
DoEvents
Loop While lngWinHwnd = 0
HideWindow = ShowWindow(lngWinHwnd, SW_MINIMIZE)
End Function
Function GetHwndFromProcess(p_lngProcessId As Long) As Long
Dim lngDesktop As Long
Dim lngChild As Long
Dim lngChildProcessID As Long
On Error Resume Next
lngDesktop = GetDesktopWindow()
lngChild = GetWindow(lngDesktop, GW_CHILD)
Do While lngChild <> 0
Call GetWindowThreadProcessId(lngChild, lngChildProcessID)
If lngChildProcessID = p_lngProcessId Then
GetHwndFromProcess = lngChild
Exit Do
End If
lngChild = GetWindow(lngChild, GW_HWNDNEXT)
Loop
On Error GoTo 0
End Function
ShowWindow function:
http://msdn.microsoft.com/en-us/library/windows/desktop/ms633548%28v=vs.85%29.aspx
GetWindow function:
http://msdn.microsoft.com/en-us/library/windows/desktop/ms633515%28v=vs.85%29.aspx
GetDesktopWindow function:
http://msdn.microsoft.com/en-us/library/windows/desktop/ms633504%28v=vs.85%29.aspx
GetWindowThreadProcessId function:
http://msdn.microsoft.com/en-us/library/windows/desktop/ms633522%28v=vs.85%29.aspx
If you need more information on how the API's work, a quick google search will provide you with a ton of information.
I hope that this can help... Thank You.
Found a very workable and silent approach:
Dim strCommand as string
Dim strPing As String
strCommand = "%ComSpec% /C %SystemRoot%\system32\ping.exe -n 1 -w 500 " & myIP & " | " & "%SystemRoot%\system32\find.exe /i " & Chr(34) & "TTL=" & Chr(34)
strPing = fShellRun(strCommand)
If strPing = "" Then
MsgBox "Not Connected"
Else
MsgBox "Connected!"
End If
'''''''''''''''''''''''''''
Function fShellRun(sCommandStringToExecute)
' This function will accept a string as a DOS command to execute.
' It will then execute the command in a shell, and capture the output into a file.
' That file is then read in and its contents are returned as the value the function returns.
' "myIP" is a user-selected global variable
Dim oShellObject, oFileSystemObject, sShellRndTmpFile
Dim oShellOutputFileToRead, iErr
Set oShellObject = CreateObject("Wscript.Shell")
Set oFileSystemObject = CreateObject("Scripting.FileSystemObject")
sShellRndTmpFile = oShellObject.ExpandEnvironmentStrings("%temp%") & oFileSystemObject.GetTempName
On Error Resume Next
oShellObject.Run sCommandStringToExecute & " > " & sShellRndTmpFile, 0, True
iErr = Err.Number
On Error GoTo 0
If iErr <> 0 Then
fShellRun = ""
Exit Function
End If
On Error GoTo err_skip
fShellRun = oFileSystemObject.OpenTextFile(sShellRndTmpFile, 1).ReadAll
oFileSystemObject.DeleteFile sShellRndTmpFile, True
Exit Function
err_skip:
fShellRun = ""
oFileSystemObject.DeleteFile sShellRndTmpFile, True
End Function
the run method of wscript already contains argumewnts to run minimized. So without all that effort shown above simply use
old code
oShellObject.Run sCommandStringToExecute & " > " & sShellRndTmpFile, 0, True
new code
oShellObject.Run sCommandStringToExecute & " > " & sShellRndTmpFile, 7, True
see Microsoft help for using the run method in wscript.
regards
Ytracks

VBA running out of memory

I have an access database with about 5000 records and each has a bmp stored in the database as an OLE. I am using Lebans OLEtoDisk, http://www.lebans.com/oletodisk.htm, to replace the objects with a file path, however, the code can only get through about 150 records and then I get an error "out of memory." I cannot figure out what is clogging up the memory. The OLEtoDisk functions use the clipboard, but I clear it after every record. Anyone have any ideas, or maybe just a way to clear all memory?
Here is the code I am using. First is the command button click event:
Option Compare Database
Option Explicit
Private Declare Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long
Private Declare Function apiOpenClipboard Lib "user32" Alias "OpenClipboard" (ByVal hwnd As Long) As Long
Private Declare Function apiEmptyClipboard Lib "user32" Alias "EmptyClipboard" () As Long
Private Declare Function apiCloseClipboard Lib "user32" Alias "CloseClipboard" () As Long
Private Declare Function CountClipboardFormats Lib "user32" () As Long
Sub EmptyClipboard()
Call apiOpenClipboard(0&)
Call apiEmptyClipboard
Call apiCloseClipboard
End Sub
Private Sub cmdCreateIPicture_Click()
DoCmd.SetWarnings False
' *********************
' You must set a Reference to: "OLE Automation" for this function to work. Goto the Menu and select Tools->References
' Scroll down to: Ole Automation and click in the check box to select this reference.
Dim lngRet, lngBytes, hBitmap As Long
Dim hpix As IPicture
Dim intRecordCount As Integer
intRecordCount = 0
Me.RecordsetClone.MoveFirst
Do While Not Me.RecordsetClone.EOF
If intRecordCount Mod 25 = 0 Then
EmptyClipboard
DoEvents
Excel.Application.CutCopyMode = False
Debug.Print "cleared"
End If
Me.Bookmark = Me.RecordsetClone.Bookmark
Me.OLEBound19.SetFocus
DoCmd.RunCommand acCmdCopy
hBitmap = GetClipBoard
Set hpix = BitmapToPicture(hBitmap)
SavePicture hpix, "C:\Users\PHammett\Images\" & intRecordCount & ".bmp"
DoCmd.RunSQL "INSERT INTO tblImageSave2 (newPath,oldPath) VALUES (""C:\Users\PHammett\Images\" & intRecordCount & """,""" & Me.RecordsetClone!Path & """);"
apiDeleteObject (hBitmap)
Set hpix = Nothing
EmptyClipboard
Me.RecordsetClone.MoveNext
intRecordCount = intRecordCount + 1
Loop
DoCmd.SetWarnings True
End Sub
Here is the code that resides in a module
Option Compare Database
Option Explicit
Private Const vbPicTypeBitmap = 1
Private Type IID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PictDesc
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PictDesc, RefIID As IID, ByVal fPictureOwnsHandle As Long, Ipic As IPicture) As Long
'windows API function declarations
'does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatVailable Lib "user32" (ByVal wFormat As Integer) As Long
'open the clipbarod to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
'get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
'empty the keyboard
Private Declare Function EmptyClipboard Lib "user32" () As Long
'close the clipobard
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function CopyEnhMetaFila Lib "gdi32" Alias "CopyEnhMetaFilaA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
'The API format types
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const xlPicture = CF_BITMAP
Const xlBitmap = CF_BITMAP
Public Function BitmapToPicture(ByVal hBmp As Long, Optional ByVal hPal As Long = 0&) As IPictureDisp
'Copyr ight: Lebans Holdings 1999 Ltd.
' May not be resold in whole or part. Please feel
' free to use any/all of this code within your
' own application without cost or obligation.
' Please include the one line Copyright notice
' if you use this function in your own code.
'
'Name: BitmapToPicture &
' GetClipBoard
'
'Purpose: Provides a method to save the contents of a
' Bound or Unbound OLE Control to a Disk file.
' This version only handles BITMAP files.
' '
'Author: Stephen Lebans
'Email: Stephen#lebans.com
'Web Site: www.lebans.com
'Date: Apr 10, 2000, 05:31:18 AM
'
'Called by: Any
'
'Inputs: Needs a Handle to a Bitmap.
' This must be a 24 bit bitmap for this release.
Dim lngRet As Long
Dim Ipic As IPicture, picdes As PictDesc, iidIPicture As IID
picdes.Size = Len(picdes)
picdes.Type = vbPicTypeBitmap
picdes.hBmp = hBmp
picdes.hPal = hPal
iidIPicture.Data1 = &H7BF80980
iidIPicture.Data2 = &HBF32
iidIPicture.Data3 = &H101A
iidIPicture.Data4(0) = &H8B
iidIPicture.Data4(1) = &HBB
iidIPicture.Data4(2) = &H0
iidIPicture.Data4(3) = &HAA
iidIPicture.Data4(4) = &H0
iidIPicture.Data4(5) = &H30
iidIPicture.Data4(6) = &HC
iidIPicture.Data4(7) = &HAB
'create the picture from the bitmap handle
lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, Ipic)
Set BitmapToPicture = Ipic
End Function
Public Function GetClipBoard() As Long
' Adapted from original Source Code by:
'* MODULE NAME: Paste Picture
'* AUTHOR & DATE: STEPHEN BULLEN, Business Modelling Solutions Ltd.
'* 15 November 1998
'*
'* CONTACT: Stephen#BMSLtd.co.uk
'* WEB SITE: http://www.BMSLtd.co.uk
Dim hClipBoard As Long
Dim hBitmap As Long
Dim hBitmap2 As Long
hClipBoard = OpenClipboard(0&)
If hClipBoard <> 0 Then
hBitmap = GetClipboardData(CF_BITMAP)
If hBitmap = 0 Then GoTo exit_error
hBitmap2 = CopyImage(hBitmap, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
hClipBoard = EmptyClipboard
hClipBoard = CloseClipboard
GetClipBoard = hBitmap2
End If
Exit Function
exit_error:
GetClipBoard = -1
End Function
Public Function ClearClipboard()
EmptyClipboard
CloseClipboard
End Function
...but I clear it after every record
Try DoEvents after this code.

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.