I'm using the following code to open a folder in min szie
Call Shell("explorer.exe" & " " & "D:\Archive\", vbMinimizedFocus)
Call Shell("explorer.exe" & " " & "D:\Shortcuts\", vbMinimizedFocus)
I would however love to to let pop up next to each other. One on the left size and one on the right. Like this
Anybody know whether there is a way to move screens after opening?
Tried And Tested [Win 7 / Excel 2010 - VBA / 1920 X 1080 (Mobile PC Display)]
Here is a very basic example on how to achieve what you want. We will be using four API's for this.
FindWindow
SetParent
SetWindowPos
GetDesktopWindow
I will not individually cover these APIs. To understand what do they do, simply click on the respective links.
LOGIC:
The newer explorer do not have Titles as I mentioned in my comments above. For example see this
However playing with Spy++, I was able to see that they had captions but were not displayed on the folder's title bar. See screenshot below.
Use FindWindow API to locate the window using it's Caption
Using SetParent, we are assigning the parent window i.e Desktop for the specified child window (Folder Window).
Reposition the window using SetWindowPos API
CODE:
Paste this code in a module and change the folder as applicable. This is a very basic code and I am not doing any error handling. I am sure you will take care of it.
Private Declare Function FindWindow Lib "user32.dll" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SetParent Lib "user32.dll" _
(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SetWindowPos Lib "user32.dll" _
(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
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Const SWP_NOZORDER As Long = &H4
Private Const SWP_SHOWWINDOW As Long = &H40
Private Sub Sample()
Dim lHwnd As Long
Dim Fldr1Path As String, Fldr2Path As String
Dim winName As String
Dim Flder1X As Long, Flder1Y As Long
Dim FlderWidth As Long, FlderHeight As Long
'~~> Folder one X,Y screen position
Flder1_X = 50: Flder1_Y = 50
'~~> Folder Width and Height. Keepping the same for both
FlderWidth = 200: FlderHeight = 200
'~~> Two Folders you want to open
Fldr1Path = "C:\Temp1"
Fldr2Path = "C:\Temp2"
'~~> The Top most folder name which is also the caption of the window
winName = GetFolderName(Fldr1Path)
'~~~> Launch the folder
Shell "explorer.exe" & " " & Fldr1Path, vbMinimizedFocus
'~~> wait for 2 seconds
Wait 2
'~~> Find the Window.
'~~> I am using `vbNullString` to make it compatible with XP
lHwnd = FindWindow(vbNullString, winName)
'~~> Set the parent as desktop
SetParent lHwnd, GetDesktopWindow()
'~~> Move the Window
SetWindowPos lHwnd, 0, Flder1_X, Flder1_Y, FlderWidth, _
FlderHeight, SWP_NOZORDER Or SWP_SHOWWINDOW
'~~> Similary for Folder 2
winName = GetFolderName(Fldr2Path)
Shell "explorer.exe" & " " & Fldr2Path, vbMinimizedFocus
Wait 2
lHwnd = FindWindow(vbNullString, winName)
SetParent lHwnd, 0
SetWindowPos lHwnd, 0, Flder1_X + FlderWidth + 10, Flder1_Y, _
FlderWidth, FlderHeight, SWP_NOZORDER Or SWP_SHOWWINDOW
MsgBox "Done"
End Sub
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
Function GetFolderName(sPath As String)
Dim MyAr
MyAr = Split(sPath, "\")
GetFolderName = MyAr(UBound(MyAr))
End Function
SCREENSHOT:(Folders arranged)
EDIT
Tried And Tested [Win XP / Excel 2003 - VBA / on VM]
Special Thanks to Peter Albert for testing this for me.
If you are working with the same 2 folders, you may can easily do this.
1- Open the two folders manually and then set the desired size and location. Close the folder.
2- Then next time you call the script, do the following
Set oShell = WScript.CreateObject("WScript.Shell")
oShell.Run "Explorer /n, D:\Archive\", 4, False
oShell.Run "Explorer /n, D:\Shortcuts\", 4, False
This will open the folder with last saved position and size.
NOTE Just tested it on my Win7 machine and it doesnt work. Turns out that Win 7 doesnt remember folder position any more (it only remembers the size). Read more about it here.
Related
I created a tool that clicks an item on a webpage in IE, then the webpage dialog box pops up, I need to put data in the blank field of the dialog box using VBA.
I can't view the source code of the dialog box manually (right click). The webpage and URL are confidential, so I can't share that. I am using FindWindow function to find a webpage dialog box, and it returns the HWND value successfully. Here is my code:
Sub FindWebDialog()
Dim hwnd As Long
hwnd = FindWindow(vbNullString, "Live Payments -- Webpage Dialog")
If hwnd <> 0 Then
'get the htmldocument
Else
MsgBox "no dialog found"
End If
End Sub
I think that if I get the return value of the FindWindow, from there I can retrieve the source code of the webpage dialog box, then use it to find the exact location of the blank field. I would like to know how to get the source code of the webpage dialog box using the HWND.
It's not clear what actually is that dialog box. Is it a part of the webpage document, or opened within new IE popup window? Is it modal?
Please make a screenshot of the dialog box, so that both the webpage and the dialog box titles will be visible. You may scrub the sensitive characters on the screenshot (e. g. in paint), and then upload it.
Also try to examine opened IE windows using the below code:
Option Explicit
Sub Test()
Dim oWnd As Object
For Each oWnd In CreateObject("Shell.Application").Windows
On Error Resume Next
If TypeName(oWnd.Document) = "HTMLDocument" Then
Wait oWnd
Debug.Print "URL = " & oWnd.Document.Location
Debug.Print "HWND = " & oWnd.Hwnd
Debug.Print "Title = " & oWnd.Document.Title
Debug.Print "Error = " & Err.Number
Debug.Print
End If
Next
Debug.Print "Completed"
End Sub
Sub Wait(oIE As Object)
Do While oIE.Busy Or oIE.readyState <> 4
DoEvents
Loop
Do While oIE.Document.readyState <> "complete"
DoEvents
Loop
End Sub
Do the following steps: make actions the dialog box to appear, find HWND using the code you posted in the question, then run the code shown above and share the output.
Both of them, the screenshot and the output listing + FindWindow's HWND, should make things clearer.
Sorry not responding to you questions above, been searching other sites for help.
Using the code above, did not find the dialog box, the IE dialog box is opened when a link was click inside the IE parent window and it is modal. The problem is only findwindow can find the dialog box and findwindow only returns HWND(windows handle which is a Long Integer). I found some code getting the htmldocument of the dialog box using HWND as the reference. (below)
Private Type UUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
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 EnumChildWindows Lib "user32" ( _
ByVal hWndParent As Long, _
ByVal lpEnumFunc As Long, _
lParam 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 Const SMTO_ABORTIFHUNG = &H2
Private Declare Function ObjectFromLresult Lib "oleacc" ( _
ByVal lResult As Long, _
riid As UUID, _
ByVal wParam As Long, _
ppvObject As Any) As Long
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public 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
If Not IsIEServerWindow(hWnd) Then
' Find a child IE server window
EnumChildWindows hWnd, AddressOf EnumChildProc, hWnd
End If
If hWnd <> 0 Then
' Register the message
lMsg = RegisterWindowMessage("WM_HTML_GETOBJECT")
' Get the object pointer
Call SendMessageTimeout(hWnd, lMsg, 0, 0, _
SMTO_ABORTIFHUNG, 1000, lRes)
If lRes Then
' Initialize the interface ID
With IID_IHTMLDocument
.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
hr = ObjectFromLresult(lRes, IID_IHTMLDocument, 0, IEDOMFromhWnd)
End If
End If
End If
End Function
Public Function IsIEServerWindow(ByVal hWnd As Long) As Boolean
Dim lRes As Long
Dim sClassName As String
'Initialize the buffer
sClassName = String$(100, 0)
'Get the window class name
lRes = GetClassName(hWnd, sClassName, Len(sClassName))
sClassName = Left$(sClassName, lRes)
IsIEServerWindow = StrComp(sClassName, _
"Internet Explorer_Server", _
vbTextCompare) = 0
End Function
And use it this code to retrieve the htmldocument so I can search for the corresponding element of a text field that I need.
Sub HtmlDocFromHandle()
Dim myHandle As Long, iHtml2 As IHTMLDocument2
Dim ieobj As Object
myHandle = FindWindow(vbNullString, "TITLE OF THE WINDOW")
If myHandle <> 0 Then
Set ihtml2 = IEDOMFromhWnd(hForm)
Set ieobj = ihtml2.activeElement
Debug.Print ieobj.document
Else
MsgBox "Window not found"
End If
End Function
I'm trying to get VBA to automate saving a file from IE. Thanks to various posts on these forums, I can login, navigate pages, and click the download link. The Save prompt appears at the bottom of IE, then I'm stuck:
I've been trying to use the code samples from https://www.mrexcel.com/forum/excel-questions/502298-need-help-regarding-ie-automation-using-vba-post3272730.html#post3272730, but the second FindWindow always returns 0:
hWnd = FindWindowEx(hWnd, 0, "DUIViewWndClassName", vbNullString)
I'm using VBA 7.0 in Excel 14, and IE11.
There is advice at the top of the original post:
'Note - IE may block the download, displaying its Information Bar at
the top of the tab, and preventing this program from 'automatically
downloading the file. To prevent this, add NRLDC to IE's Trusted
sites (Tools - Internet Options - 'Security - Trusted sites - Sites)
I can't access the trusted sites list due to IT policy, but the download prompt appears, so I don't think this is the issue.
The code I've taken is from Doongie's reply, which indicates it's updated for Windows 7:
Private Sub File_Download_Click_Save()
Dim hWnd As Long
Dim timeout As Date
Debug.Print "File_Download_Click_Save"
'Find the File Download window, waiting a maximum of 30 seconds for it to appear
timeout = Now + TimeValue("00:00:30")
Do
hWnd = FindWindow("#32770", "") 'returns various numbers on different runs: 20001h 10440h
DoEvents
Sleep 200
Loop Until hWnd Or Now > timeout
Debug.Print " File Download window "; Hex(hWnd)
If hWnd Then
SetForegroundWindow hWnd
'Find the child DUIViewWndClassName window
hWnd = FindWindowEx(hWnd, 0, "DUIViewWndClassName", vbNullString) 'always returns 0
Debug.Print " DUIViewWndClassName "; Hex(hWnd)
End If
If hWnd Then
'Find the child DirectUIHWND window
hWnd = FindWindowEx(hWnd, 0, "DirectUIHWND", "")
Debug.Print " DirectUIHWND "; Hex(hWnd)
End If
If hWnd Then
'Find the child FloatNotifySink window
hWnd = FindWindowEx(hWnd, 0, "FloatNotifySink", "")
Debug.Print " FloatNotifySink "; Hex(hWnd)
End If
If hWnd Then
'Find the child ComboBox window
hWnd = FindWindowEx(hWnd, 0, "ComboBox", "")
Debug.Print " ComboBox "; Hex(hWnd)
End If
If hWnd Then
SetForegroundWindow hWnd
'Find the child Edit window
hWnd = FindWindowEx(hWnd, 0, "Edit", "")
Debug.Print " Edit "; Hex(hWnd)
End If
If hWnd Then
'Click the Save button
SetForegroundWindow hWnd
Sleep 600 'this sleep is required and 600 milliseconds seems to be the minimum that works
SendMessage hWnd, BM_CLICK, 0, 0
End If
End Sub
Is there any way (that won't get me in trouble with IT!) that I can inspect the handle numbers of the IE elements? Code inspector only shows me the page code, not IE dialogues.
Is there a list of possible element names for lpsz1 defined somewhere, as they apply to elements of IE?
Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Have you tried the dreaded sendkeys?
Application.SendKeys "%{S}"
Application.SendKeys "%{O}"
In my IE Automation used below code to save file from IE. Below code requires VBA reference to UIAutomationCore.dll and can be found at
%windir%/sysWow64/UIAutomationCore.dll
and enable trust access to vba by
File -> Options -> Trust Center -> Trust Center Settings -> Macro Settings -> Check Trust access to the VBA
Private Sub InvokeSaveButton(IEHwnd As Long)
Dim o As IUIAutomation
Dim e As IUIAutomationElement
Set o = New CUIAutomation
Dim h As Long
h = IEHwnd
h = FindWindowEx(h, 0, "Frame Notification Bar", vbNullString)
If h = 0 Then Exit Sub
Set e = o.ElementFromHandle(ByVal h)
Dim iCnd As IUIAutomationCondition
Set iCnd = o.CreatePropertyCondition(UIA_NamePropertyId, "Save")
Dim Button As IUIAutomationElement
Set Button = e.FindFirst(TreeScope_Subtree, iCnd)
Dim InvokePattern As IUIAutomationInvokePattern
Set InvokePattern = Button.GetCurrentPattern(UIA_InvokePatternId)
InvokePattern.Invoke
End Sub
You could try the urlmon library. Change the url and file name + extension to what you need to.
It will probably not work on a website where you have to log in to get to the file.
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim errValue As Long
errValue = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If errValue = 0 Then
MsgBox "Download Completed, saved at: " & LocalFilename
Else
MsgBox "There was an error downloading the file"
End If
End Function
Sub DoIt()
DownloadFile "http://www.blahblahblah.com/somefolder/somefiles.xlsx", "C:\Users\Public\Documents\SavedFile.xlsx"
End Sub
I was using sendkey to access Power Query and connect to SharePoint Folder. Everything was smooth until the Power Query Data Preview Dialog appears.
How do I allow sendkey to continue after the dialog appears? I'm using button to start macro and using Excel 2016.
Option Explicit
Sub Button1_Click()
Dim spPath As String
Dim strkeys As String
spPath = "" 'SharePoint Link
strkeys = "%APNFO" & spPath & "{Enter}{TAB 4}{Enter}"
'stops at first{Enter}, {TAB 4}{Enter} for EDIT
Call SendKeys(strkeys)
End Sub
Update
Also tried to sendkey twice with True but same result, Stops at dialog.
Option Explicit
Sub Button1_Click()
Dim spPath As String
Dim strkeys As String
Dim strkeys2 As String
spPath = ""
strkeys = "%APNFO" & spPath & "{Enter}"
strkeys2 = "{TAB 4}{Enter}"
Call SendKeys(Trim(strkeys), True)
Call SendKeys(Trim(strkeys2), True)
Debug.Print strkeys2
End Sub
Update2
I tried what #peh suggested, using sleep() and Application.wait(). I found out that once the macro is initialized, sendkey1 started and stopped by the Application.wait(). Only after the waiting time ends, then sendkey1 is being processed. And once sendkey1 started, sendkey2 also starts.
Also tried adding DoEvents, sendkey1 works perfect. However only after clicking the Cancel button, Application.wait() and sendkey2 will start.
Call SendKeys(Trim(strkeys))
Debug.Print Now & "Send Key 1"
'Do Events
Application.wait (Now + TimeValue("0:00:10"))
Call SendKeys(Trim(strkeys2), True)
Debug.Print Now & "Send Key 2"
Pannel
If the dialogue box is the same every time, or contains a consistent string of text in the caption, you may be able to use it's caption to detect when it appears using this function in a loop with a timer that searches for a reasonable amount of time for the dialogue box:
Private Function GetHandleFromPartialCaption(ByRef lWnd As Long, ByVal sCaption As String) As Boolean
Dim lhWndP As Long
Dim 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 InStr(1, sStr, sCaption) > 0 Then
GetHandleFromPartialCaption = True
lWnd = lhWndP
Exit Do
End If
lhWndP = GetWindow(lhWndP, GW_HWNDNEXT)
Loop
End Function
Where sCaption is the name of your dialogue box. Then in your main body of code use:
If GetHandleFromPartialCaption(lhWndP, "Your Dialogue Box Caption") = True Then
SendKeys(....
I am on my linux box right now so I can't tinker with this to test, but you might attempt to read other properties of the window with a utility like:
https://autohotkey.com/boards/viewtopic.php?t=28220
Edit: if SendKeys absolutely won't work, and you don't want to go the UI automation route, and you don't mind a dependency, you could install AutoHotkey and script that from VBA (e.g. using the Shell() command). AHK is more robust when it comes to keyboard macro automation.
If you had a unique classname, for example, you could use FindWindowEx to get the window handle:
Module-scoped ~
#If VBA7 Then
'32-bit declare
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
#Else
'64-bit declare
Private Declare PtrSafe Function FindWindowEx Lib "USER32" _
Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
#End If
Procedure ~
Dim appcaption as String
appcaption = "Excel"
#If VBA7 Then
Dim parenthandle as Long, childhandle as Long
#Else
Dim parenthandle as LongPtr, childhandle as LongPtr
#End If
parenthandle = FindWindow(vbNullString, appcaption)
If parenthandle Then
childhandle = GetWindow(parenthandle, GW_CHILD)1
Do Until Not childhandle
childhandle = GetWindow(childhandle, GW_HWNDNEXT)
Loop
End If
If childhandle Then
'
End If
This code is only proof of concept, as you could have muliple Excel Windows open, for example. It should give a good starting point, however.
I can manually shorten or lengthen the Name Box (which is just to the left of the Formula Bar) by dragging the "dot" to the right or left. (This also shortens or lengthens the Formula Bar.)
How can I do the adjustment with VBA??
PHEW!!!!
Things that you throw my way!!! :P
When I realized that there are is no native way to achieve what you want, I resorted to the API way but then I was again disappointed because the "Name Box" only exposed WS_CHILDWINDOW, WS_VISIBLE, CBS_DROPDOWN, CBSAUTOHSCROLL and CBS_HASSTRINGS. The "Dot" doesn't even have a handle.
Out of frustration, I started thinking along the lines of what Mark proposed in his answer. The Registry way. It took me some 20 odd mins to find the Registry key. But Alas, that joy also didn't last long when I realized that changing the registry key didn't have any effect till I restarted Excel.
After this there was only one way left Simulation of the mouse. I would have smashed my laptop on the ground if that didn't work!.
I tried with some hardcoded values in the beginning and was happy with the results. So here is the final version...
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 SetCursorPos Lib "user32" _
(ByVal X As Integer, ByVal Y As Integer) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Sub mouse_event Lib "user32.dll" (ByVal dwFlags As Long, _
ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down
Private Const MOUSEEVENTF_LEFTUP = &H4 ' left button up
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Dim pos As RECT
Sub Sample()
Dim hwndExcel As Long
Dim hwndPanel As Long
Dim hwndCombo As Long
Dim dest_x As Long
Dim dest_y As Long
Dim cur_x As Long
Dim cur_y As Long
Dim Position As POINTAPI
'~~> Get the handle of the Excel Window
hwndExcel = FindWindow("XLMAIN", Application.Caption)
If hwndExcel = 0 Then Exit Sub
'MsgBox "Excel Window Found"
'~~> Get the handle of the Panel where the Name Box is
hwndPanel = FindWindowEx(hwndExcel, ByVal 0&, "EXCEL;", vbNullString)
If hwndPanel = 0 Then Exit Sub
'MsgBox "Excel Panel Found"
hwndCombo = FindWindowEx(hwndPanel, ByVal 0&, "Combobox", vbNullString)
If hwndCombo = 0 Then Exit Sub
'MsgBox "Excel Name Box Found"
'~~> Retrieve the dimensions of the bounding rectangle of the
'~~> specified window. The dimensions are given in screen
'~~> coordinates that are relative to the upper-left corner of the screen.
GetWindowRect hwndCombo, pos
'~~> Get the approx location of the DOT. It is where the Combobox ends
cur_x = pos.Right
cur_y = pos.Top + 10
'~~> New Destination
dest_x = cur_x + 500 '<~~ Change width here
dest_y = cur_y
'~~> Move the cursor to the specified screen coordinates of the DOT.
SetCursorPos cur_x, cur_y
Wait 1 '<~~ Wait 1 second
'~~> Press the left mouse button on the DOT
mouse_event MOUSEEVENTF_LEFTDOWN, cur_x, cur_y, 0, 0
'~> Set the new destination. Take cursor there
SetCursorPos dest_x, dest_y
'~~> Press the left mouse button again to release it
mouse_event MOUSEEVENTF_LEFTUP, dest_x, dest_y, 0, 0
Wait 1
MsgBox "done"
End Sub
Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
DoEvents
Wend
End Sub
Instructions
Paste this code in a module and then from the sheet press ALT+F8 and then select Sample and press ALT+R
Tested in Excel 2010
Before
After
As there isn't a NameBox object within VBA Excel.Application I don't think it's possible in native VBA.
You'd have to delve into REGISTRY. The registry key is
Note: Even if you set the value, for it to take effect, you will have to close and open Excel.
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.