AW: Excelinstanz
29.09.2005 00:19:33
Ralf
Hi Frank,
so einen Aufwand, nur weil Du keine Lust auf ein paar Mausklicks hast...tztztz...
Meine Frage diesbezüglich hast Du immer noch nicht beantwortet. Warum der Aufwand?
Das sollte funktionieren (Namen und Pfade natürlich noch anpassen):
Option Explicit
Private Declare
Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare
Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare
Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare
Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Const SW_SHOWNORMAL = 1
Const WM_CLOSE = &H10
Const gcClassnameMSExcel = "XLMAIN"
Public
Sub Fenster_Finden_und_schliessen()
Dim WinWnd As Long, Ret As String, RetVal As Long, lpClassName As String
Dim aInst(1) As String, x As Byte, myPics(2) As String
myPics(0) = "C:\Ico1.ico"
myPics(1) = "C:\ico2.ico"
myPics(2) = "C:\ico3.ico"
aInst(0) = "Microsoft Excel - Frank1.xls"
aInst(1) = "Microsoft Excel - Frank2.xls"
Application.DisplayAlerts = False
For x = 0 To 1
Ret = aInst(x)
WinWnd = FindWindow(vbNullString, Ret)
If WinWnd = 0 Then
MsgBox "Fenster mit dem Titel " & aInst(x) & " nicht vorhanden oder geöffnet.", vbInformation, "Fenster wurde nicht gefunden ..."
GoTo Weiter
End If
ShowWindow WinWnd, SW_SHOWNORMAL
Icon_Auf_Desktop myPics(x)
lpClassName = Space(256)
RetVal = GetClassName(WinWnd, lpClassName, 256)
PostMessage WinWnd, WM_CLOSE, 0&, 0&
Weiter:
Next x
Icon_Auf_Desktop myPics(2)
Application.Quit
Application.DisplayAlerts = True
End Sub
Public
Sub Icon_Auf_Desktop(Bild As String)
Dim myFSO As Object
Dim myFSOShell As Object
Dim strDesktop As String
Dim myMainFolder As String
Dim mySubFolder As String
Dim myShortCut As Object
Dim myToCopyFile As String, myFileExt As String
On Error GoTo Fehler
myMainFolder = ActiveWorkbook.Path
mySubFolder = myMainFolder
'OHNE Extension
myToCopyFile = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) 'Extension abschneiden
myFileExt = ".xls"
Set myFSO = CreateObject("Scripting.FileSystemObject")
Set myFSOShell = CreateObject("WScript.Shell")
'Verknüpfung auf dem Desktop erzeugen
strDesktop = myFSOShell.SpecialFolders("Desktop")
Set myShortCut = myFSOShell.CreateShortcut(strDesktop + "\" & myToCopyFile & ".lnk")
With myShortCut
'Fenstertyp beim öffnen
' 4=Normal 3=Maximized 7=Minimized
.windowstyle = 7
.IconLocation = Bild
.Targetpath = mySubFolder & "\" & myToCopyFile & myFileExt
'Keyboard Shortcut zuweisen
'.Hotkey = "ALT+CTRL+" & x + 1
'Speichern
.Save
End With
Set myFSO = Nothing
Set myFSOShell = Nothing
Set myShortCut = Nothing
Exit Sub
Fehler:
MsgBox "Fehler"
End Sub
Ciao, Ralf