Option Explicit
Private Type GUID
lData1 As Long
iData2 As Integer
iData3 As Integer
aBData4(0 To 7) As Byte
End Type
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 Sub AccessibleObjectFromWindow Lib "OLEACC.DLL" _
(ByVal hwnd As Long, ByVal dwId As Long, riid As GUID, ppvObject As Any)
Private Const OBJID_NATIVEOM = &HFFFFFFF0
Private Sub SetIDispatch(ByRef ID As GUID)
' IDispatch Interface.
' {00020400-0000-0000-C000-000000000046}.
With ID
.lData1 = &H20400
.iData2 = &H0
.iData3 = &H0
.aBData4(0) = &HC0
.aBData4(1) = &H0
.aBData4(2) = &H0
.aBData4(3) = &H0
.aBData4(4) = &H0
.aBData4(5) = &H0
.aBData4(6) = &H0
.aBData4(7) = &H46
End With
End Sub
Public Function ApplicationFromHwnd() As Application
Dim IDispatch As GUID
Dim oWB As Object
Dim lXLhwnd As Long
Dim lXLDESKhwnd As Long
Dim lWBhwnd As Long
Do
lXLhwnd = FindWindowEx(0, lXLhwnd, "XLMAIN", vbNullString)
If lXLhwnd = 0 Then
Exit Do
ElseIf lXLhwnd <> Application.hwnd Then
lXLDESKhwnd = FindWindowEx(lXLhwnd, 0&, "XLDESK", vbNullString)
lWBhwnd = FindWindowEx(lXLDESKhwnd, 0&, "EXCEL7", vbNullString)
If lWBhwnd Then
SetIDispatch IDispatch
Call AccessibleObjectFromWindow _
(lWBhwnd, OBJID_NATIVEOM, IDispatch, oWB)
Set ApplicationFromHwnd = oWB.Application
Exit Do
End If
End If
Loop
Set oWB = Nothing
End Function
Private Function MonBureau$()
Dim WshShell As Object
Set WshShell = CreateObject("WScript.Shell")
MonBureau = WshShell.SpecialFolders.Item(4) & "\"
Set WshShell = Nothing
End Function
Sub enregistrer_classeurX()
'Rem pour faire un test, _
décommenter la commande suivante pour créer un fichier vide :
'Shell "excel.exe"
Static i%
Dim oXLApp As Object, Filename$
i = i + 1
Filename$ = MonBureau & "MonClasseur" & i & ".xlsx"
Set oXLApp = ApplicationFromHwnd()
With oXLApp
.ActiveWorkbook.SaveAs (Filename)
.Quit
End With
End Sub