« 空白は、ファイル名の途中には使えますが、先頭や末尾にも使える? | トップページ | Excel VBAから他のExcelインスタンスを捕捉する。 »

2008年4月 1日 (火)

実行中の複数のExcelインスタンスをスクリプトから捕捉する。

えー! そんなことできるの? という感じですが。。。

Sub Push(Items,Item)
ReDim Preserve Items(UBound(Items)+1)
Set Items(UBound(Items))=Item
End Sub

Applications=Array()
On Error Resume Next
Set Application1=GetObject(,"Excel.Application")
On Error GoTo 0
If Not IsEmpty(Application1) Then
  Count1=GetObject("winmgmts:root\CIMV2").ExecQuery("SELECT * FROM Win32_Process WHERE Name='EXCEL.EXE'").Count
  Push Applications,Application1
  Application1.IgnoreRemoteRequests=True
  Do
    Application1.DisplayAlerts=False
    channelNumber=Application1.DDEInitiate("Excel","System")
    Application1.DisplayAlerts=True
    Application1.DDEExecute channelNumber,"[NEW()]"
    x=Application1.DDERequest(channelNumber,"Topics")
    Path=x(UBound(x)-1)
    Path=Split(Mid(Path,2),"]")(0)
    Set Application2=GetObject(Path).Application
    Application1.DDEExecute channelNumber,"[CLOSE()]"
    Application1.DDETerminate channelNumber
    Count2=GetObject("winmgmts:root\CIMV2").ExecQuery("SELECT * FROM Win32_Process WHERE Name='EXCEL.EXE'").Count
    If Count2 <> Count1 Then
      Application2.Quit
      Set Application2 = Nothing
      Exit Do
    End If
    Push Applications,Application2
    Application2.IgnoreRemoteRequests=True
  Loop
  For Each Application In Applications
    Application.IgnoreRemoteRequests=False
  Next
End If
MsgBox UBound(Applications)+1

配列 Applications() に実行中の Excel.Application オブジェクトへの参照が入ります。

« 空白は、ファイル名の途中には使えますが、先頭や末尾にも使える? | トップページ | Excel VBAから他のExcelインスタンスを捕捉する。 »