Related
I have been struggling with this question for quite some time now.
I have a userform that is called from an Excel add-in I've built which then tests whether the current active workbook contains a specific structure. If not, it creates a new workbook with that exact structure. I set this workbook as well as another workbook that I open as wb1 and wb2.
The issue is that the userform is initially called from the activeworkbook (could be any workbook) at the time of clicking the ribbon button and basically latches onto THAT workbook alone.
Is there any way I could detach the userform from that workbook and change it to show my wb2 in the background of my userform?
I have tried the following code, but it just closes my userform and doesn't work.
Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal clsName As String, ByVal wndName As String) As Long
Private Declare PtrSafe Function SetParent Lib "user32" (ByVal hChild As Long, ByVal hParent As Long) As Long
Private Sub CommandButton1_Click()
Static h As Long
If h <= 0 Then h = FindWindow("ThunderDFrame", Me.Caption)
If h <= 0 Then Exit Sub
Dim wb As Workbook: Set wb = Workbooks.Add
SetParent h, Application.Windows(wb.Name).Hwnd
wb.Activate
End Sub
Any ideas?
Here is my code from my Addin to show all sheets in all opened workbooks in one modeless userform and activating (by dblcick) choosen one. Calling: Call ShowModeless
Class WinActivate in Addin file
' Class WinActivate
Public WithEvents AppEvents As Application
Private Declare PtrSafe Function SetParent Lib "user32" _
(ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
Private Sub AppEvents_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
'Change precedent object of UserForm for new created windows
If Val(Application.Version) >= 15 Then SetParent UserFormHandle, Wn.hWnd
End Sub
Module1 in Addin file
'Module1 code
Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Dim WA As New WinActivate
Public UserFormHandle As Long
' DajArkusze is my Userform in Addin file
Sub ShowModeless()
Set WA.AppEvents = Application
DajArkusze.Show 0
UserFormHandle = FindWindow("ThunderDFrame", DajArkusze.Caption)
End Sub
I had to solve a similar problem with Forms opening on the wrong workbook when multiple screens are involved.
It turns out you can change which workbook "owns" a form by unloading the form then reloading it.
Change:
MyWorkbook.Activate
Load MyForm
MyForm.Show
To:
MyWorkbook.Activate
Unload MyForm
Load MyForm
MyForm.Show
I've got a modeless userform in an Excel VBA project.
The userform is loaded by button on spreadsheet clicked (not an active-x button if that's relevant).
Because of modeless the user can work with excel or even other applications and than switch back to the form window. I need an event that fires if the form window becomes the active window again. I thought UserForm_Activate should do the job but it doesn't (neither does UserForm_GotFocus but there is no GotFocus event for userforms?). Is there any event that fires if the user switches back to a modeless userform (or in case not: is there any known work-around)? Or do I've got some strange bug here and Activate should fire?
Here's all the code I used for testing purpose:
' standard module:
Sub BUTTON_FormLoad()
' associated as macro triggered by button click on a sheet
UserForm1.Show vbModeless
End Sub
' UserForm1:
Private Sub UserForm_Activate()
' does not fire if focus comes back
Debug.Print "Activated"
End Sub
Private Sub UserForm_GotFocus()
' does not fire if focus comes back
' wrong code - no GotFocus event for userforms?
Debug.Print "Focussed"
End Sub
Private Sub UserForm_Click()
' only fires if clicked *inside* form
' does not fire eg if user clicks top of form window
Debug.Print "Clicked"
End Sub
Where do I find the documentation of userform events? It's not on the 'UserForm object' page.
The Activate event doesn't fire when you switch between the application and a modeless userform. This is by design.
Like I mentioned in the comments
You can achieve what you want by subclassing the userform and trapping the worksheet events but it very messy.
Here is a very basic example. Sample file can be downloaded from Here
READ ME FIRST:
This is just a basic sample. Please close all Excel Files before testing this.
If the user directly clicks a control on the userform and you want to run the activate code there as well then you will have to handle that as well.
Once you are happy, amend it to suit your need.
Place code in a Module
Option Explicit
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowLong& Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long)
Private Const GWL_WNDPROC = (-4)
Private WinProcOld As Long
Private Const WM_NCLBUTTONDOWN = &HA1
Public formWasDeactivated As Boolean
'~~> Launch the form
Sub LaunchMyForm()
Dim frm As New UserForm1
frm.Show vbModeless
End Sub
'~~> Hooking the Title bar in case user clicks on the title bar
'~~> to activate the form
Public Function WinProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If wMsg = WM_NCLBUTTONDOWN Then
'~~> Ignoring unnecessary clicks to the title bar
'~~> by checking if the form was deactivated
If formWasDeactivated = True Then
formWasDeactivated = False
MsgBox "Form Activated"
End If
End If
WinProc = CallWindowProc(WinProcOld&, hwnd&, wMsg&, wParam&, lParam&)
End Function
'~~> Subclass the form
Sub SubClassUserform(hwnd As Long)
WinProcOld& = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WinProc)
End Sub
Sub UnSubClassUserform(hwnd As Long)
SetWindowLong hwnd, GWL_WNDPROC, WinProcOld&
WinProcOld& = 0
End Sub
Create a Userform. Let's call it Userform1. Add a command button in the form. Let's call it CommandButton1
Place code in Userform
Option Explicit
Private Declare Function FindWindow Lib "user32.dll" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Dim hwnd As Long
Private Sub UserForm_Initialize()
hwnd = FindWindow(vbNullString, Me.Caption)
SubClassUserform hwnd
End Sub
'~~> Userform Click event
Private Sub UserForm_Click()
'~~> Ignoring unnecessary clicks
'~~> by checking if the form was deactivated
If formWasDeactivated = True Then
formWasDeactivated = False
MsgBox "Form Activated"
End If
End Sub
'~~> Unload the form
Private Sub CommandButton1_Click()
'~~> In case hwnd gets reset for whatever reason.
hwnd = FindWindow(vbNullString, Me.Caption)
UnSubClassUserform hwnd
Unload Me
End Sub
Place this code in the Workbook code area
Option Explicit
'~~> Checking if the form was deactivated
'~~> Add more events if you want
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
formWasDeactivated = True
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
formWasDeactivated = True
End Sub
Please feel free to add more workbook events. I have only used Workbook_SheetActivate and Workbook_SheetSelectionChange
And finally add a Form Button in the worksheet and assign the macro LaunchMyForm to it. And we are done
In Action
As far as I know, there isn't such an event within VBA. From the documentation:
The Activate and Deactivate events occur only when you move the focus
within an application. Moving the focus to or from an object in
another application doesn't trigger either event.
However, the Windows APIs can handle the event with a hook. The problem with Win APIs within VBA is that errors aren't handled by VBA so Excel will crash if/when the code encounters an error; so they can be frustrating for the developer. From a purely personal perspective, I like to keep code within the hook procedures to a minimum and pass any values to a class that can then fire events - this at least minimises the crashes. It's also important to remember to unhook before finishing your session.
Basic implementation of a Win API hook would look something like this:
In a class object (here it's called cHookHandler)
Option Explicit
Public Event HookWindowActivated()
Public Event HookIdChanged()
Private mHookId As LongPtr
Private mTargetWindows As Collection
Public Property Get HookID() As LongPtr
HookID = mHookId
End Property
Public Property Let HookID(RHS As LongPtr)
mHookId = RHS
RaiseEvent HookIdChanged
End Property
Public Sub AttachHook()
modHook.AttachHook Me
End Sub
Public Sub DetachHook()
modHook.DetachHook
End Sub
Public Sub AddTargetWindow(className As String, Optional windowTitle As String)
Dim v(1) As String
'Creates an array of [0 => className, 1=> windowTitle]
'which is stored in a collection and tested for in
'your hook callback.
v(0) = className
v(1) = windowTitle
mTargetWindows.Add v
End Sub
Public Sub TestForTargetWindowActivated(className As String, windowTitle As String)
Dim v As Variant
'Tests if the callback window is one that we're after.
For Each v In mTargetWindows
If v(0) = className Then
If v(1) = "" Or v(1) = windowTitle Then
'Fires the event that our target window has been activated.
RaiseEvent HookWindowActivated
Exit Sub
End If
End If
Next
End Sub
Private Sub Class_Initialize()
Set mTargetWindows = New Collection
End Sub
Private Sub Class_Terminate()
modHook.DetachHook
End Sub
Module code (here the module is called modHook)
Option Explicit
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" _
(ByVal hHook As LongPtr, _
ByVal ncode As Long, _
ByVal wParam As LongPtr, _
lParam As Any) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As LongPtr, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" _
(ByVal hwnd As LongPtr, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private mHookHandler As cHookHandler
Public Sub AttachHook(hookHandler As cHookHandler)
Set mHookHandler = hookHandler
mHookHandler.HookID = SetWindowsHookEx(WH_CBT, AddressOf CBTCallback, 0, GetCurrentThreadId)
End Sub
Private Function CBTCallback(ByVal lMsg As Long, _
ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As LongPtr
Dim className As String, windowTitle As String
If mHookHandler Is Nothing Then Exit Function
If lMsg = HCBT_ACTIVATE Then
className = GetClassText(wParam)
windowTitle = GetWindowTitle(wParam)
If Not mHookHandler Is Nothing Then
mHookHandler.TestForTargetWindowActivated className, windowTitle
End If
End If
CBTCallback = CallNextHookEx(mHookHandler.HookID, lMsg, ByVal wParam, ByVal lParam)
End Function
Public Sub DetachHook()
Dim ret As Long
If mHookHandler Is Nothing Then Exit Sub
ret = UnhookWindowsHookEx(mHookHandler.HookID)
If ret = 1 Then
mHookHandler.HookID = 0
End If
End Sub
Private Function GetWindowTitle(wParam As LongPtr) As String
Dim tWnd As String
Dim lWnd As Long
tWnd = String(100, Chr(0))
lWnd = GetWindowText(wParam, tWnd, 100)
tWnd = Left(tWnd, lWnd)
GetWindowTitle = tWnd
End Function
Private Function GetClassText(wParam As LongPtr) As String
Dim tWnd As String
Dim lWnd As Long
tWnd = String(100, Chr(0))
lWnd = GetClassName(wParam, tWnd, 100)
tWnd = Left(tWnd, lWnd)
GetClassText = tWnd
End Function
And in this example, all events are captured within the Userform
In this simple example, two buttons on the Userform attach and detach the hook, but you'd probably call the routines from somewhere else (perhaps the userform Initialize and Terminate events). The Userform also has a label lblHook displaying the HookId which I use during development - for production code, you probably wouldn't want this, so you could leave that bit out.
Option Explicit
Private WithEvents mHookHandler As cHookHandler
Private Sub btnHook_Click()
mHookHandler.AttachHook
End Sub
Private Sub btnUnhook_Click()
mHookHandler.DetachHook
End Sub
Private Sub mHookHandler_HookIdChanged()
lblHook.Caption = mHookHandler.HookID
End Sub
Private Sub mHookHandler_HookWindowActivated()
' Caveat: this routine will crash if halted in debugger.
Debug.Print "I've been activated!"
End Sub
Private Sub UserForm_Initialize()
Set mHookHandler = New cHookHandler
mHookHandler.AddTargetWindow "ThunderDFrame", Me.Caption
End Sub
Private Sub UserForm_Terminate()
Set mHookHandler = Nothing
End Sub
Try this. the event occurs after the form appears, so hide the wb inside an initialize event.
Private Sub UserForm_Initialize()
Set WB = ThisWorkbook Windows(WB.Name).Visible = False
The event does not exist and you can use Windows hooks to achieve your desired result. In my opinion, that's the direct answer and everything else is a workaround [unless it was posted by Siddharth Rout, in which case, THAT is the direct answer]
I wrote 2 subs to automate a daily task.
First sub MatriksFlowUpdate calls 2 other subs RightClick and SingleClick to simulate a right click and then a left click on a certain part of the screen. This is done in order to prompt another program to create an Excel file and save it under C:. This sub works correctly on its own (i.e. it simulates a right click and a left click at the desired locations on the screen, prompting another program to produce an Excel sheet)
Second sub CloseInstance finds the Excel sheet created above, and closes it. This sub also works correctly on its own.
However, when I try to call these 2 subs one after the other in another sub MainSequence, I get an error saying the Excel that should be found and closed by the second sub can't be found. So I get an error on the CloseInstance sub at the location below
Set xlApp =GetObject("C:\MATRIKS\USER\REPORTS\EXCEL\Temp.xls").Application
I've tried many things to fix this, but I feel like I am going around in circles for the past few days. Any help would be much much appreciated.
P.S. My first time posting a q on stackoverflow so please bear with me with the formatting.
Public Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Sub MainSequence()
'This sub pieces together MatriksFlowUpdate and CloseInstance
Call MatriksFlowUpdate
Sleep 2000
Call CloseInstance
End Sub
Sub MatriksFlowUpdate()
'Prompts 3rd party software (Matriks) to produce Excel with latest flow data
Call RightClick
Call SingleClick
End Sub
Private Sub RightClick()
'Simulates a mouse right click at desired screen coordinates
Sleep 1000
SetCursorPos 1750, 750 'x and y position
mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
End Sub
Private Sub SingleClick()
'Simulates a mouse left click at desired screen coordinates
Sleep 1000
SetCursorPos 1750, 650 'x and y position
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
Sub CloseInstance()
'Finds the instance of Excel where Matriks exported its excel and closes that instance of Excel
Dim xlApp As Excel.Application
Dim WB As Workbook
Set xlApp =GetObject("C:\MATRIKS\USER\REPORTS\EXCEL\Temp.xls").Application
Set WB = xlApp.Workbooks("Temp.xls")
WB.Close
End Sub
Thanks to all your help, I was able to solve the problem as below:
as per DisplayName's suggestion, this was an Excel freeze issue when Sleep function was called. When Sleep function was called, Excel froze and blocked the 3rd party program from creating its own Excel instance.
I built on this idea and created a new function called WasteTime and added it to my code. I am using this function instead of Sleep in the code, thereby bypassing the Excel freeze problem.
Full code below now.
Please note that WasteTime sub was found on myonlinetraininghub.com
Public Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Sub MainSequence()
'This sub pieces together MatriksFlowUpdate and CloseInstance
Call MatriksFlowUpdate
WasteTime(2) #This is the code change, it was Sleep 2000 before
Call CloseInstance
End Sub
Sub MatriksFlowUpdate()
'Prompts 3rd party software (Matriks) to produce Excel with latest flow data
Call RightClick
Call SingleClick
End Sub
Private Sub RightClick()
'Simulates a mouse right click at desired screen coordinates
Sleep 1000
SetCursorPos 1750, 750 'x and y position
mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
End Sub
Private Sub SingleClick()
'Simulates a mouse left click at desired screen coordinates
Sleep 1000
SetCursorPos 1750, 650 'x and y position
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
Sub CloseInstance()
'Finds the instance of Excel where Matriks exported its excel and closes that instance of Excel
Dim xlApp As Excel.Application
Dim WB As Workbook
Set xlApp =GetObject("C:\MATRIKS\USER\REPORTS\EXCEL\Temp.xls").Application
Set WB = xlApp.Workbooks("Temp.xls")
WB.Close
End Sub
Sub WasteTime(Finish As Long) #This is what I use instead of Sleep
Dim NowTick As Long
Dim EndTick As Long
EndTick = GetTickCount + (Finish * 1000)
Do
NowTick = GetTickCount
DoEvents
Loop Until NowTick >= EndTick
End Sub
Maybe try something like that
Sub CloseInstance()
Dim WB As Workbook
Set WB = Application.Workbooks("Temp.xls")
If Not WB Is Nothing Then
WB.Close
End If
End Sub
Or try this to open
Sub test()
IsWorkBookOpen ("C:\MATRIKS\USER\REPORTS\EXCEL\Temp.xls")
End Sub
Sub IsWorkBookOpen(ByVal fullFileName)
Dim wBook As Workbook
If FileExists(fullFileName) Then
On Error Resume Next
'Test to see if a Workbook is open.
Set wBook = Workbooks(Dir(fullFileName))
If wBook Is Nothing Then 'Not open
Workbooks.Open (fullFileName)
Set wBook = Nothing
On Error GoTo 0
Else 'It is open
MsgBox "Yes it is open", vbInformation, "Founded"
Set wBook = Nothing
On Error GoTo 0
End If
Else
MsgBox "File does not exists"
End If
End Sub
Function FileExists(ByVal fullFileName) As Boolean
FileExists = VBA.Len(VBA.Dir(fullFileName)) > 0
End Function
should it be a timing issue you could keep on trying and getting the Excel application until it's found (not tested):
Sub CloseInstance()
'Finds the instance of Excel where Matriks exported its excel and closes that instance of Excel
Dim xlApp As Excel.Application
On Error Resume Next
Do
Set xlApp = GetObject("C:\MATRIKS\USER\REPORTS\EXCEL\Temp.xls").Application
DoEvents
Loop While xlApp Is Nothing
xlApp.Workbooks("Temp.xls").Close
End Sub
I created a small program using the following code to transfer a picture from one sheet to another in the same workbook.
Sub transferPicturesPAPER_EXAM(pictureNo As Long, p As Integer, srcSht As String, dstSht As String, insertWhere As String)
' Transfers the selected Picture to the exam sheet.
''zxx
If pictureNo = 0 Then Exit Sub
Sheets(srcSht).Select
ActiveSheet.Unprotect
ActiveSheet.pictures("Picture " & pictureNo).Select
'ActiveSheet.Shapes.Range(Array("Picture " & pictureNo)).Select
Selection.Copy
Sheets(dstSht).Select
Range(insertWhere).Select
ActiveSheet.Paste
'== rename to correspond to the problem number
Selection.Name = "Picture " & p
End Sub
This works fine. However, when I place the routine in a larger workbook, I get the following error at the line: Activesheet.paste:
Paste method of Worksheet class failed
The code worked fine for several program executions.
Any help would be greatly appreciated.
Try this :
Sub transferPicturesPAPER_EXAM(pictureNo As Long, _
p As Integer, srcSht As String, _
dstSht As String, insertWhere As String)
' Transfers the selected Picture to the exam sheet.
''zxx
Dim pic As Picture
If pictureNo = 0 Then Exit Sub
Application.EnableEvents = False
Sheets(srcSht).Unprotect
Set pic = Sheets(srcSht).Pictures("Picture " & pictureNo)
pic.Copy
Sheets(dstSht).Activate
Sheets(dstSht).Range(insertWhere).Select
Sheets(dstSht).Paste
'== rename to correspond to the problem number
Selection.Name = "Picture " & p
Application.EnableEvents = True
End Sub
Try this one :
Sub transferPicturesPAPER_EXAM(pictureNo As Long, p As Integer, srcSht As String, dstSht As String, insertWhere As String)
' Transfers the selected Picture to the exam sheet.
''zxx
Dim shpPictureToCopyAs Shape
If pictureNo = 0 Then Exit Sub
With Sheets(srcSht)
.Unprotect
Set shpPictureToCopy= .Shapes(pictureNo).Duplicate
shpPictureToCopy.Cut
End With
Sheets(dstSht).Range(insertWhere).PasteSpecial (xlPasteAll)
End Sub
I recommend disabling and enabling events and screen updating in the main procedure, from which this one has been called. Otherwise you can enable them when you dont want to. Something like this :
Sub MainProcedure() 'your sub name
Application.EnableEvents = False
Application.ScreenUpdating = False
Call transferPicturesPAPER_EXAM(1, 1, "Sheet1", "Sheet2", "A20") 'with your variables as arguments of course
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I often had this problem too. But you cannot wait 3 seconds per picture , it's too long. I work on 1000 pictures, it's gonna take for ever.
The core of the problem is that Excel copies to windows clipboard first, which is slow.
If you try to paste before the clipboard has the Pic , its will error.
So, some small steps needed for mass copying:
Clear clipbard (not always needed but it makes sure you are not working on older data)
Copy Pic
Test if Pic is in the Clipboard and wait until it is there (loop)
Paste
Here is the code (for Excel 64 bits) :
Option Explicit
'Does the clipboard contain a bitmap/metafile?
Public Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal Hwnd As LongPtr) As Long
'clear clipboard
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
'Get a pointer to the bitmap/metafile
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr 'wformat as long ?
'Close the clipboard
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
'for waiting
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Clear_Clipboard()
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
Application.CutCopyMode = False
End Sub
Sub PastePic(Pic As Shape)
Dim Rg As Range
Dim T#
Dim Ligne&: Ligne = 5
Dim Sh_Vendeur As Worksheet
Set Sh_Vendeur = ThisWorkbook.Sheets(1)
Clear_Clipboard
Pic.Copy
Set Rg = Sh_Vendeur.Cells(Ligne, 2)
'wait until the clipboard gets a pic, but not over 3 seconds (avoid infinite loop)
T = Timer
Do
Waiting (2)
Loop Until Is_Pic_in_Clipboard Or Timer - T > 0.3
'Rg.Select
'Rg.PasteSpecial
Sh_Vendeur.Paste Destination:=Rg 'paste to a range without select
End Sub
Sub Waiting(ByVal Mili_Seconds&)
Sleep Mili_Seconds
End Sub
Function Is_Pic_in_Clipboard() As Boolean
If IsClipboardFormatAvailable(2) <> 0 Or IsClipboardFormatAvailable(14) <> 0 Then Is_Pic_in_Clipboard = True '2-14 =bitmap et Picture JPEG
End Function
The time delay produced weird results. In some instants some of the pictures were pasted and in others they weren't. Very inconsistent results.
Relocated the Application.wait ... code at the very beginning of the subroutine - ran the program several times - worked perfectly
Would never have guessed that solution.
Thanks to everyone who suggested a solution.
I had success by using the command "DoEvents" just after copying the picture. This way I do not get error when using Paste, otherwise I do.
I can see the WindowActivate events firing, at various levels, when I switch between windows within excel, but is there a way to fire an event when excel becomes the foreground application? If I click out of excel and work, for example in the browser for a while and then click back onto an excel window, I don't see any events firing. Is there any way to detect this?
I would like to refresh some elements of my VBA application because, occasionally, I find that my Mouse Over feature, based on Hypertext Function, loses its ability to Activate charts. I can fix it by un-protecting and protecting the worksheet, or by trashing and re-initialising a subset of my objects. I would like trigger this action on the event that I am looking for.
I can also do this by SendKeys but it's not nice because it wipes out the keyboard settings (e.g. scroll lock) due to a documented bug in SendKeys and it makes the screen flicker more than I would like.
Since the code will reside in VBA I would limit the action to a particular workbook. If a different (passive) workbook is active when entering the Excel instance Window, then no action would be triggered and I can use the WorkbookActivate event to refresh the application if and when the user selects the workbook containing it.
I believe this is not provided in Excel directly, so use the Windows API. You can do win32 programming in VBA!
Explanation
You can use the win32 api function SetWinEventHook to get Windows to report certain events to you. Including EVENT_SYSTEM_FOREGROUND which is triggered when the foreground window changes. In the below example I check the new foreground window's process id against Excel's process id. This is a simple way to do it, but it will detect other Excel windows such as the VBA window the same as the main Excel window. This may or may not be the behavior you want and can be changed accordingly.
You have to be careful using SetWinEventHook, as that you pass a callback function to it. You are limited in what you can do in this callback function, it exists outside of VBA's normal execution and any errors inside it will cause Excel to crash in a messy unrecoverable way.
That's why I use Application.OnTime to report the events. They aren't gaurenteed to occur in order if multiple events are triggered more rapidly than Excel and VBA update. But it's safer. You could also update a collection or array of events, then read those back seperately outside of the WinEventFunc callback.
Example Code
To test this, create a new module and paste this code into it. Then run StartHook. Remember to run StopAllEventHooks before closing Excel or modifying the code!! In production code you'd probably add StartEventHook and StopAllEventHooks to the WorkBook_Open and WorkBook_BeforeClose events to ensure they get run at the appropriate times. Remember, if something happens to the WinEventFunc VBA code before the hook is stopped Excel will crash. This includes the code being modified or the workbook it is housed in being closed. Also do not press the stop button in VBA while a hook is active. The stop button can wipe the current program state!
Option Explicit
Private Const EVENT_SYSTEM_FOREGROUND = &H3&
Private Const WINEVENT_OUTOFCONTEXT = 0
Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, ByVal eventMax As Long, _
ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, _
ByVal idThread As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private pRunningHandles As Collection
Public Function StartEventHook() As Long
If pRunningHandles Is Nothing Then Set pRunningHandles = New Collection
StartEventHook = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0&, AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
pRunningHandles.Add StartEventHook
End Function
Public Sub StopEventHook(lHook As Long)
Dim LRet As Long
If lHook = 0 Then Exit Sub
LRet = UnhookWinEvent(lHook)
End Sub
Public Sub StartHook()
StartEventHook
End Sub
Public Sub StopAllEventHooks()
Dim vHook As Variant, lHook As Long
For Each vHook In pRunningHandles
lHook = vHook
StopEventHook lHook
Next vHook
End Sub
Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, _
ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
'This function is a callback passed to the win32 api
'We CANNOT throw an error or break. Bad things will happen.
On Error Resume Next
Dim thePID As Long
If LEvent = EVENT_SYSTEM_FOREGROUND Then
GetWindowThreadProcessId hWnd, thePID
If thePID = GetCurrentProcessId Then
Application.OnTime Now, "Event_GotFocus"
Else
Application.OnTime Now, "Event_LostFocus"
End If
End If
On Error GoTo 0
End Function
Public Sub Event_GotFocus()
Sheet1.[A1] = "Got Focus"
End Sub
Public Sub Event_LostFocus()
Sheet1.[A1] = "Nope"
End Sub
I modified #AndASM 's very nice solution to work in a 64 bit environment. Changes were
changed API function call parameters from Long to LongLong parameters
included PtrSafe attributes
replaced Sheet1.[A1] = with range("a1").value = syntax
#andasm's code with mods follows
Option Explicit
Private Const EVENT_SYSTEM_FOREGROUND = &H3&
Private Const WINEVENT_OUTOFCONTEXT = 0
Private Declare PtrSafe Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, _
ByVal eventMax As Long, _
ByVal hmodWinEventProc As LongLong, _
ByVal pfnWinEventProc As LongLong, _
ByVal idProcess As Long, _
ByVal idThread As Long, _
ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private pRunningHandles As Collection
Public Function StartEventHook() As Long
If pRunningHandles Is Nothing Then Set pRunningHandles = New Collection
StartEventHook = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0&, AddressOf WinEventFunc, 0, 0, WINEVENT_OUTOFCONTEXT)
pRunningHandles.Add StartEventHook
End Function
Public Sub StopEventHook(lHook As Long)
Dim LRet As Long
If lHook = 0 Then Exit Sub
LRet = UnhookWinEvent(lHook)
End Sub
Public Sub StartHook()
StartEventHook
End Sub
Public Sub StopAllEventHooks()
Dim vHook As Variant, lHook As Long
For Each vHook In pRunningHandles
lHook = vHook
StopEventHook lHook
Next vHook
End Sub
Public Function WinEventFunc(ByVal HookHandle As Long, ByVal LEvent As Long, _
ByVal hWnd As Long, ByVal idObject As Long, ByVal idChild As Long, _
ByVal idEventThread As Long, ByVal dwmsEventTime As Long) As Long
'This function is a callback passed to the win32 api
'We CANNOT throw an error or break. Bad things will happen.
On Error Resume Next
Dim thePID As Long
If LEvent = EVENT_SYSTEM_FOREGROUND Then
GetWindowThreadProcessId hWnd, thePID
If thePID = GetCurrentProcessId Then
Application.OnTime Now, "Event_GotFocus"
Else
Application.OnTime Now, "Event_LostFocus"
End If
End If
On Error GoTo 0
End Function
Public Sub Event_GotFocus()
Range("a1").Value = "Got Focus"
End Sub
Public Sub Event_LostFocus()
Range("a1").Value = "Nope"
End Sub