Externe Anwendung öffnen schließen

[Marek]

Hallo!
Ich wollte fragen ob es möglich ist ein externes Programm über einen VBA Code in Excel zu öffnen und nach einer gewisser Zeit (~10s) wider zu schließen.
Das starten des Programms habe ich mit der Shell Funktion schon super hinbekommen, aber wie schließe ich das Programm wieder. Excel soll das Programm öffnen wenn eine bestimmte Bedingungen erfüllt ist und dann eine E-mail senden. Vorm erstellen der E-mail muss er jedoch das Outlook Programm öffnen, weil sonst die E-mail im Postausgang stecken bleibt. 
Hoffe ihr könnt mir helfen!
Vielen Dank im Voraus
LG
Marek

[maninweb]

Hallo,

sowas geht meines Wissens nur mit Windows API. Siehe hier (Englisch) http://www.cpearson.com/excel/ShellAndWait.aspx

Ich würde aber vielleicht eher den Code zum Versand der E-Mail prüfen, da es ja bei Dir Outlook ist. Ggf. lässt sich da
was finden (kenne die Rahmenbedingungen nicht), um das Lagern im Postausgang zu verhindern und direkt zu senden.

Gruß

[volti]

Hallo Marek,

das Schließen einer externen Anwendung kann ganz einfach mit der Windows-Funktion Postmessage realisiert werden, in dem man dem Fenster (hier Outlook) den Windows-Befehl WM_Close sendet.
Postmessage platziert die Anweisung in die Windows-Warteschleife und wird irgendwann abgearbeitet.

Postmessage benötigt hierzu das Handle des Fensters, welches man schließen möchte. Bei bekanntem Windows-Caption (in der Regel das was oben im blauen Kopf steht) kann das einfach über Findwindow ermittelt werden.

Hier ein Beispiel für diese Kurzform:

Code:

Option Explicit

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, _
        ByVal lParam As LongPtr) As Long
Private Const WM_CLOSE = &H10

Dim hwnd As LongPtr

Sub StarteUndSchließeOutlookKurz()
'Outlook starten
 Shell "outlook.exe", 1
'Mach Dein Ding....
 MsgBox "Jetzt Outlook schließen"

'Handle des Outlook-Fenster ermitteln
 hwnd = FindWindow(vbNullString, "Posteingang - Outlook-Datendatei - Outlook")
 PostMessage hwnd, WM_CLOSE, 0&, 0&        'Outlook schließen
 
End Sub

PS: Die ShellUndWait-Function ist hier m.E. nicht anwendbar, da sie einen Prozess/Anwendung startet und darauf wartet, dass sie (von wem auch immer) beendet wird und der aufrufende Excelcode weitermachen kann.

Ist der Windows-Caption nicht bekannt, wird es schwieriger und aufwändiger, denn jetzt müssen alle Fenster durchgescannt werden und anhand Text oder Klassennamen identifiziert werden. Findwindow unterstützt keine Platzhalter:

Code:

Option Explicit

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, _
        ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" ( _
       ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
       ByVal hwnd As LongPtr, ByVal lpString As String, _
       ByVal cch As Long) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Const WM_CLOSE = &H10
Dim hwnd As LongPtr
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2

Sub StarteUndSchließeOutlookLang()
 Dim sText As String, L As Long, sClass As String * 128

'Outlook starten
 Shell "outlook.exe", 1
'Mach Dein Ding....
 MsgBox "Jetzt Outlook schließen"

'Alle Fenster durchscannen, um Outlook zu finden
 hwnd = GetWindow(GetForegroundWindow(), GW_HWNDFIRST)
 Do While hwnd <> 0
    L = GetWindowTextLength(hwnd) + 1
    sText = Space$(L)
    L = GetWindowText(hwnd, sText, L)
    If sText Like "Post*Outlook*" Then
      PostMessage hwnd, WM_CLOSE, 0&, 0&   'Outlook schließen
      Exit Sub
    End If
    DoEvents
    hwnd = GetWindow(hwnd, GW_HWNDNEXT)    'Handle des nächsten Fensters
 Loop
 
End Sub

____________________

viele Grüße aus Freigericht
Karl-Heinz

[Marek]

Hallo!
Vielen vielen Dank für die schnellen Antworten!
Müsste ich meinen ganzen Code mit Sub und End Sub bei 'Mach dein ding einfügen?
Das ist mein daweiliger Code:

Option Explicit
Option Compare Text

Sub SendeMail()
'Sendet Mail mit integriertem Bereich als Bild mit Signatur
'Das Bild wird über das Kürzel ~ im Text platziert
Dim WSh As Worksheet
Dim sMailtext As String, sSignatur As String
Dim sBer As String, iEinf As Integer


Set WSh = ThisWorkbook.Sheets("3AHET")  'Blatt mit Maildaten

    If WSh.Range("AU11") Like "X" Then
  sBer = "AG6:AR41"  'Kopierbereich
 
      GoTo Weiter
End If

