AW: Speichern per VBA klappt nur zuällig
12.09.2020 11:02:36
Nepumuk
Hallo,
teste mal:
Option Explicit
Private Declare PtrSafe Function GetClassNameA Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function EnumWindows Lib "user32.dll" ( _
ByVal lpEnumFunc As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function EnumChildWindows Lib "user32.dll" ( _
ByVal hWndParent As LongPtr, _
ByVal lpEnumFunc As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Sub IIDFromString Lib "ole32.dll" ( _
ByVal lpsz As String, _
ByRef lpiid As GUID)
Private Declare PtrSafe Sub AccessibleObjectFromWindow Lib "oleacc.dll" ( _
ByVal hwnd As LongPtr, _
ByVal dwId As Long, _
ByRef riid As GUID, _
ByRef ppvObject As Any)
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Const GC_CLASSNAMEEXCEL = "XLMAIN"
Private Const GC_CLASSNAMEEXCEL7 = "EXCEL7"
Private Const IID_EXCELWINDOW = "{00020893-0000-0000-C000-000000000046}"
Private Const OBJID_NATIVEOM = &HFFFFFFF0
Private Const FOLDER_PATH As String = "" 'Anpassen !!!
Private Const FILE_NAME As String = "" 'Anpassen !!!
Private lalngptrChildHwnd() As LongPtr, lialngChildCount As Long
Private lalngptrMainHwnd() As LongPtr, lialngMainCount As Long
Private Function GetApplications() As Application()
Dim ialngIndex As Long, ialngCount As Long
Dim udtGuid As GUID
Dim objWindow As Window
Dim aobjTempApplications() As Application
Erase lalngptrChildHwnd
lialngChildCount = 0
Erase lalngptrMainHwnd
lialngMainCount = 0
Call IIDFromString(StrConv(IID_EXCELWINDOW, vbUnicode), udtGuid)
Call EnumWindows(AddressOf EnumWindowsProc, ByVal 0)
For ialngIndex = LBound(lalngptrMainHwnd) To UBound(lalngptrMainHwnd)
Call EnumChildWindows(lalngptrMainHwnd(ialngIndex), _
AddressOf EnumChildWindowsProc, ByVal 0&)
Next
For ialngIndex = LBound(lalngptrChildHwnd) To UBound(lalngptrChildHwnd)
Call AccessibleObjectFromWindow(lalngptrChildHwnd(ialngIndex), _
OBJID_NATIVEOM, udtGuid, objWindow)
If Not objWindow Is Nothing Then
Redim Preserve aobjTempApplications(ialngCount)
Set aobjTempApplications(ialngCount) = objWindow.Application
ialngCount = ialngCount + 1
End If
Next
GetApplications = aobjTempApplications
End Function
Private Function EnumWindowsProc( _
ByVal pvlngptrHwnd As LongPtr, _
ByVal pvlnglParam As LongPtr) As LongPtr
If ClassName(pvlngptrHwnd) = GC_CLASSNAMEEXCEL Then
Redim Preserve lalngptrMainHwnd(lialngMainCount)
lalngptrMainHwnd(lialngMainCount) = pvlngptrHwnd
lialngMainCount = lialngMainCount + 1
End If
EnumWindowsProc = 1
End Function
Private Function EnumChildWindowsProc( _
ByVal pvlngptrHwnd As LongPtr, _
ByVal pvlngptrlParam As LongPtr) As LongPtr
If ClassName(pvlngptrHwnd) = GC_CLASSNAMEEXCEL7 Then
Redim Preserve lalngptrChildHwnd(lialngChildCount)
lalngptrChildHwnd(lialngChildCount) = pvlngptrHwnd
lialngChildCount = lialngChildCount + 1
EnumChildWindowsProc = 0
Else
EnumChildWindowsProc = 1
End If
End Function
Private Function ClassName( _
ByVal pvlngptrHwnd As LongPtr) As String
Dim strClassName As String * 256
Dim lngReturn As Long
lngReturn = GetClassNameA(pvlngptrHwnd, strClassName, Len(strClassName))
ClassName = Left$(strClassName, lngReturn)
End Function
Public Sub Save_SAP_Export()
Dim aobjApplications() As Application
Dim ialngIndex As Long
Dim objWorkbook As Workbook, objWorksheet As Worksheet
Dim objCell As Range
Dim objDictionary As Object
Dim avntApplications As Variant, vntApplicationItem As Variant
Dim strFirstAddress As String
Dim blnFound As Boolean
aobjApplications = GetApplications
Set objDictionary = CreateObject("Scripting.Dictionary")
For ialngIndex = LBound(aobjApplications) To UBound(aobjApplications)
If Not objDictionary.Exists(aobjApplications(ialngIndex).hwnd) Then _
Call objDictionary.Add(aobjApplications(ialngIndex).hwnd, aobjApplications(ialngIndex))
Set aobjApplications(ialngIndex) = Nothing
Next
avntApplications = objDictionary.Items
Set objDictionary = Nothing
For Each vntApplicationItem In avntApplications
For Each objWorkbook In vntApplicationItem.Workbooks
If InStr(objWorkbook.Name, "(1)") > 0 Then
vntApplicationItem.DisplayAlerts = False
objWorkbook.Worksheets(1).Name = "Tabelle1"
Call objWorkbook.SaveAs(Filename:=FOLDER_PATH & FILE_NAME)
vntApplicationItem.DisplayAlerts = True
Call MsgBox("Speichern erfolgreich.", vbInformation, "Information")
blnFound = True
Exit For
End If
Next
If blnFound Then Exit For
Next
Erase avntApplications
End Sub
Vergiss nicht den Pfad und den Dateinamen anzupassen !!!
Gruß
Nepumuk