AW: Speicherprob bei progr. Steuerung von Fremdpro
20.12.2004 11:23:30
Fremdpro
Huhu Josef,
so der Firmenserver hat sich entschieden, die gestern gesendeten Mails doch noch zu übertragen. Nachstehend der Code, den Du allerdings nur mit den entsprechenden Tabellenblättern und Zellennamen zum Laufen bringen könntest. Da der Code aber absolut unspektakulär ist, denke ich, dass Du auch ohne Testlauf einen Eindruck gewinnen kannst - zumal der Testlauf auf einem Standalone (wie bei mir zuhause) auch reibungslos läuft.
Ich habe jetzt eine Methode zum Beenden des Prozesses über das Windows-Handle zu "Microsoft Outlook" gefunden (www.vbarchiv.net/faq/allg_exitprocess.php). Schöner wäre es natürlich, wenn man über den Prozeßnamen "Outlook.exe" beenden könnte. Am besten natürlich, wenn es noch eine andere, eine SICHERE und trotzdem "schonende" Methode zum Beenden gäbe. Das Beenden des Proceces ist natürlich schon relativ gewaltsam... Was passiert zum Beispiel, wenn Outlook gerade im Begriff war, eine Mail zu empfangen mit dieser Mail beim Terminieren des Prozesses? Nochmals Danke und Gruß
Björn
Hier der Code
Public
Sub Senden()
Dim tbl As Worksheet
Set tbl = ActiveWorkbook.ActiveSheet
Dim i%
i = 2
Dim ls%, c%
ls = Cells(2, Cells.Columns.Count).End(xlToLeft).Column
Dim werte As Worksheet
Set werte = ThisWorkbook.Sheets("Werte")
Dim Kdnr, VNAnrede, VNTitel, VNVorname, VNNachname, _
VNStrasse, VNPlz, VNOrt, VNTelPriv, VNTelGesch, VNGebDat, VNArt, _
AGTNr, Beginn, Ablauf, Sparte, Vsnr, Beitrag, _
Monatsfaelligkeit, Tagesfaelligkeit, Schadenzahl, Schadenhoehe, Saldoart, Saldohoehe, _
Mahnstufe, BeitragZW, ZW, ErstellDat, Ablauf2, GEVO, TKlausel, _
AgtAnrede, AgtVorname, AgtNachname, AgtPnr, AgtGes, AgtMandant, _
AgtTel, AgtFax, AgtMail As String
Dim lHwnd, lRetVal As Long
Dim intCounter%
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
Dim bolStatusBar
Application.DisplayStatusBar = True
bolStatusBar = Application.DisplayStatusBar
On Error Resume Next
Err.Number = 0
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
'MsgBox "starte Outlook"
'Outlook läuft noch nicht, muß gestartet werden
Set objOutlook = CreateObject("Outlook.Application")
Shell "outlook.exe", vbMinimizedNoFocus
'Application.ActivateMicrosoftApp xlMicrosoftMail
End If
On Error GoTo 0
'übersetze Buchstaben am Ende der Beiträge in der Steuertabelle in Zahlen
Dim StrToInt As New Collection
StrToInt.Add 1, "A"
StrToInt.Add 2, "B"
StrToInt.Add 3, "C"
StrToInt.Add 4, "D"
StrToInt.Add 5, "E"
StrToInt.Add 6, "F"
StrToInt.Add 7, "G"
StrToInt.Add 8, "H"
StrToInt.Add 9, "I"
StrToInt.Add 0, "ä"
'Dim B%
'If UF.TextBox1.Value = "" Then
B = 2
'Else
'B = UF.TextBox1.Value
'End If
'Letzte Zeile in der Steuertabelle
Dim lr%
'If UF.TextBox2.Value = "" Then
lr = tbl.Cells(tbl.Cells.Rows.Count, 17).End(xlUp).Row
'Else
'lr = UF.TextBox2.Value
'End If
Dim start, Messung As Double
start = Timer
Dim HTMLString As String
Dim JBB As String
Dim RSVBeitragZW$
Dim MS As MEMORYSTATUS
Dim t1 As Variant
Dim s%, z%
s = 1 'Schleifendurchläufe
z = lr - B + 1 'Anzahl der Mails
For i = B To lr
DoEvents
Sleep 1
Kdnr = tbl.Cells(i, 1)
VNAnrede = tbl.Cells(i, 2)
VNTitel = tbl.Cells(i, 3)
VNVorname = tbl.Cells(i, 4)
VNNachname = tbl.Cells(i, 5)
VNStrasse = tbl.Cells(i, 6)
VNPlz = tbl.Cells(i, 7)
VNOrt = tbl.Cells(i, 8)
VNTelPriv = tbl.Cells(i, 9)
VNTelGesch = tbl.Cells(i, 10)
VNGebDat = tbl.Cells(i, 11)
VNArt = tbl.Cells(i, 13)
AGTNr = tbl.Cells(i, 12)
Beginn = tbl.Cells(i, 14)
Ablauf = tbl.Cells(i, 15)
Sparte = tbl.Cells(i, 16)
Vsnr = tbl.Cells(i, 17)
Beitrag = tbl.Cells(i, 18)
Monatsfaelligkeit = tbl.Cells(i, 19)
Tagesfaelligkeit = tbl.Cells(i, 20)
Schadenzahl = tbl.Cells(i, 22)
Schadenhoehe = tbl.Cells(i, 23)
Saldoart = tbl.Cells(i, 24)
Saldohoehe = tbl.Cells(i, 25)
Mahnstufe = tbl.Cells(i, 26)
BeitragZW = tbl.Cells(i, 178)
ZW = tbl.Cells(i, 181)
ErstellDat = tbl.Cells(i, 182)
Ablauf2 = tbl.Cells(i, 183)
GEVO = tbl.Cells(i, 190)
TKlausel = tbl.Cells(i, 192)
AgtAnrede = tbl.Cells(i, 200)
AgtVorname = tbl.Cells(i, 201)
AgtNachname = tbl.Cells(i, 202)
AgtPnr = tbl.Cells(i, 203)
AgtGes = tbl.Cells(i, 204)
AgtMandant = tbl.Cells(i, 205)
AgtTel = tbl.Cells(i, 206)
AgtFax = tbl.Cells(i, 207)
AgtMail = tbl.Cells(i, 208)
With werte
.Range("AgenturNummer") = AGTNr
.Range("VNAnrede") = VNAnrede
.Range("VNTitel") = VNTitel
.Range("VNVorname") = VNVorname
.Range("VNVorname") = VNVorname
.Range("VNNachname") = VNNachname
.Range("VNStrasse") = VNStrasse
.Range("VNPlz") = VNPlz
.Range("VNOrt") = VNOrt
.Range("VNTelPriv") = VNTelPriv
.Range("VNTelGesch") = VNTelGesch
.Range("VNKundenNummer") = Kdnr
.Range("VNGeburtstag") = VNGebDat
.Range("RSVNummer") = Sparte & " " & Vsnr
.Range("RSVBeginn") = Beginn
.Range("RSVAblauf") = Ablauf
.Range("RSVZW") = ZW
RSVBeitragZW = Format(((Left(BeitragZW, 12) + (Mid(BeitragZW, 13, 1) / 10)_
+ (CInt(StrToInt(Mid(BeitragZW, 14, 1))) / 100))) * 116 / 100, "#,###.00")
.Range("RSVBeitragZW") = RSVBeitragZW
JBB = Format(RSVBeitragZW * CInt(ZW), "#,###.00")
.Range("RSVSaldo") = Saldoart & " " & Format((Left(Saldohoehe, 12) _
+ (Mid(Saldohoehe, 13, 1) / 10)), "#,##0.00")
.Range("RSVMahnstufe") = Mahnstufe
End With
HTMLString = "<html><body>" & _
ThisWorkbook.Sheets("Mailtext").Range("Agenturdaten") & _
ThisWorkbook.Sheets("Mailtext").Range("AllgemAnrede") & _
ThisWorkbook.Sheets("Mailtext").Range("VScheinDaten1") & _
ThisWorkbook.Sheets("Mailtext").Range("VScheinDaten2") & _
ThisWorkbook.Sheets("Mailtext").Range("AllgemSchluss") & _
"</body></html>"
DoEvents
Sleep 1
If werte.Range("AgenturSperre") = 0 Then
Application.StatusBar = "Sende Mail zu Vertrag " & Sparte & " " & Vsnr & "..."
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
.To = "test@testxyz.de"
.Subject = "Info " & " " & " " & VNNachname & ", Agt. " & AGTNr
.HTMLBody = HTMLString
DoEvents
Sleep 1
.Send
End With
End If
DoEvents
s = s + 1
Set objOutlookMsg = Nothing
DoEvents
If DateDiff("s", t1, Now) >= 60 Then
DoEvents
Sleep 5000
DoEvents
Sleep 1
DoEvents
Sleep 1
DoEvents
Sleep 1
t1 = Now
End If
DoEvents
Sleep 1
If (i - 1) Mod 100 = 0 Then
DoEvents
Sleep 100
DoEvents
Sleep 100
DoEvents
Sleep 100
'Outlook schließen...
objOutlook.Quit
Set objOutlook = Nothing
Sleep 7500
'...und wieder neu starten
On Error Resume Next
Err.Number = 0
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
'Outlook läuft noch nicht, muß gestartet werden
Set objOutlook = CreateObject("Outlook.Application")
Shell "outlook.exe", vbMinimizedNoFocus
End If
On Error GoTo 0
End If
Next i
Call Beep(750, 500)
Set objOutlook = Nothing
Application.StatusBar = ""
End Sub