AW: Emails aus Excel versenden
23.02.2016 00:09:19
Raphael
Hallo Kulo,
in deinem Code wird lediglich ein Outlookobjekt erstellt und im Postausgang abgelegt. Das Programm wird nicht direkt geöffnet.
Ich denke diesen Code könntest du nutzten. Aber evtl. gehts auch einfacher und eleganter.
Der erste Teil, die API Declare und die Function sind von Sepp (Ehrensberger)
Option Explicit
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As _
Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As _
Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As _
Long, ByVal uExitCode As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal _
nCmdShow As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal _
lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As _
Long, lpdwProcessId As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd _
As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Const PROCESS_TERMINATE = &H1
Private Const GW_HWNDNEXT As Long = &H2
Private Const SW_MINIMIZE = &H6
Private Const SW_RESTORE = &H9
Public lTaskID As Long
Public hWnd As Long
Private Retval As Long
Private Function ShellTohWnd(ByVal hhwPfad As String, Optional Mode As VbAppWinStyle)
Dim ProcHWN As Long
lTaskID = Shell(hhwPfad, Mode)
Retval = FindWindow(vbNullString, vbNullString)
Do While Retval 0
If GetParent(Retval) = 0 Then
Call GetWindowThreadProcessId(Retval, ProcHWN)
If ProcHWN = lTaskID Then
ShellTohWnd = Retval
Exit Do
End If
End If
Retval = GetWindow(Retval, GW_HWNDNEXT)
Loop
End Function
Sub Schliessen()
Dim hTask As Long
Dim lResult As Long
If lTaskID > 0 Then
hTask = OpenProcess(PROCESS_TERMINATE, 0&, lTaskID)
lResult = TerminateProcess(hTask, 1&)
lResult = CloseHandle(hTask)
lTaskID = 0
hWnd = 0
End If
End Sub
Private Sub EmailLKW2()
Dim objOutlook As Object
Dim objMail As Object
Dim Ol As Object
Dim olF As Object
Dim olNs As Object
lTaskID = 0
'Hier den Pfad anpassen in der deine Outlook.exe liegt
hWnd = ShellTohWnd("C:\....\OUTLOOK.EXE", vbHide)
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.Recipients.Add Worksheets("LKW").Range("B3").Value
.Subject = Worksheets("LKW").Range("A1").Value
.Body = Worksheets("LKW").Range("E8").Value
.Display
.Send
End With
'Outlook aufgreifen und prüfen ob der Postausgang leer ist
Set Ol = GetObject(, "outlook.Application")
Set olNs = Ol.getnamespace("mapi")
Set olF = olNs.getdefaultfolder(4) 'olFolderOutbox
'Warten bis der Outlookausgang leer ist und danach Outlook schliessen
Do
Application.Wait (Now + TimeValue("0:00:01"))
Loop While (olF.Items.Count > 0)
Call Schliessen
End Sub