I have a macro that copies rtf format word document to outlook email for sending it to many recipients. However, due to this a copy of the text is also saved on the clipboard and the code crashes if many recipients are there. I was using the below code for clearing the clipboard but the code is no longer working after the office 365 update. I tried changing the declare functions to include 'Ptrsafe' but still not able to run it. Any help would be greatly appreciated. Thanks
Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As Long, ByVal dwId As Long, _
riid As tGUID, ppvObject As Object) As Long
Declare Function AccessibleChildren Lib "oleacc" _
(ByVal paccContainer As IAccessible, ByVal iChildStart As Long, _
ByVal cChildren As Long, rgvarChildren As Variant, _
pcObtained As Long) As Long
Declare Function FindWindow Lib "User32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Declare Function GetParent Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EnumChildWindows Lib "User32" (ByVal hwndParent _
As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hwnd As Long, _
ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, ByVal lpClass As String, ByVal lpCaption As String) As Long
Const CHILDID_SELF = 0&
Const ROLE_PUSHBUTTON = &H2B&
Const WM_GETTEXT = &HD
Type tGUID
lData1 As Long
nData2 As Integer
nData3 As Integer
abytData4(0 To 7) As Byte
End Type
Type AccObject
objIA As IAccessible
lngChild As Long
End Type
Dim lngChild As Long
Dim strClass As String
Dim strCaption As String
'Using Active Accessibility to clear Office clipboard
'Assumption:
'this is running within Word or Excel as a macro, thus the global Application object is available
Sub ClearOfficeClipboard()
Static accButton As AccObject
If accButton.objIA Is Nothing Then
Dim fShown As Boolean
fShown = CommandBars("Office Clipboard").Visible 'Office 2013+ version
If Not (fShown) Then
CommandBars("Office Clipboard").Visible = True 'Office 2013+ version
End If
accButton = FindAccessibleChildInWindow(GetOfficeClipboardHwnd(Application), "Clear All", ROLE_PUSHBUTTON)
End If
If accButton.objIA Is Nothing Then
MsgBox "Unable to locate the ""Clear All"" button!"
Else
accButton.objIA.accDoDefaultAction accButton.lngChild
End If
CommandBars("Office Clipboard").Visible = False
End Sub
'Retrieve window class name
Function GetWndClass(ByVal hwnd As Long) As String
Dim buf As String
Dim retval As Long
buf = Space(256)
retval = GetClassName(hwnd, buf, 255)
GetWndClass = Left(buf, retval)
End Function
'Retrieve window title
Function GetWndText(ByVal hwnd As Long) As String
Dim buf As String
Dim retval As Long
buf = Space(256)
retval = SendMessage(hwnd, WM_GETTEXT, 255, buf)
GetWndText = Left(buf, InStr(1, buf, Chr(0)) - 1)
End Function
'The call back function used by EnumChildWindows
Function EnumChildWndProc(ByVal hChild As Long, ByVal lParam As Long) As Long
Dim found As Boolean
EnumChildWndProc = -1
If strClass > "" And strCaption > "" Then
found = StrComp(GetWndClass(hChild), strClass, vbTextCompare) = 0 And _
StrComp(GetWndText(hChild), strCaption, vbTextCompare) = 0
ElseIf strClass > "" Then
found = (StrComp(GetWndClass(hChild), strClass, vbTextCompare) = 0)
ElseIf strCaption > "" Then
found = (StrComp(GetWndText(hChild), strCaption, vbTextCompare) = 0)
Else
found = True
End If
If found Then
lngChild = hChild
EnumChildWndProc = 0
Else
EnumChildWndProc = -1
End If
End Function
'Find the window handle of a child window based on its class and titie
Function FindChildWindow(ByVal hParent As Long, Optional cls As String = "", Optional title As String = "") As Long
lngChild = 0
strClass = cls
strCaption = title
EnumChildWindows hParent, AddressOf EnumChildWndProc, 0
FindChildWindow = lngChild
End Function
'Retrieve the IAccessible interface from a window handle
'Reference:Jean Ross,Chapter 17: Accessibility in Visual Basic,Advanced Microsoft Visual Basic 6.0, 2nd Edition
Function IAccessibleFromHwnd(hwnd As Long) As IAccessible
Dim oIA As IAccessible
Dim tg As tGUID
Dim lReturn As Long
' Define the GUID for the IAccessible object
' {618736E0-3C3D-11CF-810C-00AA00389B71}
With tg
.lData1 = &H618736E0
.nData2 = &H3C3D
.nData3 = &H11CF
.abytData4(0) = &H81
.abytData4(1) = &HC
.abytData4(2) = &H0
.abytData4(3) = &HAA
.abytData4(4) = &H0
.abytData4(5) = &H38
.abytData4(6) = &H9B
.abytData4(7) = &H71
End With
' Retrieve the IAccessible object for the form
lReturn = AccessibleObjectFromWindow(hwnd, 0, tg, oIA)
Set IAccessibleFromHwnd = oIA
End Function
'Recursively looking for a child with specified accName and accRole in the accessibility tree
Function FindAccessibleChild(oParent As IAccessible, strName As String, lngRole As Long) As AccObject
Dim lHowMany As Long
Dim avKids() As Variant
Dim lGotHowMany As Long, i As Integer
Dim oChild As IAccessible
FindAccessibleChild.lngChild = CHILDID_SELF
If oParent.accChildCount = 0 Then
Set FindAccessibleChild.objIA = Nothing
Exit Function
End If
lHowMany = oParent.accChildCount
ReDim avKids(lHowMany - 1) As Variant
lGotHowMany = 0
If AccessibleChildren(oParent, 0, lHowMany, avKids(0), lGotHowMany) <> 0 Then
MsgBox "Error retrieving accessible children!"
Set FindAccessibleChild.objIA = Nothing
Exit Function
End If
'To do: the approach described in http://msdn.microsoft.com/msdnmag/issues/0400/aaccess/default.aspx
' are probably better and more reliable
On Error Resume Next
For i = 0 To lGotHowMany - 1
If IsObject(avKids(i)) Then
If StrComp(avKids(i).accName, strName) = 0 And avKids(i).accRole = lngRole Then
Set FindAccessibleChild.objIA = avKids(i)
Exit For
Else
Set oChild = avKids(i)
FindAccessibleChild = FindAccessibleChild(oChild, strName, lngRole)
If Not FindAccessibleChild.objIA Is Nothing Then
Exit For
End If
End If
Else
If StrComp(oParent.accName(avKids(i)), strName) = 0 And oParent.accRole(avKids(i)) = lngRole Then
Set FindAccessibleChild.objIA = oParent
FindAccessibleChild.lngChild = avKids(i)
Exit For
End If
End If
Next i
End Function
Function FindAccessibleChildInWindow(hwndParent As Long, strName As String, lngRole As Long) As AccObject
Dim oParent As IAccessible
Set oParent = IAccessibleFromHwnd(hwndParent)
If oParent Is Nothing Then
Set FindAccessibleChildInWindow.objIA = Nothing
Else
FindAccessibleChildInWindow = FindAccessibleChild(oParent, strName, lngRole)
End If
End Function
'Retrieve the window handle of the task pane
Function GetOfficeTaskPaneHwnd(app As Object) As Long
GetOfficeTaskPaneHwnd = FindChildWindow(app.hwnd, _
"MsoCommandBar", Application.CommandBars("Task Pane").NameLocal)
End Function
'Retrieve the window handle of the clipboard child window inside task pane
'The window title of the clipboard window seems to be language independent,
'making it a better start point to searching our UI element than the task pane window
Function GetOfficeClipboardHwnd(app As Object) As Long
GetOfficeClipboardHwnd = FindChildWindow(app.hwnd, , "Collect and Paste 2.0")
End Function```
We can clear the clipboard using a MsForms.DataObject. The code below creates one without the need to reference the MsForms library.
Sub ClearClipBoard()
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText ""
.PutInClipBoard
End With
End Sub
Related
I want to use something similar to
GetObject(,"Excel.Application") to get back the application I created.
I call CreateObject("Excel.Application") to create Excel instances. Later if the VBA project resets, due to debugging and coding, the Application object variables are lost but the Excel instances are running in the background. Kind of a memory leak situation.
I want to re-attach to either re-use (preferred way) or close them.
To list the running instances of Excel:
#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 Test()
Dim xl As Application
For Each xl In GetExcelInstances()
Debug.Print "Handle: " & xl.ActiveWorkbook.FullName
Next
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
This would be best as a comment on Florent B.'s very useful function that returns a collection of the open Excel instances, but I don't have sufficient reputation to add comments. In my tests, the collection contained "repeats" of the same Excel instances i.e. GetExcelInstances().Count was larger than it should have been. A fix for that is the use of the AlreadyThere variable in the version below.
Private 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
Dim AlreadyThere As Boolean
Dim xl As Application
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
AlreadyThere = False
For Each xl In GetExcelInstances
If xl Is acc.Application Then
AlreadyThere = True
Exit For
End If
Next
If Not AlreadyThere Then
GetExcelInstances.Add acc.Application
End If
End If
Loop
End Function
#PGS62/#Philip Swannell has the correct answer for returning a Collection; I can iterate all instances; and it is brilliant, as #M1chael comment.
Let's not confuse Application objects with Workbook objects... ...Of
course it would be possible to write a nested loop that loops over the
workbooks collection of each application object
This is the nested loop implemented and fully functional:
Sub Test2XL()
Dim xl As Excel.Application
Dim i As Integer
For Each xl In GetExcelInstances()
Debug.Print "Handle: " & xl.Application.hwnd
Debug.Print "# workbooks: " & xl.Application.Workbooks.Count
For i = 1 To xl.Application.Workbooks.Count
Debug.Print "Workbook: " & xl.Application.Workbooks(i).Name
Debug.Print "Workbook path: " & xl.Application.Workbooks(i).path
Next i
Next
Set xl = Nothing
End Sub
And, for Word instances, the nested loop:
Sub Test2Wd()
Dim wd As Word.Application
Dim i As Integer
For Each wd In GetWordInstancesCol()
Debug.Print "Version: " & wd.System.Version
Debug.Print "# Documents: " & wd.Application.Documents.Count
For i = 1 To wd.Application.Documents.Count
Debug.Print "Document: " & wd.Application.Documents(i).Name
Debug.Print "Document path: " & wd.Application.Documents(i).path
Next i
Next
Set wd = Nothing
End Sub
For Word you have to use what is explained in the end of this thread
I use the following to check if two instances are running, and display a message. It could be altered to close other instance... This may be of help... I need code to return a specific instance, and return for use similar to GetObject(,"Excel.Application")... I don't think it possible though
If checkIfExcelRunningMoreThanOneInstance() Then Exit Function
In module (some of the declarations are possible used for other code):
Const MaxNumberOfWindows = 10
Const HWND_TOPMOST = -1
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Global ret As Integer
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private 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 Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetKeyNameText Lib "user32" Alias "GetKeyNameTextA" (ByVal lParam As Long, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Const VK_CAPITAL = &H14
Private Declare Function GetKeyState Lib "user32" _
(ByVal nVirtKey As Long) As Integer
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 EnumProcesses Lib "PSAPI.DLL" ( _
lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long
Private Declare Function EnumProcessModules Lib "PSAPI.DLL" ( _
ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long
Private Declare Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" ( _
ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_QUERY_INFORMATION = &H400
Global ExcelWindowName$ 'Used to switch back to later
Function checkIfExcelRunningMoreThanOneInstance()
'Check instance it is 1, else ask user to reboot excel, return TRUE to abort
ExcelWindowName = excel.Application.Caption 'Used to switch back to window later
If countProcessRunning("excel.exe") > 1 Then
Dim t$
t = "Two copies of 'Excel.exe' are running, which may stop in cell searching from working!" & vbCrLf & vbCrLf & "Please close all copies of Excel." & vbCrLf & _
" (1 Then press Alt+Ctrl+Del to go to task manager." & vbCrLf & _
" (2 Search the processes running to find 'Excel.exe'" & vbCrLf & _
" (3 Select it and press [End Task] button." & vbCrLf & _
" (4 Then reopen and use PostTrans"
MsgBox t, vbCritical, ApplicationName
End If
End Function
Private Function countProcessRunning(ByVal sProcess As String) As Long
Const MAX_PATH As Long = 260
Dim lProcesses() As Long, lModules() As Long, N As Long, lRet As Long, hProcess As Long
Dim sName As String
countProcessRunning = 0
sProcess = UCase$(sProcess)
ReDim lProcesses(1023) As Long
If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
For N = 0 To (lRet \ 4) - 1
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
If hProcess Then
ReDim lModules(1023)
If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
sName = String$(MAX_PATH, vbNullChar)
GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
sName = Left$(sName, InStr(sName, vbNullChar) - 1)
If Len(sName) = Len(sProcess) Then
If sProcess = UCase$(sName) Then
countProcessRunning = countProcessRunning + 1
End If
End If
End If
End If
CloseHandle hProcess
Next N
End If
End Function
The I found:
Dim xlApp As Excel.Application
Set xlApp = GetObject("ExampleBook.xlsx").Application
Which gets the object if you know the name of the sheet currently active in Excel instance. I guess this could be got from the application title using the first bit of code. In my app I do know the filename.
This can accomplish what you want.
Determine if an instance of Excel is open:
Dim xlApp As Excel.Application
Set xlApp = GetObject(, "Excel.Application")
If an instance is running you can access it using the xlApp object. If an instance is not running you will get a run-time error (you might need/want an error handler). The GetObject function gets the first instance of Excel that had been loaded. You can do your job with it, and to get to others, you can close that one and then try GetObject again to get the next one, etc.
So you will be attaining your ok-but-second-preferred objective
(taken from http://excelribbon.tips.net/T009452_Finding_Other_Instances_of_Excel_in_a_Macro.html).
For attaining your preferred objective, I think that https://stackoverflow.com/a/3303016/2707864 shows you how.
Create an array of objects and store the newly created Excel.Application in the array. That way you can reference them as and when you need. Let's take a quick example:
In a module:
Dim ExcelApp(2) As Object
Sub Test()
Set ExcelApp(1) = CreateObject("Excel.Application")
ExcelApp(1).Visible = True
Set ExcelApp(2) = CreateObject("Excel.Application")
ExcelApp(2).Visible = True
End Sub
Sub AnotherTest()
ExcelApp(1).Quit
ExcelApp(2).Quit
End Sub
Run Test() macro and you should see two Excel Applications pop up. Then run AnotherTest() and the Excel Applications will quit. You can even set the array to Nothing after you are done.
You can get handle of running Excel applications using the script published on http://www.ozgrid.com/forum/showthread.php?t=182853. That should get you where you want to go.
You should use this code every time you need an Excel application object. This way, your code will only ever work with one application object or use a pre-existing one. The only way you could end up with more than one is if the user started more than one. This is both the code to open Excel and attach and reuse, like you want.
Public Function GetExcelApplication() As Object
On Error GoTo openExcel
Set GetExcelApplication = GetObject(, "Excel.Application")
Exit Function
openExcel:
If Err.Number = 429 Then
Set GetExcelApplication = CreateObject("Excel.Application")
Else
Debug.Print "Unhandled exception: " & Err.Number & " " & Err.Description
End If
End Function
If you wanted to close multiple instances you would need to call GetObject followed by .Close in a loop until it throws the error 429.
The details can be found in this Article
I've got an add-in that processes and then moves certain incoming emails. The only unfortunate consequence of this is that the "new mail envelope" on the taskbar:
remains lit when there isn't any mail for the user to look at.
There's a VBA solution to this issue here: http://www.outlookcode.com/d/code/clearenvicon.htm
It doesn't seem easily portable to VB though - after clearing up what were to me the obvious changes suggested I end up with:
Module RemoveNotification
' Code sample by Outlook MVP "Neo"
' Removes the New Mail icon from the Windows system tray,
' and resets Outlook's new mail notification engine.
' Tested against Outlook 2000 (IMO) and Outlook 2002 (POP Account)
' Send questions and comments to neo#mvps.org
' WARNING: Due to the use of AddressOf, code must
' go into a module and not ThisOutlookSession or
' a class module
' Entry Point is RemoveNewMailIcon.
Public Const WUM_RESETNOTIFICATION As Long = &H407
'Required Public constants, types & declares
'for the Shell_Notify API method
Public Const NIM_ADD As Long = &H0
Public Const NIM_MODIFY As Long = &H1
Public Const NIM_DELETE As Long = &H2
Public Const NIF_ICON As Long = &H2 'adding an ICON
Public Const NIF_TIP As Long = &H4 'adding a TIP
Public Const NIF_MESSAGE As Long = &H1 'want return messages
' Structure needed for Shell_Notify API
Structure NOTIFYICONDATA
Dim cbSize As Long
Dim hwnd As Long
Dim uID As Long
Dim uFlags As Long
Dim uCallbackMessage As Long
Dim hIcon As Long
Dim szTip As String * 64
End Structure
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long,
ByVal wParam As Integer, ByVal lParam As Any) As Long
Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long,
ByVal lpClassName As String,
ByVal nMaxCount As Long) As Long
Declare Function GetWindowTextLength Lib "user32" _
Alias "GetWindowTextLengthA" _
(ByVal hwnd As Long) As Long
Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" _
(ByVal hwnd As Long,
ByVal lpString As String,
ByVal cch As Long) As Long
Declare Function EnumWindows Lib "user32" _
(ByVal lpEnumFunc As Long,
ByVal lParam As Long) As Long
Declare Function Shell_NotifyIcon Lib "shell32.dll" _
Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long,
lpData As NOTIFYICONDATA) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String,
ByVal lpWindowName As String) As Long
' This is the entry point that makes it happen
Sub RemoveNewMailIcon()
EnumWindows AddressOf EnumWindowProc, 0
End Sub
Public Function EnumWindowProc(ByVal hwnd As Long,
ByVal lParam As Long) As Long
'Do stuff here with hwnd
Dim sClass As String
Dim sIDType As String
Dim sTitle As String
Dim hResult As Long
sTitle = GetWindowIdentification(hwnd, sIDType, sClass)
If sTitle = "rctrl_renwnd32" Then
hResult = KillNewMailIcon(hwnd)
End If
If hResult Then
EnumWindowProc = False
' Reset the new mail notification engine
Call SendMessage(hwnd, WUM_RESETNOTIFICATION, 0&, 0&)
Else
EnumWindowProc = True
End If
End Function
Private Function GetWindowIdentification(ByVal hwnd As Long,
sIDType As String,
sClass As String) As String
Dim nSize As Long
Dim sTitle As String
'get the size of the string required
'to hold the window title
nSize = GetWindowTextLength(hwnd)
'if the return is 0, there is no title
If nSize > 0 Then
sTitle = Space$(nSize + 1)
Call GetWindowText(hwnd, sTitle, nSize + 1)
sIDType = "title"
sClass = Space$(64)
Call GetClassName(hwnd, sClass, 64)
Else
'no title, so get the class name instead
sTitle = Space$(64)
Call GetClassName(hwnd, sTitle, 64)
sClass = sTitle
sIDType = "class"
End If
GetWindowIdentification = TrimNull(sTitle)
End Function
Private Function TrimNull(startstr As String) As String
Dim pos As Integer
pos = InStr(startstr, Chr$(0))
If pos Then
TrimNull = Left(startstr, pos - 1)
Exit Function
End If
'if this far, there was
'no Chr$(0), so return the string
TrimNull = startstr
End Function
Private Function KillNewMailIcon(ByVal hwnd As Long) As Boolean
Dim pShell_Notify As NOTIFYICONDATA
Dim hResult As Long
'setup the Shell_Notify structure
pShell_Notify.cbSize = Len(pShell_Notify)
pShell_Notify.hwnd = hwnd
pShell_Notify.uID = 0
' Remove it from the system tray and catch result
hResult = Shell_NotifyIcon(NIM_DELETE, pShell_Notify)
If (hResult) Then
KillNewMailIcon = True
Else
KillNewMailIcon = False
End If
End Function
End Module
Which gives the below errors & warnings:
Severity Code Description Line
Error BC30205 End of statement expected. 35
Error BC30800 Method arguments must be enclosed in parentheses. 73
Error BC30828 'As Any' is not supported in 'Declare' statements. 40
Error BC30581 'AddressOf' expression cannot be converted to 'Long' because 'Long' is not a delegate type. 73
Error BC30277 Type character '$' does not match declared data type 'Char'. 129
Warning BC42104 Variable 'sIDType' is used before it has been assigned a value. A null reference exception could result at runtime. 85
Warning BC42104 Variable 'sClass' is used before it has been assigned a value. A null reference exception could result at runtime. 85
Warning BC42109 Variable 'pShell_Notify' is used before it has been assigned a value. A null reference exception could result at runtime. Make sure the structure or all the reference members are initialized before use 145
Posting this question do I can provide a full example for anyone like me who needed to figure this out...
Occasionally when automating IE you may be faced with a pop-up dialog which you need to interact with: I'm specifically talking here about the modal dialog which is IE-specific, and opened using showModalDialog
https://msdn.microsoft.com/en-us/library/ms536759(v=vs.85).aspx
These dialogs are different from the typical "pop-over" dialogs or ones based on window.open() - although they contain HTML, there's no easy way to get a reference to the document contained within the dialog. For example iterating through the windows under the Windows shell does not find this type of dialog.
I figured there must be some way to solve this problem using the Windows API, and I found a bunch of relevant pieces via Google, but no complete and self-contained example.
See my answer for how I solved my specific use case - should be easily re-used if you need something similar.
Here's what I ended up with (apologies for not including the various links where I found the key parts - will add later if I can re-find them)
Edit: https://social.msdn.microsoft.com/Forums/en-US/baf3cb64-8858-4d2d-9d7b-eaee76919256/modify-the-code-obtained-from-the-internet-explorerserver-hwnd-handle?forum=vbgeneral
Declarations (if you have 64-bit Office installed you will need to make some adjustments)
Option Explicit
' Requires: VBA project reference to "Microsoft HTML Object Library"
Private Const SMTO_ABORTIFHUNG = &H2
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" _
(ByVal hWnd As Long) As Long
Private Declare Function GetWindow Lib "user32" _
(ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" _
(ByVal hWnd As Long) As Boolean
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" _
Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function SendMessageTimeout Lib "user32" _
Alias "SendMessageTimeoutA" ( _
ByVal hWnd As Long, _
ByVal msg As Long, _
ByVal wParam As Long, _
lParam As Any, _
ByVal fuFlags As Long, _
ByVal uTimeout As Long, _
lpdwResult As Long) As Long
Private Declare Function ObjectFromLresult Lib "oleacc" ( _
ByVal lResult As Long, _
riid As UUID, _
ByVal wParam As Long, _
ppvObject As Any) As Long
Example usage:
'An example of how to use this approach - other subs below should not need adjusting
Sub DialogDemo()
Const DLG_TITLE = "User Info -- Webpage Dialog" '<< the dialog title
Dim doc As IHTMLDocument
Set doc = GetIEDialogDocument(DLG_TITLE)
If Not doc Is Nothing Then
'Debug.Print doc.body.innerHTML
doc.getElementById("password_id").Value = "password"
doc.getElementById("Notes_id").Value = "notes go here"
doc.getElementById("b_Ok_id").Click '<< click OK
Else
MsgBox "Dialog Window '" & DLG_TITLE & "' was not found!", vbOKOnly + vbExclamation
End If
End Sub
'Given an IE dialog window title, find the window and return a reference
' to the embedded HTML document object
Function GetIEDialogDocument(dialogTitle As String) As IHTMLDocument
Dim lhWndP As Long, lhWndC As Long, doc As IHTMLDocument
'find the IE dialog window given its title
If GetHandleFromPartialCaption(lhWndP, dialogTitle) Then
Debug.Print "Found dialog window - " & dialogTitle & "(" & TheClassName(lhWndP) & ")"
lhWndC = GetWindow(lhWndP, GW_CHILD) 'Find Child
If lhWndC > 0 Then
If TheClassName(lhWndC) = "Internet Explorer_Server" Then
Debug.Print , "getting the document..."
Set doc = IEDOMFromhWnd(lhWndC)
End If
End If
Else
Debug.Print "Window '" & dialogTitle & "' not found!"
End If
Set GetIEDialogDocument = doc
End Function
' IEDOMFromhWnd
' Returns the IHTMLDocument interface from a WebBrowser window
' hWnd - Window handle of the control
Function IEDOMFromhWnd(ByVal hWnd As Long) As IHTMLDocument
Dim IID_IHTMLDocument As UUID
Dim hWndChild As Long
Dim lRes As Long
Dim lMsg As Long
Dim hr As Long
If hWnd <> 0 Then
lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT") ' Register the message
SendMessageTimeout hWnd, lMsg, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes ' Get the object pointer
If lRes Then
With IID_IHTMLDocument ' Initialize the interface ID
.Data1 = &H626FC520
.Data2 = &HA41E
.Data3 = &H11CF
.Data4(0) = &HA7
.Data4(1) = &H31
.Data4(2) = &H0
.Data4(3) = &HA0
.Data4(4) = &HC9
.Data4(5) = &H8
.Data4(6) = &H26
.Data4(7) = &H37
End With
' Get the object from lRes (note - returns the object via the last parameter)
hr = ObjectFromLresult(lRes, IID_IHTMLDocument, 0, IEDOMFromhWnd)
End If
End If 'hWnd<>0
End Function
'utilty function for getting the classname given a window handle
Function TheClassName(lhWnd As Long)
Dim strText As String, lngRet As Long
strText = String$(100, Chr$(0))
lngRet = GetClassName(lhWnd, strText, 100)
TheClassName = Left$(strText, lngRet)
End Function
Private Function GetHandleFromPartialCaption(ByRef lWnd As Long, _
ByVal sCaption As String) As Boolean
Dim lhWndP As Long, sStr As String
GetHandleFromPartialCaption = False
lhWndP = FindWindow(vbNullString, vbNullString) 'PARENT WINDOW
Do While lhWndP <> 0
sStr = String(GetWindowTextLength(lhWndP) + 1, Chr$(0))
GetWindowText lhWndP, sStr, Len(sStr)
sStr = Left$(sStr, Len(sStr) - 1)
If Len(sStr) > 2 Then
If UCase(sStr) Like "*ARG*" Then Debug.Print sStr
End If
If InStr(1, sStr, sCaption) > 0 Then
GetHandleFromPartialCaption = True
lWnd = lhWndP
Exit Do
End If
lhWndP = GetWindow(lhWndP, GW_HWNDNEXT)
Loop
End Function
I'm currently working on a VBA code generator/injector that adds VBA functionality to Excel workbooks by using the VBA Extensibility. This all works fine.
However, the original code that is injected uses conditional compilation, referring to some global conditional compilation arguments:
Is there any way I can programmatically modify/add the conditional compilation arguments of a VBA project?
I checked all properties of the VBProject but couldn't find anything.
Inspired by this approach, shown by SiddharthRout, I managed to find the following solution using SendMessage and FindWindow:
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5
Public Sub subSetconditionalCompilationArguments()
Dim strArgument As String
Dim xlApp As Object
Dim wbTarget As Object
Dim lngHWnd As Long, lngHDialog As Long
Dim lngHEdit As Long, lngHButton As Long
strArgument = "PACKAGE_1 = 1"
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set wbTarget = xlApp.Workbooks.Open("C:\Temp\Sample.xlsb")
'Launch the VBA Project Properties Dialog
xlApp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
'Get the handle of the "VBAProject" Window
lngHWnd = FindWindow("#32770", vbNullString)
If lngHWnd = 0 Then
MsgBox "VBAProject Property Window not found!"
GoTo Finalize
End If
'Get the handle of the dialog
lngHDialog = FindWindowEx(lngHWnd, ByVal 0&, "#32770", vbNullString)
If lngHDialog = 0 Then
MsgBox "VBAProject Property Window could not be accessed!"
GoTo Finalize
End If
'Get the handle of the 5th edit box
lngHEdit = fctLngGetHandle("Edit", lngHDialog, 5)
If lngHEdit = 0 Then
MsgBox "Conditional Compilation Arguments box could not be accessed!"
GoTo Finalize
End If
'Enter new argument
SendMessage lngHEdit, WM_SETTEXT, False, ByVal strArgument
DoEvents
'Get the handle of the second button box (=OK button)
lngHButton = fctLngGetHandle("Button", lngHWnd)
If lngHButton = 0 Then
MsgBox "Could not find OK button!"
GoTo Finalize
End If
'Click the OK Button
SendMessage lngHButton, BM_CLICK, 0, vbNullString
Finalize:
xlApp.Visible = True
'Potentially save the file and close the app here
End Sub
Private Function fctLngGetHandle(strClass As String, lngHParent As Long, _
Optional Nth As Integer = 1) As Long
Dim lngHandle As Long
Dim i As Integer
lngHandle = FindWindowEx(lngHParent, ByVal 0&, strClass, vbNullString)
If Nth = 1 Then GoTo Finalize
For i = 2 To Nth
lngHandle = FindWindowEx(lngHParent, lngHandle, strClass, vbNullString)
Next
Finalize:
fctLngGetHandle = lngHandle
End Function
For Access 2000 I used:
Application.GetOption("Conditional Compilation Arguments")
for getting,
Application.SetOption("Conditional Compilation Arguments", "<arguments>")
for setting.
That's all.
The only way to affect anything in that dialog box is through SendMessage API functions, or maybe Application.SendKeys. You'd be better off declaring the constants in code, like this:
#Const PACKAGE_1 = 0
And then have your code modify the CodeModule of all your VBA components:
Dim comp As VBComponent
For Each comp In ThisWorkbook.VBProject.VBComponents
With comp.CodeModule
Dim i As Long
For i = 1 To .CountOfLines
If Left$(.Lines(i, 1), 18) = "#Const PACKAGE_1 =" Then
.ReplaceLine i, "#Const PACKAGE_1 = 1"
End If
Next i
End With
Next comp
This is how to get and set multiple arguments in Access after 2010:
To set them this is the code:
application.SetOption "Conditional Compilation Arguments","A=4:B=10"
To get them:
Application.GetOption("Conditional Compilation Arguments")
They are printed like this:
A = 4 : B = 10
That is how to test it:
Sub TestMe()
#If A = 1 Then
Debug.Print "a is 1"
#Else
Debug.Print "a is not 1"
#End If
End Sub
I have a string (msg) that is pretty much a very long list of items. I need to put this in a msgbox but it is not long enough to show the whole text. Is there an alternative to this?
Thank you!
The Message Box function is a built-in function of VBA and cannot exceed 1024 Characters. You are limited to creating your own UserForm or some other alternative... Such as opening and writing to an unsaved instance of notepad...
An ALL API solution to open Notepad and Write your message to it...
NOTE: If your running VBA 7.0 (Office 2010) then you'll have to add PtrSafe just after each Declare Statement...
At the top of your module paste the API Declarations and Global Variables
Option Explicit
Public Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Public Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
'Miscellaneous API Constants
Public Const NORMAL_PRIORITY_CLASS As Long = &H20&
Public Const INFINITE As Long = -1&
'Window Message Constants
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE
Public Const WM_SETTEXT As Long = &HC
'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
'Keybd_event Constants
Public Enum enumKBE
KBE_KeyDown = 0
KBE_KeyUp = 2
KBE_ExtKeyDown = 1
KBE_ExtKeyUp = 3
End Enum
'Keyboard Control Key Constants
Public Const VK_CONTROL = &H11
Public Const VK_HOME = &H24
'Keyboard Control Action Constants
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
'Create a new process
Public Declare Function CreateProcessA _
Lib "kernel32.dll" _
(ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
ByVal lpProcessAttributes As Long, _
ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, _
ByVal lpCurrentDirectory As String, _
ByRef lpStartupInfo As STARTUPINFO, _
ByRef lpProcessInformation As PROCESS_INFORMATION) As Long
'Waits until the specified process has finished processing its initial input
'and is waiting for user input with no input pending, or until the time-out
'interval has elapsed.
Public Declare Function WaitForInputIdle _
Lib "user32.dll" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
'Closes Handles Created and referenced from the CreateProcess API
Public Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
'Returns the Window Handle of the Window that is accepting User input.
Public Declare Function GetForegroundWindow Lib "user32.dll" () As Long
'Desktop Window handle
Public Declare Function GetDesktopWindow Lib "user32.dll" () As Long
'Retrieves Window handle
Public Declare Function GetWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
'Get the length of a Window's caption
Public Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
'Get the caption of a Window as a string
Public Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" _
(ByVal hwnd As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
'Returns the Class or catagory name of an Window handle
Public Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" _
(ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
'You can use the GetDlgItem function with any parent-child window pair, not just with
'dialog boxes. As long as the hDlg (hWnd) parameter specifies a parent window and the
'child window has a unique identifier (as specified by the hMenu parameter in the
'CreateWindow or CreateWindowEx function that created the child window),
'GetDlgItem returns a valid handle to the child window.
Public Declare Function GetDlgItem Lib "user32.dll" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
'Send messages to windows
Public Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
'Finds a window with the name, returns the handle.
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Gets a controls window handle. The form window handle must be specified to get a decent control.
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
'Translates (maps) a virtual-key code into a scan code or character value
Public Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
'Synthesizes a keystroke. The system can use such a synthesized keystroke to generate a WM_KEYUP or WM_KEYDOWN message.
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'Sets Keyboard control and focus to the provided Window handle
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
'Computer will wait for x number of milliseconds
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Write2Notepad function opens a new instance of Notepad and writes to it. If it succeeds, then it will return the Process ID of the Notepad instance.
Public Function Write2Notepad(strInText As String) As Long
Const nEditID = 15 'Identifier ID to Notepad's Edit Control
Dim PI As PROCESS_INFORMATION
Dim SI As STARTUPINFO
Dim RetVal As Long, hWndNote As Long, chWnd As Long, LngVal As Long, PID As Long
Dim strCaption As String, strClassName As String
'Initialize the STARTUPINFO structure
SI.cb = Len(SI)
'Start the application
RetVal = CreateProcessA(lpApplicationName:=vbNullString, _
lpCommandLine:="Notepad.exe", _
lpProcessAttributes:=0&, _
lpThreadAttributes:=0&, _
bInheritHandles:=1&, _
dwCreationFlags:=NORMAL_PRIORITY_CLASS, _
lpEnvironment:=0&, _
lpCurrentDirectory:=vbNullString, _
lpStartupInfo:=SI, _
lpProcessInformation:=PI)
'Wait for the application to finish loading
While WaitForInputIdle(PI.hProcess, INFINITE) <> 0
DoEvents
Wend
'Get the Process ID of the newly opened Notepad application
PID = PI.dwProcessID
'Close all Threads and handles for the Startup Process Information
' (This is not the Window Handle and is highly recommended)
Call CloseHandle(PI.hThread)
Call CloseHandle(PI.hProcess)
'Get the Active Application's Window Handle
'Note: when stepping through code in debugger this Will Return the VB Editor's Window Handle,
' Set a break point below GetForegroundWindow instead.
hWndNote = GetForegroundWindow()
If hWndNote = 0 Then '
'If the ForegroundWindow Handle isn't available Get the first Child Window to the Desktop
hWndNote = GetWindow(GetDesktopWindow, GW_CHILD)
End If
'Do While loop to verify the hWndNote Window Handle belongs to an Empty Untitled Notepad Window
Do
chWnd = 0
'Get Window Caption
LngVal = GetWindowTextLength(hWndNote) + 1
strCaption = String(LngVal, Chr$(0))
LngVal = GetWindowText(hWndNote, strCaption, LngVal)
strCaption = IIf(LngVal > 0, Left(strCaption, LngVal), "")
'Get the Window Class name
LngVal = GetWindowTextLength(hWndNote) + 1
strClassName = String(LngVal, Chr$(0))
LngVal = GetClassName(hWndNote, strClassName, LngVal)
strClassName = IIf(LngVal > 0, Left(strClassName, LngVal), "")
If strCaption Like "Untitled - Notepad" And strClassName = "Notepad" Then
'Get the window handle of the Edit Control which is a child window of Notepad
chWnd = GetDlgItem(hWndNote, nEditID)
'Get the character count of the notepad text to ensure it is empty (Should return 0)
If SendMessage(chWnd, WM_GETTEXTLENGTH, 0, 0) = 0 Then
Exit Do
End If
End If
'Get the next Window
hWndNote = GetWindow(hWndNote, GW_HWNDNEXT)
'Process Windows events.
DoEvents
Loop While hWndNote <> 0
If hWndNote = 0 Then
MsgBox "Cannot find Notepad's Window Handle."
Write2Notepad = 0
Exit Function
End If
If chWnd = 0 Then
'Returns child Window Hwnd - Similar to GetDlgItem
chWnd = FindWindowEx(hWndNote, ByVal 0&, vbNullString, vbNullString)
End If
DoEvents
'Sends the Text Value to Notepad
RetVal = SendMessage(chWnd, WM_SETTEXT, Len(strInText) + 1, ByVal strInText)
'To ensure the cursor position is at the top left the Keyboard Control forces the "Ctrl" Key is pressed
keybd_event VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KBE_KeyDown, 0
'Sends the "Home" input to Notepad (Simulates the CTRL + Home action to bring the cursor to the top of Notepad
SendMessage chWnd, WM_KEYDOWN, VK_HOME, 0
SendMessage chWnd, WM_KEYUP, VK_HOME, 0
'Simulates the Key up or unpressing of the "Ctrl" Key
keybd_event VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KBE_KeyUp, 0
'Ensures the Notepad window has the Cursor Focus
SetForegroundWindow (hWndNote)
'Returns the Process ID if the Value of the Settext SendMessage call equals a value of 1 (True) = successful
If CBool(RetVal) = True And PID > 0 Then
Write2Notepad = PID
Else
Write2Notepad = 0
End If
End Function
Routine to Test the Write2Notepad Function
Sub TestWriting2Notepad()
Dim strTestText As String
Dim lngProcID As Long
Dim oNotepad As Object
strTestText = "This" & vbCrLf & "is" & vbCrLf & "a Test" & vbCrLf & "to see if" & vbCrLf & "I can" & vbCrLf & _
vbCrLf & vbCrLf & "Write" & vbCrLf & vbCrLf & "2" & vbCrLf & vbCrLf & "Notepad!!!"
lngProcID = Write2Notepad(strTestText)
If lngProcID = 0 Then
Debug.Print "Something went wrong... It was probably your fault!"
Else
Debug.Print "You Successfully Wrote to Notepad... API Style!"
Do
DoEvents
Sleep 500
Set oNotepad = Nothing
On Error Resume Next
Set oNotepad = GetObject("winmgmts:root\cimv2:Win32_Process.Handle='" & lngProcID & "'")
On Error GoTo 0
Loop While Not oNotepad Is Nothing
' For Example only - Delete Below Line
MsgBox "You Closed Notepad"
End If
End Sub
The above code might look like a lot of trouble or more complicated but it will likely work much more reliably and efficiently then any other method.
The below function will copy your message to the clipboard using the MS clip tool, open notepad, and then paste the clipboard contents (your message) into Notepad... This way you don't have to save anything to a file and its easily closed... Or you can save it if you choose.
Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Print2Notepad(strMessage)
Dim oShell As Object, oExec As Object, oIn As Object
Set oShell = CreateObject("WScript.Shell")
Set oExec = oShell.Exec("clip")
Set oIn = oExec.StdIn
oIn.WriteLine strMessage
oIn.Close
Do While oExec.Status = 0
Sleep 100
Loop
Set oIn = Nothing
Set oExec = Nothing
oShell.Run "Notepad", 1, False
Sleep 250
oShell.SendKeys "^v"
End Sub
Sub test()
Call Print2Notepad("This is a test message")
End Sub
You can also add an additional routine to "Sleep" while notepad is open to halt code if you need... See Below
Sub Print2Notepad_WaitTillClose(strMessage)
Dim oShell As Object, oExec As Object, oIn As Object
Dim iPID As Variant, oNotepad As Object
Set oShell = CreateObject("WScript.Shell")
Set oExec = oShell.Exec("clip")
Set oIn = oExec.StdIn
oIn.WriteLine strMessage
oIn.Close
Do While oExec.Status = 0
Sleep 100
Loop
Set oIn = Nothing
Set oExec = Nothing
iPID = oShell.Exec("Notepad").ProcessID
Sleep 500
oShell.SendKeys "^v"
Do
Sleep 500
Set oNotepad = Nothing
On Error Resume Next
Set oNotepad = GetObject("winmgmts:root\cimv2:Win32_Process.Handle='" & iPID & "'")
On Error GoTo 0
Loop While Not oNotepad Is Nothing
' For Example only - Delete Below Line
MsgBox "You Closed Notepad"
End Sub
EDIT:
I just realized that I wrote the above code to work for VBScript... Since this is Excel, if you want to look into other methods to copy contents to the Clipboard without using the WshShell.Exec method; you can also try:
Dim DataObj As New MSForms.DataObject
Dim S As String
S = "Hello World"
DataObj.SetText S
DataObj.PutInClipboard
To use the DataObject in your code, you must set a reference to the Microsoft Forms 2.0 Object Library. This can also be done by creating a UserForm and then Deleting it... The reference will remain (Excel 2007).
For additional Clipboard API's and code take a look at:
1) http://www.cpearson.com/excel/Clipboard.aspx
2) http://msdn.microsoft.com/en-us/library/office/ff192913.aspx
3) http://msdn.microsoft.com/en-us/library/windows/desktop/ms648709%28v=vs.85%29.aspx
There are other possible methods but I think these are the most stable and reliable. I will leave the code the way it is so that it will work for both VBA and VBScript
Use a TextBox. I know ActiveX TextBoxes can even be assigned scrollbars.