MsgBox "Es wurde keine Mail versendet!", vbCritical, "Mail senden"
Exit Sub

Weiter:
On Error Resume Next
'Bereich kopieren
Do
  WSh.Range(sBer).Copy
  If Err.Number = 0 Then Exit Do
  Err.Clear
Loop

Shell "C:\Program Files\Microsoft Office\root\Office16\OUTLOOK"

With CreateObject("Outlook.Application").CreateItem(0)

  .Subject = "Notenübersicht"    'Betreff
  .To = "180178@studierende.htl-donaustadt.at"        'Empfänger
  sMailtext = "Noteninfo für das vergangerne Monat"
           
  .GetInspector:  sSignatur = .HTMLBody      'Signatur holen
  .HTMLBody = Replace(sMailtext, "", "
") & sSignatur
  .Display
 
  iEinf = InStr(sMailtext, "~")              'Alternative Einfügestelle
  If iEinf = 0 Then iEinf = Len(sMailtext)  'Grafik Einfügestelle
With .GetInspector.WordEditor.Range(iEinf, iEinf).Paste 'Bereich in EMail als Tabelle einfuegen
  End With
.send
End With

End Sub

Vielen Dank 
LG Marek

[volti]

Hallo Marek,

Du kannst Deine eMail-Sub lassen wie sie ist und sie anstelle von "Mach Dein Ding" als Sub aufrufen.

z.B. 
Call SendeMail


Hier ist allerdings schon eine "Shell "C:\Program Files\Microsoft Office\root\Office16\OUTLOOK"" drin, die wohl Outlook schon aufruft?!
Dann kannst Du Dir die andere Shell ja sparen....

viele Grüße
Karl-Heinz

[Case]

Hallo, :19:

um Programme zu schließen bietet sich Windows Management Instrumentation Command-line (WMIC) an - Link. Das ist sehr mächtig:

Code:

Option Explicit
Public Sub Main()
    Shell "wmic Process where ""name='outlook.exe'"" call terminate", vbHide
End Sub

Es ist auch egal, wenn das Programm nicht läuft. Mit WMIC kannst du natürlich noch sehr viel mehr machen (einfach mal in einer Suchmaschine deiner Wahl abklären). :21:

[volti]

Hi Case,

danke für den interessanten Hinweis. Noch nie was von gehört.
Eine neue Spielwiese.....  :19:

viele Grüße
Karl-Heinz

[Marek]

Hallo!
Danke für die vielen Hinweise!
Ich habe jetzt den Code so aufgebaut:

Code:

Option Explicit
Option Compare Text

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, _
        ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" ( _
      ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
      ByVal hwnd As LongPtr, ByVal lpString As String, _
      ByVal cch As Long) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Const WM_CLOSE = &H10
Dim hwnd As LongPtr
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2

Sub SendeMail()
'Sendet Mail mit integriertem Bereich als Bild mit Signatur
'Das Bild wird über das Kürzel ~ im Text platziert
Dim WSh As Worksheet
Dim sMailtext As String, sSignatur As String
Dim sBer As String, iEinf As Integer
Dim sText As String, L As Long, sClass As String * 128
Dim newHour As Integer, newMinute As Integer, newSecond As Integer
Dim waitTime As Boolean

Set WSh = ThisWorkbook.Sheets("3AHET")  'Blatt mit Maildaten

    If WSh.Range("AU11") Like "X" Then
  sBer = "AG6:AR41"  'Kopierbereich
 
      GoTo Weiter
End If

MsgBox "Es wurde keine Mail versendet!", vbCritical, "Mail senden"
Exit Sub

Weiter:
On Error Resume Next
'Bereich kopieren
Do
  WSh.Range(sBer).Copy
  If Err.Number = 0 Then Exit Do
  Err.Clear
Loop

Shell "C:\Program Files\Microsoft Office\root\Office16\OUTLOOK"

With CreateObject("Outlook.Application").CreateItem(0)

  .Subject = "Notenübersicht"    'Betreff
  .To = "180178@studierende.htl-donaustadt.at"        'Empfänger
  sMailtext = "Noteninfo für das vergangerne Monat"
           
  .GetInspector:  sSignatur = .HTMLBody      'Signatur holen
  .HTMLBody = Replace(sMailtext, "", "<br>") & sSignatur
  .Display
 
  iEinf = InStr(sMailtext, "~")              'Alternative Einfügestelle
  If iEinf = 0 Then iEinf = Len(sMailtext)  'Grafik Einfügestelle
With .GetInspector.WordEditor.Range(iEinf, iEinf).Paste 'Bereich in EMail als Tabelle einfuegen
  End With
.send
End With

newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 5
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait (waitTime)

'Alle Fenster durchscannen, um Outlook zu finden
hwnd = GetWindow(GetForegroundWindow(), GW_HWNDFIRST)
Do While hwnd <> 0
    L = GetWindowTextLength(hwnd) + 1
    sText = Space$(L)
    L = GetWindowText(hwnd, sText, L)
    If sText Like "Post*Outlook*" Then
      PostMessage hwnd, WM_CLOSE, 0&, 0&  'Outlook schließen
      Exit Sub
    End If
    DoEvents
    hwnd = GetWindow(hwnd, GW_HWNDNEXT)    'Handle des nächsten Fensters
