| |
▼excelVBA好きです さん：
Window HandleからWorkbookのObjectを取得しています。
Main_Procの中のエクセル名を実際のファイル名に変えて
Main_Procを実行してみて下さい。
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 SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, lParam As Any) 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 IsWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Private Const OBJID_NATIVEOM = &HFFFFFFF0
Private Const OBJID_CLIENT = &HFFFFFFFC
Private Const IID_IMdcList = "{8BD21D23-EC42-11CE-9E0D-00AA006002F3}"
Private Const IID_IUnknown = "{00000000-0000-0000-C000-000000000046}"
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
Private wD() As WbkDtl
' コールバック関数
Public 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
Public Sub GetExcelBook(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
If IsWindow(wDl.hWnd) = 0 Then Exit Sub
lngResult = SendMessage(wDl.hWnd, WM_GETOBJECT, 0, ByVal OBJID_NATIVEOM)
If lngResult Then
bytID = IID_IDispatch & vbNullChar
IIDFromString bytID(0), IID(0)
lngRtnCode = ObjectFromLresult(lngResult, IID(0), 0, wbw)
If Not wbw Is Nothing Then Set wDl.wkb = wbw.Parent
End If
End Sub
Sub Main_Proc()
Dim lngRtnCode As Long
Dim i As Long
Dim wbA As Workbook
Dim wbB As Workbook
Erase wD
' ワークブックのウィンドウハンドルを取得 WorkBook->EXCEL7
lngRtnCode = EnumWindows(AddressOf EnumWindowsProc, ByVal 0&)
If Sgn(wD) <> 0 Then
For i = 0 To UBound(wD)
Call GetExcelBook(wD(i))
Select Case wD(i).wkb.Name
Case "A.xls" ' Aエクセル
Set wbA = wD(i).wkb
Case "B.xls" ' Bエクセル
Set wbB = wD(i).wkb
End Select
Next
End If
If wbA Is Nothing Or wbB Is Nothing Then
MsgBox "対象のブックがありません"
Exit Sub
End If
With wbA
For i = 1 To .Worksheets.Count
' Aエクセルのシートをコピー
.Worksheets(i).Cells.Copy
' Bエクセルにシートを追加
wbB.Worksheets.Add After:=wbB.Worksheets(wbB.Worksheets.Count)
' 貼付け
wbB.Worksheets(wbB.Worksheets.Count).Paste
Next
End With
With wbA.Application
.DisplayAlerts = False
.Quit 'Aエクセルを終了
End With
End Sub
|
|
Yuki
- 09/10/4(日) 16:07 -
