麻辣家族討論版版 - Powered by Discuz! Board

debug.print workbooks.count

複製代碼

Sub ex()
Dim oXL As Excel.Application
Dim oWB As Excel.Workbook
Set oXL = GetObject(, "Excel.Application")
For Each oWB In oXL.Workbooks
Debug.Print oWB.Name
Next
End Sub

複製代碼

Option Explicit
Private 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
Private Declare PtrSafe Function GetDesktopWindow Lib "user32.dll" () As Long
Sub GetXLhWnds() '資料：http://www.pcreview.co.uk/threads/getobject-when-more-than-1-excel-is-running.3575757/
Dim n As Long
Dim hWndXL As Long
Do
hWndXL = FindWindowEx(GetDesktopWindow, hWndXL, "XLMAIN", vbNullString)
If hWndXL Then
n = n + 1
End If
Loop Until hWndXL = 0
Debug.Print "獨立EXCEL有：" & n &"個"
End Sub

複製代碼

Option Explicit
Private 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
Private Declare PtrSafe Function GetDesktopWindow Lib "user32.dll" () As Long
Sub test()
Dim i As Long
Dim arrXLhWnd() As Long
If GetXLhWnds(arrXLhWnd) Then
For i = LBound(arrXLhWnd) To UBound(arrXLhWnd)
Debug.Print arrXLhWnd(i)
Next
End If
End Sub
Function GetXLhWnds(arrXLhWnd() As Long) As Long
Dim n As Long
Dim hWndXL As Long, hWndDT As Long
ReDim arrXLhWnd(1 To 100) ' cater for 100 potential Excelinstances
hWndDT = GetDesktopWindow
Do
hWndXL = FindWindowEx(hWndDT, hWndXL, "XLMAIN", vbNullString)
If hWndXL Then
n = n + 1
arrXLhWnd(n) = hWndXL
End If
Loop Until hWndXL = 0

複製代碼

Option Explicit
Option Base 1
#If Win64 Then
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
Private Declare PtrSafe Function IIDFromString Lib "ole32" _
(ByVal lpsz As LongPtr, ByRef lpiid As GUID) As LongPtr
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" _
(ByVal hWnd As LongPtr, ByVal dwId As LongPtr, ByRef riid As GUID, _
ByRef ppvObject As Object) As Long
#Else
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 IIDFromString Lib "ole32" _
(ByVal lpsz As Long, ByRef lpiid As GUID) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _
(ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As GUID, _
ByRef ppvObject As Object) As Long
#End If
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Const S_OK As Long = &H0
Private Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Private Const OBJID_NATIVEOM As Long = &HFFFFFFF0
Private Function GetXLapp(hWinXL, xlApp As Object) As Boolean
Dim hWinDesk, hWin7, obj As Object
Dim iid As GUID
Call IIDFromString(StrPtr(IID_IDispatch), iid)
hWinDesk = FindWindowEx(hWinXL, 0&, "XLDESK", vbNullString)
hWin7 = FindWindowEx(hWinDesk, 0&, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hWin7, OBJID_NATIVEOM, iid, obj) = S_OK Then
Set xlApp = obj.Application
GetXLapp = True
End If
End Function
Private Function IsCollectionExists(ByVal oCol As Collection, ByVal vKey As Variant) As Boolean
On Error Resume Next
oCol.Item vKey
IsCollectionExists = (Err.Number = 0)
Err.Clear
On Error GoTo 0
End Function
Public Function GetXLInstanceInfo(ByRef col As Object) As Long
Dim hWndXL, i As Long
Dim xlApp As Object, wb As Object
Set col = Nothing
Set col = New Collection
hWndXL = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
While hWndXL > 0
If GetXLapp(hWndXL, xlApp) Then
For Each wb In xlApp.Workbooks
If Not IsCollectionExists(col, wb.Name) Then
col.Add Array(hWndXL, xlApp, wb.Name, wb.Path), wb.Name
End If
Next
End If
hWndXL = FindWindowEx(0, hWndXL, "XLMAIN", vbNullString)
Wend
GetXLInstanceInfo = col.Count
End Function
Sub Ex()
Dim col As Collection
Dim i As Long
Dim xlApp As Excel.Application, AR As Variant
i = GetXLInstanceInfo(col)
Debug.Print "獨立EXCEL有：" & i & "個"
'測試 : 在所有Excel檔第1個工作表儲存格A1上寫入自己的檔名
For i = 1 To col.Count
AR = col(i) ' AR(1): HWND (視窗控制代碼)
' AR(2): xlApp (Excel檔所屬的父項 Excel.Application)
' AR(3): 檔名
' AR(4): 檔案路徑
Set xlApp = AR(2)
xlApp.Workbooks(AR(3)).Sheets(1).Range("A1").Value = "檔名:" & AR(3)
Next
Set xlApp = Nothing
Set col = Nothing
End Sub

複製代碼

Private Sub Workbook_Deactivate()
msgbox "有切換"
End Sub

複製代碼

Option Explicit
Public xApp As New Class1
Dim NewApp As New Application
Sub Ex()
Set xApp.The_App = NewApp
End Sub

複製代碼

Option Explicit
Dim WithEvents APP As Application
Property Set The_App(P As Object)
Set APP = P ' 將 APP 屬性值設成物件。
With APP
.Visible = True
With .Workbooks.Add
.Sheets(1).[a1] = 5
End With
End With
End Property
Private Sub APP_NewWorkbook(ByVal Wb As Workbook)
MsgBox Wb.Name
End Sub
Private Sub APP_SheetChange(ByVal Sh As Object, ByVal Target As Range)
MsgBox Target.Address(, , , 1, 1)
End Sub

複製代碼

Option Explicit
Dim WithEvents APP As Application
Property Set The_App(P As Object)
Set APP = P ' 將 APP 屬性值設成物件。
With APP
.Visible = True
End With
End Property
Private Sub APP_NewWorkbook(ByVal Wb As Workbook)
MsgBox Wb.Name
End Sub
Private Sub APP_SheetChange(ByVal Sh As Object, ByVal Target As Range)
MsgBox Target.Address(, , , 1, 1)
End Sub
Private Sub APP_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
MsgBox "進入 " & Wb.Name
End Sub
Private Sub APP_WindowDeactivate(ByVal Wb As Workbook, ByVal Wn As Window)
MsgBox "退出 " & Wb.Name
End Sub
Private Sub APP_WindowResize(ByVal Wb As Workbook, ByVal Wn As Window)
MsgBox Wn.Caption & "變化視窗"
End Sub

複製代碼