Loop

End Sub

Nur leider Funktioniert das mit dem Anhalten des Codes nicht ganz, sodass Outlook dann fragt ob er Outlook schließen soll oder warten soll!
Hab ich alles richtig gemacht oder was falsch.
Eine weitere Frage wäre noch ob mir jemand helfen kann das der Makro nur an bestimmten Tagen ausgeführt wird. Also statt der If-bedingung am Anfang mit dem "X".
Ich habe mir schon paar Formeln angeschaut und ausprobiert, aber irgendwie funktionieren die nicht.
Hoffe mir kann wer helfen!
Vielen Dank im Voraus
LG
Marek

[volti]

Hallo Marek,

nachfolgend mal ein angepasster Code, der bei mir das geschlossene Outlook öffnet, die Mail kreiert, absendet (konnte ich nicht testen) und Outlook anschließend wieder schließt.
Die Mail wird nur an den in der Zelle angegebenen, kommagetrennten Wochentagen versendet.

Für das Schließen von Outlook habe ich den Code von Case verwendet, der ist deutlich kürzer als die API-Version und funktioniert sehr gut.

Ich weiß jetzt allerdings nicht, ob bei Dir beim Ausführen des Send-Befehl noch eine Sicherheits-MsgBox von Outlook kommt, die das automatische Versenden behindern würde...

Schau mal, ob Du damit schon weiter kommst:

Code:

Option Explicit
Option Compare Text

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub SendeMail()
'Sendet Mail mit integriertem Bereich als Bild mit Signatur
 Dim WSh As Worksheet
 Dim sMailtext As String, sSignatur As String
 Dim sBer As String, iEinf As Integer
 Set WSh = ThisWorkbook.Sheets("3AHET")             'Blatt mit Maildaten

 If InStr(WSh.Range("AU11").Value, Left$(WeekdayName(Weekday(Date), False, vbSunday), 2)) > 0 Then
    sBer = "AG6:AR41"                               'Kopierbereich
 Else
   Application.StatusBar = "Es wurde keine Mail versendet!"
   Exit Sub
 End If

 On Error Resume Next
'Bereich kopieren
 Do
    WSh.Range(sBer).Copy
    If Err.Number = 0 Then Exit Do
    Err.Clear
 Loop

'Outlook starten
 Shell "C:\Program Files\Microsoft Office\root\Office16\OUTLOOK"
 Sleep 2000
 
 With CreateObject("Outlook.Application").CreateItem(0)
   .Subject = "Notenübersicht"                        'Betreff
   .To = "180178@studierende.htl-donaustadt.at"       'Empfänger
   sMailtext = "Noteninfo für den vergangenen Monat"
          
   .GetInspector:  sSignatur = .HTMLBody              'Signatur holen
   .HTMLBody = Replace(sMailtext, "", "<br>") & sSignatur
   .display
 
   iEinf = Len(sMailtext)                             'Grafik Einfügestelle
   .GetInspector.WordEditor.Range(iEinf, iEinf).Paste 'Bereich in EMail als Tabelle einfuegen
   .send
 End With

'3 Sekunden warten
 Sleep 3000

'Outlook beenden
 Shell "wmic Process where ""name='outlook.exe'"" call terminate", vbHide
 
End Sub

____________________

viele Grüße aus Freigericht
Karl-Heinz

[Marek]

Hallo!
Vielen Dank für den Code.
Ich werde ihn dann später ausprobieren und Bescheid sagen, ob er funktioniert.
Gibt es für die Wochentage nicht auch noch andere leichtere Formeln?
Diese habe ich mir angeschaut:

Sub test()
If Date = "Datum 1" Or_
   Date = "Datum 2" Or_
   Date = " Datum 3" Then
sBer = kopierbereich
End if
Ens sub

Und:

Sub Test2()
Dim datKontrolle As Date
datKontrolle = DateSerial(2020,9,30)
datKontrolle = DateSerial(2020,10,31)
datKontrolle = DateSerial(2020,11,30)
datKontrolle = DateSerial(2020,12,31)
datKontrolle = DateSerial(2021,1,31)
datKontrolle = DateSerial(2021,2,28)
datKontrolle = DateSerial(2021,3,31)
datKontrolle = DateSerial(2021,4,30)
datKontrolle = DateSerial(2021,5,31)
datKontrolle = DateSerial(2021,6,30)

Ich Date = datKontrolle Then
MsgBox "Macro wird ausgeführt"
Else
MsgBox "falsches Datum"
Ens If

End Sub

Zur Probe habe ich dann einmal das aktuelle Datum genommen. Er hat dann trotzdem gesagt, das keine Email versendet wurde.
Werde mich später melden!
LG
Marek