Nachtrag:
nachdem es bei jedem vierten Versuch weiterhin nicht funktioniert hat, bin ich dahinter gekommen, dass SetFocus völlig ausreicht. Jedoch benötigt Word ein bisschen Zeit um diesen zu setzen. Daher habe ich Sleep verwendet. Sollte der Fehler immer noch auftauchen erhöhe den Wert bei Sleep ein bisschen.
Private Declare PtrSafe Function SetFocus Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
'weitere mögliche API-Funktionen durchgetestet
'Private Const WM_KILLFOCUS = &H8
'Private Const WM_SETFOCUS = &H7
'Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
'Private Declare PtrSafe Function GetProcessID Lib "kernel32" (ByVal hwnd As LongPtr) As LongPtr
'Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
'Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hwnd As LongPtr) As Long
'Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Sub ExcelAnzeigen()
ExtDateipfad = "D:\Daten\Entwicklung\Tests\Test.xlsm"
Tabellenname = "Tabelle1"
On Error Resume Next 'Excel neue Instanz aufbauen
Set ExcApp = CreateObject("Excel.Application")
On Error GoTo 0
wdhwnd = Application.ActiveWindow.hwnd 'Word Handle ermitteln
Set excwb2 = ExcApp.Workbooks.Open(ExtDateipfad)
Set ExcWs2 = excwb2.Sheets(Tabellenname)
excwb2.Activate
ExcApp.Visible = True
ExcApp.WindowState = -4137
ExcWs2.Activate
ExcWs2.Visible = True
ExcWs2.Cells(ExcWs2.Cells(ExcWs2.Rows.Count, 1).End(-4162).Row, 1).Select
'wartet auf Nutzereingabe und Zelle auswählen
'Dim rng As Range
Set rng = ExcApp.Selection
Do
DoEvents
Loop Until ExcApp.Selection.Address <> rng.Address
Debug.Print ExcApp.Selection.Address
Debug.Print rng.Address
'Fokus an Word zurückgeben
SetFocus wdhwnd
Sleep 200
'Schliessen der Datei
With excwb2
.Saved = True
.Close
End With
ExcApp.Quit
Set excwb2 = Nothing
End Sub
Gruß Mr. K.
|