narazil jsem na malý problém se spojením maker s tím s předchozího příspěvku a prosím ještě o pomoc.
http://www.pc-help.cz/viewtopic.php?f=35&t=133974
Mám 3 funkční makra Module2, Module3, Module 4 a chtěl bych k nim na konec přidat i to z předchozího
příspěvku, které jsem si nakopíroval do Module5. Mám to takto zapsáno v Module1:
Kód: Vybrat vše
Sub spoustec()
Module2.sloupce
Module3.vymaz
Module4.zmena
Module5.GetAllWorkbookWindowNames
End Sub
Problém je v tom, že první tři makra proběhnou v pohodě a na tom posledním to vždy vyhodí chybovou hlášku,
kterou když odklepnu, tak makro doběhne.
Pokud to makro v Module5, ale spustím samostatně bez těch ostatních problém nenastane.
Nevíte jak to makro viz níže (předchozí příspěvek) správně přidat k ostatním, aby to proběhlo bez chyb?
Kód: Vybrat vše
'------------- Code Module --------------
Option Explicit
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
Declare Function GetClassName Lib "User32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, ByRef lpiid As UUID) As Long
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As UUID, ByRef ppvObject As Object) As Long
Type UUID 'GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'------------- Code (Module, Form) --------------
Const IID_IDispatch As String = "{00020400-0000-0000-C000-000000000046}"
Const OBJID_NATIVEOM As Long = &HFFFFFFF0
'Sub Command1_Click()
Sub GetAllWorkbookWindowNames()
On Error GoTo MyErrorHandler
Dim hWndMain As Long
hWndMain = FindWindowEx(0&, 0&, "XLMAIN", vbNullString)
Do While hWndMain <> 0
GetWbkWindows hWndMain
hWndMain = FindWindowEx(0&, hWndMain, "XLMAIN", vbNullString)
Loop
Exit Sub
MyErrorHandler:
MsgBox "GetAllWorkbookWindowNames" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub
Private Sub GetWbkWindows(ByVal hWndMain As Long)
On Error GoTo MyErrorHandler
Dim hWndDesk As Long
hWndDesk = FindWindowEx(hWndMain, 0&, "XLDESK", vbNullString)
If hWndDesk <> 0 Then
Dim hWnd As Long
hWnd = FindWindowEx(hWndDesk, 0, vbNullString, vbNullString)
Dim strText As String
Dim lngRet As Long
Do While hWnd <> 0
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
If Left$(strText, lngRet) = "EXCEL7" Then
GetExcelObjectFromHwnd hWnd
Exit Sub
End If
hWnd = FindWindowEx(hWndDesk, hWnd, vbNullString, vbNullString)
Loop
On Error Resume Next
End If
Exit Sub
MyErrorHandler:
MsgBox "GetWbkWindows" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Sub
Public Function GetExcelObjectFromHwnd(ByVal hWnd As Long) As Boolean
On Error GoTo MyErrorHandler
Dim fOk As Boolean
fOk = False
Dim iid As UUID
Call IIDFromString(StrPtr(IID_IDispatch), iid)
Dim obj As Object
If AccessibleObjectFromWindow(hWnd, OBJID_NATIVEOM, iid, obj) = 0 Then 'S_OK
Dim objApp As Excel.Application
Set objApp = obj.Application
Dim wbCount As Integer
For wbCount = 1 To objApp.Workbooks.Count
' Debug.Print objApp.Workbooks(wbCount).name
' Sheets Workbooks
' Dim myWorksheet As Worksheet
' For Each myWorksheet In objApp.Workbooks(1).Worksheets
' Debug.Print " " & myWorksheet.name
' DoEvents
' Next
If InStr(objApp.Workbooks(wbCount).name, "crd") > 0 Then
objApp.Workbooks(wbCount).Close False
wbCount = wbCount - 1
If wbCount = objApp.Workbooks.Count Then Exit For
End If
Next
fOk = True
End If
GetExcelObjectFromHwnd = fOk
Exit Function
MyErrorHandler:
MsgBox "GetExcelObjectFromHwnd" & vbCrLf & vbCrLf & "Err = " & Err.Number & vbCrLf & "Description: " & Err.Description
End Function
díky za pomoc a trpělivost
