Option Explicit
Type my_Mail_structure
s_To As String
s_Subject As String
s_Body As String
s_Name As String
s_KW As String
s_Einheiten As String
s_Wert As String
End Type
'*** Blattbeschreibung
'Blattname
Const c_BLATTNAME = Abrechnungsmatrix
'Spalten
Const c_SP_Name = 1
Const c_SP_Email = 2
Const c_SP_KW1 = 3
'Zeilen
Const c_Z_UEBERSCHRIFTEN = 1
Const c_Z_ERSTENAME = 2
Const c_Z_LETZTERNAME = 19
'Umrechnungsfakto Einheit/Wert
Const c_UMRECHNUNGSFAKTOR_EINHEIT_WERT As Double = 0.25
Sub AbrechnugnsMails()
Dim ws As Worksheet
Dim f() As my_Mail_structure, f_cnt As Long
Dim b_test As Boolean->Schalter Test: True = Test
b_test = False->Schalter Test: True = Test, False= kein Test
->Auftragsfeld mail initialisieren
f_cnt = 0: ReDim Preserve f(1 To 1)
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets(c_BLATTNAME)
If Err.Number <> 0 Then
MsgBox (Blatt-> & c_BLATTNAME &-> nicht vorhanden.)
GoTo AUFRAEUMEN
End If
On Error GoTo 0
If Not AbrechnungsmailsAufbereiten(ws, f(), f_cnt) Then
MsgBox (Fehler in AbrechnungsmailsAufbereiten.)
GoTo AUFRAEUMEN
End If
If b_test Then
Call AbrechnungsdatenAlsMsgbox(f(), f_cnt)
Else
Call AbrechnungsdatenAlsMailUeberOutlook(f(), f_cnt)
End If
AUFRAEUMEN:
On Error GoTo 0
Set ws = Nothing
End Sub
'**************************************************************************
Private Function AbrechnungsdatenAlsMsgbox(f() As my_Mail_structure, f_cnt As Long)
Dim x As Long, s_Mldg As String
For x = 1 To f_cnt
s_Mldg = _
mail Nr. & x & vbLf & _
========= & vbLf & vbLf & _
To & vbTab & : & f(x).s_To & vbLf & _
Subject & vbTab & : & f(x).s_Subject & vbLf & _
Body & vbTab & : & vbLf & f(x).s_Body
MsgBox s_Mldg
Next
End Function
'**************************************************************************
Private Function AbrechnungsmailsAufbereiten(ws As Worksheet, _
f() As my_Mail_structure, _
f_cnt As Long) As Boolean
Dim l_col As Long, n As Long
AbrechnungsmailsAufbereiten = False
For n = c_Z_ERSTENAME To c_Z_LETZTERNAME
->Name leer ?
If ws.Cells(n, c_SP_Name).Value = Then GoTo NAECHSTERNAME
->neues Feldelement anlegen
f_cnt = f_cnt + 1: ReDim Preserve f(1 To f_cnt)
->Namen speichern
f(f_cnt).s_Name = ws.Cells(n, c_SP_Name).Value
->letzte KW suchen
l_col = ws.Cells(n, ws.Columns.Count).End(xlToLeft).Column
If l_col < c_SP_KW1 Then
MsgBox (Kein Verbrauchswert in Zeile & n)
GoTo AUFRAEUMEN
End If
->KW (aus Überschriftenzeile
f(f_cnt).s_KW = ws.Cells(c_Z_UEBERSCHRIFTEN, l_col).Value
->Einheiten
f(f_cnt).s_Einheiten = ws.Cells(n, l_col).Value
->Einheiten in Betrag umrechnen
On Error Resume Next
f(f_cnt).s_Wert = _
Format(f(f_cnt).s_Einheiten * c_UMRECHNUNGSFAKTOR_EINHEIT_WERT, 0.00) & ?
If Err.Number <> 0 Then
MsgBox (Der Verbrauchswert in Zeile & n & ist keine Zahl.)
GoTo AUFRAEUMEN
End If
On Error GoTo 0
->email leer ?
If ws.Cells(n, c_SP_Email).Value = Then
MsgBox (Kein Mail-Adresse in Zeile & n & vorhanden.)
GoTo AUFRAEUMEN
End If
->To
f(f_cnt).s_To = ws.Cells(n, c_SP_Email).Value
->Subject
f(f_cnt).s_Subject = Abrechnung - & f(f_cnt).s_Name & - & f(f_cnt).s_KW
->Text
f(f_cnt).s_Body = Du hast in & f(f_cnt).s_KW & & f(f_cnt).s_Einheiten & _
Einheiten verbraucht und musst dafür & f(f_cnt).s_Wert & _
zahlen. & vbLf & vbLf & _
Der Stromwart
NAECHSTERNAME:
Next
If f_cnt = 0 Then
MsgBox (Es sind keine Abrechnungsdaten vorhanden.)
GoTo AUFRAEUMEN
End If
AbrechnungsmailsAufbereiten = True
AUFRAEUMEN:
On Error GoTo 0
End Function