- 帖子
- 23
- 主題
- 0
- 精華
- 0
- 積分
- 73
- 點名
- 265
- 作業系統
- XP
- 軟體版本
- Office 2003
- 閱讀權限
- 20
- 註冊時間
- 2012-4-21
- 最後登錄
- 2025-10-30
           
|
10#
發表於 2015-7-25 18:22
| 只看該作者
no3-taco前輩，謝謝你的幫忙。
我有查到網路上的類似的問題。我把代碼放在底下（上一封的代碼是我依 ...
justintoolbox 發表於 2015-7-25 17:37 
試試看(測試環境 : Win7 + Office2013)- 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
|
|
發表於 2015-7-25 00:32
| 
