tagCANDY CGI VBレスキュー(花ちゃん)の Visual Basic 6.0用 掲示板
VBレスキュー(花ちゃん)の Visual Basic 6.0用 掲示板
[ツリー表示へ]　 [ワード検索]　 [Home]

タイトル ： Re: 既に開いてあるExcelのPathを取得
投稿日： 2009/07/07(Tue) 15:32
投稿者： YK
こんにちは。
起動中のワークブックオブジェクトを取得できます。
リストボックスにワークブックオブジェクトのフルネームを表示します。

Form にコマンドボタンとリストボックスを各一個貼り付けて　
実行してみて下さい。

参照設定　Microsoft Excel XX.X Object Libray
          Accessibility  は OLEACC.DLL を参照する

******************* Standard Module ********************

Option Explicit
Private Declare Function EnumWindows Lib "user32.dll" _
                        (ByVal lpEnumFunc As Long, _
                         ByVal lParam As Long) As Long

Private Declare Function GetClassName Lib "user32.dll" _
                        Alias "GetClassNameA" _
                        (ByVal hWnd As Long, _
                         ByVal lpClassName As String, _
                         ByVal nMaxCount As Long) As Long

Private Declare Function EnumChildWindows Lib "user32.dll" _
                        (ByVal hWndParent As Long, _
                         ByVal lpEnumFunc As Long, _
                         ByVal lParam As Long) As Long

Private Declare Function GetWindowText Lib "user32.dll" _
                        Alias "GetWindowTextA" _
                        (ByVal hWnd As Long, _
                         ByVal lpString As String, _
                         ByVal nMaxCount As Long) As Long

Private Declare Function IIDFromString Lib "ole32" _
                        (lpsz As Any, lpiid As Any) As Long
        
Private Declare Function ObjectFromLresult Lib "oleacc" _
                        (ByVal lResult As Long, _
                         riid As Any, _
                         ByVal wParam As Long, _
                         ppvObject As Any) As Long

Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _
                        (ByVal hWnd As Long, _
                         ByVal dwObjectID As Long, _
                         ByRef riid As Any, _
                         ByRef ppvObject As Any) As Long
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Enum NVADIRConstants
    NAVDIR_MIN
    NAVDIR_UP
    NAVDIR_DOWN
    NAVDIR_LEFT
    NAVDIR_RIGHT
    NAVDIR_NEXT
    NAVDIR_PREVIOUS
    NAVDIR_FIRSTCHILD
    NAVDIR_LASTCHILD
    NAVDIR_MAX
End Enum
Private Declare Function IsWindow Lib "user32" _
                        (ByVal hWnd As Long) As Long

Private Const CHILDID_SELF As Long = 0&
Private Const OBJID_NATIVEOM = &HFFFFFFF0
Private Const OBJID_CLIENT = &HFFFFFFFC

'固有の型を指定しても問題無さそうなのですが
'その場合は、EXCEL.EXEをOleView.Exe(Platform SDKに付属)で開いて
'IIDを調べて指定した方が無難かも知れません。 ↓
Private Const IID_IDispatch = "{00020400-0000-0000-C000-000000000046}"

Private Const WM_GETOBJECT = &H3D&

Type WbkDtl
    hWnd        As Long
    wkb         As Excel.Workbook
End Type
Public wD()     As WbkDtl
    
' コールバック関数
Private Function EnumWindowsProc(ByVal hWnd As Long, _
                                 ByVal lParam As Long) As Long
    Dim strClassBuff    As String * 128
    Dim strClass        As String
    Dim lngRtnCode      As Long
    Dim lngThreadId     As Long
    Dim lngProcesID     As Long

    ' クラス名取得
    lngRtnCode = GetClassName(hWnd, strClassBuff, Len(strClassBuff))
    strClass = Left(strClassBuff, InStr(strClassBuff, vbNullChar) - 1)
    If strClass = "XLMAIN" Then
        ' 子ウィンドウを列挙
        lngRtnCode = EnumChildWindows(hWnd, AddressOf EnumChildSubProc, lParam)
    End If
    ' 列挙を継続
EnumPass:
    EnumWindowsProc = True
End Function

' コールバック関数 - 子ウィンドウを列挙
Private Function EnumChildSubProc(ByVal hwndChild As Long, _
                                  ByVal lParam As Long) As Long
    Dim strClassBuff    As String * 128
    Dim strClass        As String
    Dim strTextBuff     As String * 516
    Dim strText         As String
    Dim lngRtnCode      As Long
    
    ' クラス名取得
    lngRtnCode = GetClassName(hwndChild, strClassBuff, Len(strClassBuff))
    strClass = Left(strClassBuff, InStr(strClassBuff, vbNullChar) - 1)
    If strClass = "EXCEL7" Then
        ' テキストをバッファに
        lngRtnCode = GetWindowText(hwndChild, strTextBuff, Len(strTextBuff))
        strText = Left(strTextBuff, InStr(strTextBuff, vbNullChar) - 1)
        If InStr(1, strText, ".xla") = 0 Then     '
            If Sgn(wD) = 0 Then
                ReDim wD(0)
                wD(0).hWnd = hwndChild
            Else
                ReDim Preserve wD(UBound(wD) + 1)
                wD(UBound(wD)).hWnd = hwndChild
            End If
        End If
    End If
    ' 列挙を継続
EnumChildPass:
    EnumChildSubProc = True
End Function

'***********   OLEACC.DLL を参照すること  *************

Private Sub GetExcelBookDObj(wDl As WbkDtl)
    Dim IID(0 To 3) As Long
    Dim bytID()     As Byte
    Dim lngResult   As Long
    Dim lngRtnCode  As Long
    Dim wbw         As Excel.Window
    Dim objAcc      As IAccessible
    Dim wb          As Workbook
    If IsWindow(wDl.hWnd) = 0 Then Exit Sub
    bytID = IID_IDispatch & vbNullChar
    IIDFromString bytID(0), IID(0)
    lngRtnCode = AccessibleObjectFromWindow(wDl.hWnd, OBJID_NATIVEOM, IID(0), objAcc)
    If Not objAcc Is Nothing Then Set wDl.wkb = objAcc.Parent
End Sub


Sub Main_Proc()
    Dim lngRtnCode  As Long
    Dim i           As Long
    Erase wD
'   ワークブックのウィンドウハンドルを取得 WorkBook->EXCEL7
    lngRtnCode = EnumWindows(AddressOf EnumWindowsProc, ByVal 0&)
    If Sgn(wD) <> 0 Then
        For i = 0 To UBound(wD)
            Call GetExcelBookDObj(wD(i))
        Next
    End If
End Sub


************ Form Module ********************
Option Explicit

Private Sub Command1_Click()
    Dim i   As Long
    Me.List1.Clear
    Call Main_Proc
    If Sgn(wD) <> 0 Then
        For i = 0 To UBound(wD)
            If Not wD(i).wkb Is Nothing Then
                Me.List1.AddItem wD(i).wkb.FullName
            End If
        Next
    End If
End Sub
- 関連一覧ツリー （ をクリックするとツリー全体を一括表示します）

古いスレッドにレスはつけられません。