I'm currently making a ms access database and I have made a form where the user inputs data. I would like the user to be able to press a button which copies the label and the entered data so they can paste it elsewhere. I have found a project which achieves exactly what I want however I cannot seem to get it to work for my application. The code below is what I found online and this is the link to the thread. It is the one labeled copypaste.zip https://www.access-programmers.co.uk/forums/threads/copy-all-date-on-form-to-clipboard-to-user-can-past-this-into-another-system.309872/ .Thank you.
This is on the module code:
Option Compare Database
Option Explicit
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1
As Long, ByVal lpString2 As Long) As Long
Public Sub SetClipboard(sUniText As String)
Dim iStrPtr As Long
Dim iLen As Long
Dim iLock As Long
Const GMEM_MOVEABLE As Long = &H2
Const GMEM_ZEROINIT As Long = &H40
Const CF_UNICODETEXT As Long = &HD
OpenClipboard 0&
EmptyClipboard
iLen = LenB(sUniText) + 2&
iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
iLock = GlobalLock(iStrPtr)
lstrcpy iLock, StrPtr(sUniText)
GlobalUnlock iStrPtr
SetClipboardData CF_UNICODETEXT, iStrPtr
CloseClipboard
End Sub
Public Function GetClipboard() As String
Dim iStrPtr As Long
Dim iLen As Long
Dim iLock As Long
Dim sUniText As String
Const CF_UNICODETEXT As Long = 13&
OpenClipboard 0&
If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
iStrPtr = GetClipboardData(CF_UNICODETEXT)
If iStrPtr Then
iLock = GlobalLock(iStrPtr)
iLen = GlobalSize(iStrPtr)
sUniText = String$(iLen \ 2& - 1&, vbNullChar)
lstrcpy StrPtr(sUniText), iLock
GlobalUnlock iStrPtr
End If
GetClipboard = sUniText
End If
CloseClipboard
End Function
This is on the form code:
Option Compare Database
Option Explicit
Private Sub Command6_Click()
Dim strSql As String
Dim ctl As Variant
For Each ctl In Me.Controls
If ctl.Tag = "?" Then
strSql = strSql & ctl.Controls(0).Caption & " " & Nz(ctl, "") & vbNewLine
End If
Next
Me.Text4 = ""
Me.Text4 = strSql
Me.Text7 = ""
SetClipboard strSql
End Sub
That is much code for nothing. This will do:
Private Sub CommandCopy_Click()
Dim Control As Control
Dim Value As String
For Each Control In Me.Controls
If Control.Tag = "?" Then
Value = Value & Control.Caption & " " & Nz(Control.Value) & vbNewLine
End If
Next
' Renamed Text4.
Me!ValueCopy.Value = Value
Me!ValueCopy.SetFocus
DoCmd.RunCommand acCmdCopy
End Sub
Related
I like to copy an excel file to clipboard by VBA, so that I can paste the excel file to some other places. I found the below VBA codes on the internet. But the codes seems not working, the Excel file (contain the VBA code) shut down automatically after running the codes. Can some one advise? Thanks.
Option Explicit
' Required data structures
Private Type POINTAPI
x As Long
y As Long
End Type
' Clipboard Manager Functions
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
' Other required Win32 APIs
Private Declare PtrSafe Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Private Declare PtrSafe Function DragQueryPoint Lib "shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
' Predefined Clipboard Formats
Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_SYLK = 4
Private Const CF_DIF = 5
Private Const CF_TIFF = 6
Private Const CF_OEMTEXT = 7
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_RIFF = 11
Private Const CF_WAVE = 12
Private Const CF_UNICODETEXT = 13
Private Const CF_ENHMETAFILE = 14
Private Const CF_HDROP = 15
Private Const CF_LOCALE = 16
Private Const CF_MAX = 17
' New shell-oriented clipboard formats
Private Const CFSTR_SHELLIDLIST As String = "Shell IDList Array"
Private Const CFSTR_SHELLIDLISTOFFSET As String = "Shell Object Offsets"
Private Const CFSTR_NETRESOURCES As String = "Net Resource"
Private Const CFSTR_FILEDESCRIPTOR As String = "FileGroupDescriptor"
Private Const CFSTR_FILECONTENTS As String = "FileContents"
Private Const CFSTR_FILENAME As String = "FileName"
Private Const CFSTR_PRINTERGROUP As String = "PrinterFriendlyName"
Private Const CFSTR_FILENAMEMAP As String = "FileNameMap"
' Global Memory Flags
Private Const GMEM_FIXED = &H0
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_NOCOMPACT = &H10
Private Const GMEM_NODISCARD = &H20
Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MODIFY = &H80
Private Const GMEM_DISCARDABLE = &H100
Private Const GMEM_NOT_BANKED = &H1000
Private Const GMEM_SHARE = &H2000
Private Const GMEM_DDESHARE = &H2000
Private Const GMEM_NOTIFY = &H4000
Private Const GMEM_LOWER = GMEM_NOT_BANKED
Private Const GMEM_VALID_FLAGS = &H7F72
Private Const GMEM_INVALID_HANDLE = &H8000
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Private Type DROPFILES
pFiles As Long
pt As POINTAPI
fNC As Long
fWide As Long
End Type
Public Function ClipboardCopyFiles(Files() As String) As Boolean
Dim data As String
Dim df As DROPFILES
Dim hGlobal As Long
Dim lpGlobal As Long
Dim i As Long
' Open and clear existing crud off clipboard.
If OpenClipboard(0&) Then
Call EmptyClipboard
' Build double-null terminated list of files.
For i = LBound(Files) To UBound(Files)
data = data & Files(i) & vbNullChar
Next
data = data & vbNullChar
' Allocate and get pointer to global memory,
' then copy file list to it.
hGlobal = GlobalAlloc(GHND, Len(df) + Len(data))
If hGlobal Then
lpGlobal = GlobalLock(hGlobal)
' Build DROPFILES structure in global memory.
df.pFiles = Len(df)
Call CopyMem(ByVal lpGlobal, df, Len(df))
Call CopyMem(ByVal (lpGlobal + Len(df)), ByVal data, Len(data))
Call GlobalUnlock(hGlobal)
' Copy data to clipboard, and return success.
If SetClipboardData(CF_HDROP, hGlobal) Then
ClipboardCopyFiles = True
End If
End If
' Clean up
Call CloseClipboard
End If
End Function
Public Function ClipboardPasteFiles(Files() As String) As Long
Dim hDrop As Long
Dim nFiles As Long
Dim i As Long
Dim desc As String
Dim filename As String
Dim pt As POINTAPI
Const MAX_PATH As Long = 260
' Insure desired format is there, and open clipboard.
If IsClipboardFormatAvailable(CF_HDROP) Then
If OpenClipboard(0&) Then
' Get handle to Dropped Filelist data, and number of files.
hDrop = GetClipboardData(CF_HDROP)
nFiles = DragQueryFile(hDrop, -1&, "", 0)
' Allocate space for return and working variables.
ReDim Files(0 To nFiles - 1) As String
filename = Space(MAX_PATH)
' Retrieve each filename in Dropped Filelist.
For i = 0 To nFiles - 1
Call DragQueryFile(hDrop, i, filename, Len(filename))
Files(i) = TrimNull(filename)
Next
' Clean up
Call CloseClipboard
End If
' Assign return value equal to number of files dropped.
ClipboardPasteFiles = nFiles
End If
End Function
Private Function TrimNull(ByVal sTmp As String) As String
Dim nNul As Long
'
' Truncate input sTmpg at first Null.
' If no Nulls, perform ordinary Trim.
'
nNul = InStr(sTmp, vbNullChar)
Select Case nNul
Case Is > 1
TrimNull = Left(sTmp, nNul - 1)
Case 1
TrimNull = ""
Case 0
TrimNull = Trim(sTmp)
End Select
Sub maaa()
'i = "c:\" & ActiveDocument.Name
'ActiveDocument.SaveAs i
Dim afile(0) As String
afile(0) = "c:\070206.excel" 'The file actually exists
MsgBox ClipboardCopyFiles(afile)
End Sub
Here is how you would do a proper Win API declaration
#If VBA7 Then
' Clipboard Manager Functions
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
' Other required Win32 APIs
Private Declare PtrSafe Function DragQueryFile Lib "shell32.dll" (ByVal HDROP As LongPtr, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Private Declare PtrSafe Function DragQueryPoint Lib "shell32.dll" (ByVal HDROP As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
' Clipboard Manager Functions
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
' Other required Win32 APIs
Private Declare Function DragQueryFile Lib "shell32.dll" (ByVal HDROP As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Private Declare Function DragQueryPoint Lib "shell32.dll" (ByVal HDROP As Long, lpPoint As POINTAPI) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If
Keep in mind that you would need for example
#If VBA7 Then
Dim hGlobal As LongPtr
Dim lpGlobal As LongPtr
#Else
Dim hGlobal As Long
Dim lpGlobal As Long
#End If
whenever you declare variables (that WIN API 'uses') in your functions/subs. This is needed just so it works on versions prior to MS Office 2010.
If you are sure that your code will be used on version 2010+, you can drop everything after #Else or drop conditional compilation altogether and just use declarations inside VBA7. LongPtr is 32/64 bit.
In your code you need to End Function TrimNull as well.
Also if you plan on using WIN API extensively you should check https://www.microsoft.com/en-us/download/details.aspx?id=9970
From hours of searching this site and googling I found that hooking into mouse scroll wheel events from VBA for use in userforms/controls is well documented for 32 bit Office and I got this to work quickly and flawlessly on a Win10/64 bit and Word 2016/32 bit environment. However when moving to a 64 bit Office environment (Win10/64bit) it consistently crashed after calling 'SetWindowsHookEx' and then moving the mouse cursor.
Being aware of the Long vs LongLong (LongPtr) implementation changes from 32 to 64 bit and the inconsistent code examples I found with respect to Long/LongPtr, I checked every bit of my code using the standard Microsoft WIN32API declare statements for 64 bit but it still crashes.
For reference: I'm building my own 'Insert cross-references' functionality as an add-in to Word, for private use.
The event log only shows an 'Exception code: 0xc0000005' occurred in VBE7.dll and I am at a loss as how to continue troubleshooting this. I've spent hours online searching for options, trying different things with my code but to no avail. Can anyone advise how to proceed to drill down on this problem? Any help is appreciated.
The relevant code snippet is below, all declares come from the above linked WIN32API reference except WindowFromPoint because the 'LongLong' type for Point seemed wrong to me. All checks on err.LastDllError report no error , except for SetWindowsHookEx, the msg from err.lastDllError is Command successfully completed. On SetWindowsHookEx the message is empty but a non-zero mouse hook is returned. Moving the mouse directly after this call crashes Word - removing the call to SetWindowsHookEx does not crash Word. I've set a debug.print in MouseProc but it never gets there.
Below code is void of VBA7/WIN64 checks as I wanted a clean code for 64 bit to check and get it working before I merge it with my 32 bit implementation.
Option Explicit
' Window field offsets for GetWindowLong() and GetWindowWord()
Private Const GWL_WNDPROC = (-4)
Private Const GWL_HWNDPARENT = (-8)
Private Const GWL_STYLE = (-16)
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_USERDATA = (-21)
Private Const GWL_ID = (-12)
Private Const GWL_HINSTANCE As Long = (-6)
'set up the variables used for the mousewheel
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As LongPtr = &H20A
Private Const HC_ACTION As Long = 0
' DLL messages
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type Msg
hwnd As LongPtr
message As Long
wParam As LongPtr
lParam As LongPtr
time As Long
pt As POINTAPI
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As LongPtr
wHitTestCode As Long
dwExtraInfo As LongPtr
End Type
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongLong) As LongPtr
Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongPtr) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowsHook Lib "user32" Alias "SetWindowsHookA" (ByVal nFilterType As Long, ByVal pfnFilterProc As LongPtr) As LongPtr
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As LongPtr) As Long
Private Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
Dim n As Long
Private mCtl As MSForms.Control
Private mbHook As Boolean
Private mLngMouseHook As LongPtr
Private mListBoxHwnd As LongPtr
Sub HookListBoxScroll64(frm As Object, ctl As MSForms.Control)
Dim tPT As POINTAPI
Dim lngAppInst As LongPtr
Dim hwndUnderCursor As LongPtr
Dim ptLL As LongLong
GetCursorPos tPT
Debug.Print "GetCursorPos err: " & GetWin32ErrorDescription(err.LastDllError)
ptLL = PointToLongLong(tPT)
Debug.Print "PointToLongLong err: " & GetWin32ErrorDescription(err.LastDllError)
hwndUnderCursor = WindowFromPoint(ptLL)
Debug.Print "WindowFromPoint err: " & GetWin32ErrorDescription(err.LastDllError)
If Not IsNull(frm.ActiveControl) And Not frm.ActiveControl Is ctl Then
ctl.SetFocus
End If
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll64
Debug.Print "UnhookListBoxScroll64 err: " & GetWin32ErrorDescription(err.LastDllError)
Set mCtl = ctl
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
Debug.Print "GetWindowLongPtr AppInst: " & lngAppInst & ", err: " & GetWin32ErrorDescription(err.LastDllError)
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
Debug.Print "SetWindowsHookEx hook: " & mLngMouseHook & ", err: " & GetWin32ErrorDescription(err.LastDllError)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Private Function MouseProc( _
ByVal nCode As Long, ByVal wParam As LongPtr, _
ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
Debug.Print "MouseProc"
Dim idx As Long
On Error GoTo errH
If (nCode = HC_ACTION) Then
Dim ptLL As LongLong
ptLL = PointToLongLong(lParam.pt)
If WindowFromPoint(ptLL) = mListBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
If TypeOf mCtl Is frame Then
If lParam.hwnd > 0 Then idx = -10 Else idx = 10
idx = idx + mCtl.ScrollTop
If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
mCtl.ScrollTop = idx
End If
ElseIf TypeOf mCtl Is UserForm Then
If lParam.hwnd > 0 Then idx = -10 Else idx = 10
idx = idx + mCtl.ScrollTop
If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
mCtl.ScrollTop = idx
End If
Else
If lParam.hwnd > 0 Then idx = -1 Else idx = 1
idx = idx + mCtl.ListIndex
If idx >= 0 Then mCtl.ListIndex = idx
End If
Exit Function
End If
Else
UnhookListBoxScroll64
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll64
End Function
I am currently trying to find a way to check whether a window is open or not using Findwindow Function. I am able to find the window if i know the entire name of the window. In the below code i know that the name of the window is "win32api - Notepad" so i can easily find the window however i want to know whether it is possible to identify the window if i know only part name like "win32*".
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Sub runapplication()
hwnd = FindWindow(vbNullString, "win32api - Notepad")
MsgBox (hwnd)
End Sub
One way you can do this is with the EnumWindows API function. Since it operates via a callback function, you'll need to cache both the criteria and the results somewhere that has scope beyond the calling function:
Public Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, _
ByVal param As Long) As Long
Public Declare Function IsWindowVisible Lib "User32" (ByVal hWnd As Long) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Public Const MAX_LEN = 260
Public results As Dictionary
Public criteria As String
Public Sub Example()
criteria = "win32*"
Set results = New Dictionary
Call EnumWindows(AddressOf EnumWindowCallback, &H0)
Dim result As Variant
For Each result In results.Keys
Debug.Print result & " - " & results(result)
Next result
End Sub
Public Function EnumWindowCallback(ByVal hwnd As Long, ByVal param As Long) As Long
Dim retValue As Long
Dim buffer As String
If IsWindowVisible(hwnd) Then
buffer = Space$(MAX_LEN)
retValue = GetWindowText(hwnd, buffer, Len(buffer))
If retValue Then
If buffer Like criteria Then
results.Add hwnd, Left$(buffer, retValue)
End If
End If
End If
EnumWindowCallback = 1
End Function
The below code worked for me. Just Declared IsWindowVisible Function and Added Microsoft scripting runtime library to my project.
Public Declare Function EnumWindows Lib "User32" (ByVal lpEnumFunc As Long, _
ByVal param As Long) As Long
Public Declare Function GetWindowText Lib "User32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Public Declare Function IsWindowVisible Lib "User32" (ByVal hWnd As Long) As Long
Public Const MAX_LEN = 260
Public results As Dictionary
Public criteria As String
Public Sub Example()
criteria = "win32"
Set results = New Dictionary
Call EnumWindows(AddressOf EnumWindowCallback, &H0)
Dim result As Variant
For Each result In results.Keys
Debug.Print result & " - " & results(result)
Next result
End Sub
Public Function EnumWindowCallback(ByVal hWnd As Long, ByVal param As Long) As Long
Dim retValue As Long
Dim buffer As String
If IsWindowVisible(hWnd) Then
buffer = Space$(MAX_LEN)
retValue = GetWindowText(hWnd, buffer, Len(buffer))
If retValue Then
If InStr(1, buffer, criteria, vbTextCompare) > 0 Then
results.Add hWnd, Left$(buffer, retValue)
End If
End If
End If
EnumWindowCallback = 1
End Function
I need to create a userform for my excel vba program., But how can I add "minimize" button for this userform? Thanks.
You can try this code :
Private Sub ToggleButton1_Click()
If ToggleButton1.Value = True Then
Me.Height = Me.Height * 0.25
Else
Me.Height = dHeight
End If
End Sub
Private Sub UserForm_Initialize()
dHeight = Me.Height
End Sub
[EDIT]
Found this link where they explain how to do it with an API to minimize.
Here is the given code :
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Const GWL_STYLE As Long = (-16) 'Sets a new window style
Private Const WS_SYSMENU As Long = &H80000 'Windows style
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const SW_SHOWMAXIMIZED = 3
Private Sub UserForm_Activate()
Dim lFormHandle As Long, lStyle As Long
'===========================================
'= Originally from Dax =
'= Modified with comments by Ivan F Moala =
'= 22/07/01 =
'===========================================
'Lets find the UserForm Handle the function below retrieves the handle
'to the top-level window whose class name ("ThunderDFrame" for Excel)
'and window name (me.caption or UserformName caption) match the specified strings.
lFormHandle = FindWindow("ThunderDFrame", Me.Caption)
'The GetWindowLong function retrieves information about the specified window.
'The function also retrieves the 32-bit (long) value at the specified offset
'into the extra window memory of a window.
lStyle = GetWindowLong(lFormHandle, GWL_STYLE)
'lStyle is the New window style so lets set it up with the following
lStyle = lStyle Or WS_SYSMENU 'SystemMenu
lStyle = lStyle Or WS_MINIMIZEBOX 'With MinimizeBox
lStyle = lStyle Or WS_MAXIMIZEBOX 'and MaximizeBox
'Now lets set up our New window the SetWindowLong function changes
'the attributes of the specified window , given as lFormHandle,
'GWL_STYLE = New windows style, and our Newly defined style = lStyle
SetWindowLong lFormHandle, GWL_STYLE, (lStyle)
'Remove >'< if you want to show form Maximised
'ShowWindow lFormHandle, SW_SHOWMAXIMIZED 'Shows Form Maximized
'The DrawMenuBar function redraws the menu bar of the specified window.
'We need this as we have changed the menu bar after Windows has created it.
'All we need is the Handle.
DrawMenuBar lFormHandle
End Sub
Regards,
Max
'Place this code in a Module
Private Declare Function FindWindowA Lib "USER32" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "USER32" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Option Explicit
Sub FormatUserForm(UserFormCaption As String)
Dim hWnd As Long
Dim exLong As Long
hWnd = FindWindowA(vbNullString, UserFormCaption)
exLong = GetWindowLongA(hWnd, -16)
If (exLong And &H20000) = 0 Then
SetWindowLongA hWnd, -16, exLong Or &H20000
Else
End If
End Sub
Sub ShowForm()
UserForm1.Show
End Sub
'Place this code in a UserForm with one Command Button named CommandButton1.
Option Explicit
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Call FormatUserForm(Me.Caption)
End Sub
I am wrapping up an office application (VBA) that makes a call to a C# console application to perform some of the heavy lifting for the application (large simulation program). I would like to be able to have the VBA application wait for the console application to complete as well as retreive the exit code from the console application. I have been able to do the former, but have yet to be able to retrieve the exit code from the application. Is there any way that I can use something like
Diagnostics.Process.Start(filePath)
I have seen this in VB but not sure about VBA. Otherwise, any other suggestions?
Have a look at WaitForSingleObject and GetExitCodeProcess functions.
Example Usage:
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Public Const INFINITE = &HFFFF
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
Sub RunApplication(ByVal Cmd as String)
lTaskID = Shell(Cmd, vbNormalFocus)
' Get process handle
lPID = OpenProcess(PROCESS_ALL_ACCESS, True, lTaskID)
If lPID Then
' Wait for process to finish
Call WaitForSingleObject(lPID, INFINITE)
' Get Exit Process
If GetExitCodeProcess(lPID, lExitCode) Then
' Received value
MsgBox "Successfully returned " & lExitCode, vbInformation
Else
MsgBox "Failed: " & DLLErrorText(Err.LastDllError), vbCritical
End If
Else
MsgBox "Failed: " & DLLErrorText(Err.LastDllError), vbCritical
End If
lTaskID = CloseHandle(lPID)
End Sub
Public Function DLLErrorText(ByVal lLastDLLError As Long) As String
Dim sBuff As String * 256
Dim lCount As Long
Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100, FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Const FORMAT_MESSAGE_FROM_HMODULE = &H800, FORMAT_MESSAGE_FROM_STRING = &H400
Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000, FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
lCount = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0)
If lCount Then
DLLErrorText = Left$(sBuff, lCount - 2) ' Remove line feeds
End If
End Function
This functionality has been wrapped up in the ShellAndWait function.
Excellent write up on it here.