I am trying to find out if excel is running, because after i am done creating excel files I need to know if I should close down excel or not.
My method is working fine for me, but it fails on another user and I have no idea why it is failing. My bet would be that the while loop runs forever. So should I add a counter to avoid this or is there a better way to find out if excel is running?
Function ListWins(Optional title = "*", Optional Class = "*") As Boolean
Dim hWndThis As Long
ListWins = True
hWndThis = FindWindow(vbNullString, vbNullString)
While hWndThis
Dim sTitle As String, sClass As String
sTitle = Space$(255)
sTitle = Left$(sTitle, GetWindowText(hWndThis, sTitle, Len(sTitle)))
sClass = Space$(255)
sClass = Left$(sClass, GetClassName(hWndThis, sClass, Len(sClass)))
If sTitle Like title And sClass Like Class Then
ListWins = False
Debug.Print sTitle, sClass
End If
hWndThis = GetWindow(hWndThis, GW_HWNDNEXT)
Wend
End Function
So here is the new function that works for me:
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Function ExcelOpen() As Boolean
ExcelOpen = FindWindow("XLMAIN", vbNullString)
End Function
Related
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 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 want to detect currently opened swf file name. Here is my code:
Private Const GW_HWNDNEXT = 2
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Sub Form_Load()
ListWins "*.swf*"
End Sub
Sub ListWins(Optional Title = "*", Optional Class = "*")
Dim hWndThis As Long
hWndThis = FindWindow(vbNullString, vbNullString)
While hWndThis
Dim sTitle As String, sClass As String
sTitle = Space$(255)
sTitle = Left$(sTitle, GetWindowText(hWndThis, sTitle, Len(sTitle)))
sClass = Space$(255)
sClass = Left$(sClass, GetClassName(hWndThis, sClass, Len(sClass)))
If sTitle Like Title And sClass Like Class Then
Debug.Print sTitle, sClass
List1.AddItem (sTitle)
End If
hWndThis = GetWindow(hWndThis, GW_HWNDNEXT)
Wend
End Sub
This code is working fine to detect *.doc, *.xls files name, but not working on *.swf files.
NOTE
I have tested it in VBA. I am sure it will work in VB6 as well.
Try this (Paste this code in a module and run the Sub Sample)
Private Declare Function GetWindowTextLength Lib "user32" Alias _
"GetWindowTextLengthA" (ByVal HWnd As Long) 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 GetDesktopWindow Lib "user32" () As Long
Public Declare Function EnumChildWindows Lib "user32" _
(ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Public Function APIWindowCaption(ByVal HWnd As Long, ByVal lParam As Long) As Long
Static winnum As Integer
Dim MyStr As String
winnum = winnum + 1
MyStr = String(GetWindowTextLength(HWnd) + 1, Chr$(0))
GetWindowText HWnd, MyStr, Len(MyStr)
'~~> This will give you the caption of the window
If InStr(1, MyStr, ".swf", vbTextCompare) Then Debug.Print MyStr
APIWindowCaption = 1
End Function
Sub Sample()
Dim retval As Long, DesktophWnd As Long
DesktophWnd = GetDesktopWindow
retval = EnumChildWindows(DesktophWnd, AddressOf APIWindowCaption, ByVal 0&)
End Sub
SNAPSHOT
I am using the ROT to find any active MSWord instances. In some versions of word the document does not get registered in the table, instead it is registered as the NORMAL template and so I can not find the document by it's title as documented by microsoft. Anyone know of a hotfix for this?
Is FindWindowPartial API any use to you? It will allow you to search for windows with Microsoft Word in the title.
Option Explicit
Private Const GW_HWNDNEXT = 2
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
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
Function FindWindowPartial(ByVal Title As String) As String
Dim hWndThis As Long
hWndThis = FindWindow(vbNullString, vbNullString)
While hWndThis
Dim sTitle As String, sClass As String
sTitle = Space$(255)
sTitle = Left$(sTitle, GetWindowText(hWndThis, sTitle, Len(sTitle)))
If InStr(sTitle, Title) > 0 Then
FindWindowPartial = sTitle & "|" & FindWindowPartial
End If
hWndThis = GetWindow(hWndThis, GW_HWNDNEXT)
Wend
End Function