VBA, html Format

Option Private Module
Public Sub ForumAnfrage()
Call unprotectwspv
'Abfrage Range wscount
Dim wscountRange As String
wscountRange = "BH13:BH3999"
'zählen ob Zeile markiert ist
Dim wscount As Integer
wscount = WorksheetFunction.CountIf(Range(wscountRange), "=x")
If wscount > 1 Then
MsgBox "zu viele Zellen gewählt!" & vbCr & vbCr & "!!! Abbruch der Operation !!!"
Call protectwspv
Exit Sub
End If
If wscount -------------
'
Dim sBox As String
Dim iRow As Integer
For iRow = 13 To 3999
If Cells(iRow, zMailanTobi) = "x" Then
sBox = "ini_KundePVKontrolle"
End If
'
'
Dim sEmail_Address As String
If Cells(iRow, zMailanTobi) = "x" Then
sEmail_Address = Worksheets("Tabelle2").Cells(3, 16).Value
End If
Dim sEmail_Name As String
If Cells(iRow, zMailanTobi) = "x" Then
sEmail_Name = Worksheets("Tabelle2").Cells(4, 16).Value
End If
Dim sKName As String
If Cells(iRow, zMailanTobi) = "x" Then
sKName = Cells(iRow, zKName).Value
End If
Dim sKTelefon As String
If Cells(iRow, zMailanTobi) = "x" Then
sKTelefon = Cells(iRow, zKTelefon).Value
End If
Dim sKMail As String
If Cells(iRow, zMailanTobi) = "x" Then
sKMail = Cells(iRow, zKMail).Value
End If
Dim sKAdresse As String
If Cells(iRow, zMailanTobi) = "x" Then
sKAdresse = Cells(iRow, zKAdresse).Value
End If
Dim sAErrichter As String
If Cells(iRow, zMailanTobi) = "x" Then
sAErrichter = Cells(iRow, zAErrichter).Value
End If
Dim sAEMail As String
If Cells(iRow, zMailanTobi) = "x" Then
sAEMail = Cells(iRow, zAEMail).Value
End If
Dim sAETelefon As String
If Cells(iRow, zMailanTobi) = "x" Then
sAETelefon = Cells(iRow, zAETelefon).Value
End If
Dim sAZModule As String
If Cells(iRow, zMailanTobi) = "x" Then
sAZModule = Cells(iRow, zAZModule).Value & " x"
End If
Dim sALModule As String
If Cells(iRow, zMailanTobi) = "x" Then
If Cells(iRow, zAbfragePV) = "mini PV" Then sALModule = Cells(iRow, zALModule).Value & " Wp"
If Not Cells(iRow, zAbfragePV) = "mini PV" Then sALModule = Cells(iRow, zALModule).Value & " Wp"
End If
Dim sAGModule As String
If Cells(iRow, zMailanTobi) = "x" Then
If Cells(iRow, zAbfragePV) = "mini PV" Then sAGModule = Cells(iRow, zAGModule).Value & " Wp"
If Not Cells(iRow, zAbfragePV) = "mini PV" Then sAGModule = Cells(iRow, zAGModule).Value & " kWp"
End If
Dim sAWeri As String
If Cells(iRow, zMailanTobi) = "x" Then
If Cells(iRow, zAbfragePV) = "mini PV" Then sAWeri = Cells(iRow, zAWeRi).Value & " W"
If Not Cells(iRow, zAbfragePV) = "mini PV" Then sAWeri = Cells(iRow, zAWeRi).Value & " kW"
End If
Dim sZaehler As String
If Cells(iRow, zMailanTobi) = "x" Then
sZaehler = Cells(iRow, zZaehler).Value
End If
Dim sTrafo As String
If Cells(iRow, zMailanTobi) = "x" Then
sTrafo = Cells(iRow, zTrafo).Value
End If
Dim sUW As String
If Cells(iRow, zMailanTobi) = "x" Then
sUW = Cells(iRow, zUW).Value
End If
Dim sZusatztext As String
If Cells(iRow, zMailanTobi) = "x" Then
sZusatztext = Cells(iRow, zZusatztext).Value
End If
Dim sDatumAngelegt As String
If Cells(iRow, zMailanTobi) = "x" Then
sDatumAngelegt = Cells(iRow, zDatumAngelegt).Value
End If
Dim sTitle As String
If Cells(iRow, zMailanTobi) = "x" Then
sTitle = "Anlagenkontrolle PV" & " // " & Sheets("PV").Cells(iRow, zKAdresse) & " // " & Sheets("PV").Cells(iRow, zKName)
End If
Dim sAttachment As String
If Cells(iRow, zMailanTobi) = "x" Then
sAttachment = Cells(iRow, zAttachment).Value
End If
If Cells(iRow, zMailanTobi) = "x" Then
MsgBox "Anlagenkontrolle PV" & vbCr & vbCr & sKAdresse & vbCr & "Kd: " & sKName & vbCr & vbCr & "OK klicken E-Mail wird erstellt"
End If
Next
'
'
Dim sHTML As String
sHTML = ""
Dim bChange As Boolean
Dim intColor As Long
intColor = 0
Dim intRed As Long, intGreen As Long, intBlue As Long
Dim sFontName As String
sFontName = ""
Dim sFontSize As String
sFontSize = ""
Dim sUnderline As String
sUnderline = ""
Dim bBold As Integer
bBold = 0
'------------
Dim varChar
For Each varChar In Sheets(sBox).Shapes("Textbox1").TextFrame2.TextRange.Characters
'--------
bChange = False
'
Dim char_Text As String
char_Text = varChar.Text
Dim char_FontName As String
char_FontName = varChar.Font.Name
Dim char_FontSize As String
char_FontSize = varChar.Font.Size
Dim char_Underline As String
char_Underline = varChar.Font.UnderlineStyle
Dim char_RGB As Long
char_RGB = varChar.Font.Fill.ForeColor.RGB
Dim char_Bold As Integer
char_Bold = varChar.Font.Bold
' get Character >
'
If Not sFontName Like char_FontName Then
bChange = True
sFontName = char_FontName
End If
' Font >
'
If Not sFontSize Like char_FontSize Then
bChange = True
sFontSize = char_FontSize
End If
' FontSize >
'
If Not sUnderline Like char_Underline Then
bChange = True
sUnderline = char_Underline
End If
' Underline >
'
If Not intColor Like char_RGB Then
bChange = True
intColor = char_RGB
intRed = (intColor And &HFF) \ 256 ^ 0      ' &HFF hexadecimal = 255 decimal
intGreen = (intColor And &HFF00&) \ 256 ^ 1   ' &HFF00& hexadecimal = 65280 decimal
intBlue = intColor \ 256 ^ 2
End If
' Color >
'
If Not bBold Like char_Bold Then
bChange = True
bBold = char_Bold
End If
' Bold >
'
char_Text = Replace(char_Text, vbCrLf, "
")
char_Text = Replace(char_Text, vbLf, "
")
' Korrekturen >
'
If bChange Then
sHTML = sHTML & ""
sHTML = sHTML & vbCrLf & " 0 Then
sHTML = sHTML & " font-weight:font-weight: bold;"
Else
sHTML = sHTML & " font-weight:font-weight: normal;"
End If
sHTML = sHTML & """>"
End If
' Formatierung HTML >
'
sHTML = sHTML & char_Text
' Text_anfuegen >
Next
'
sHTML = sHTML & ""
' Korrektur >
'- init >-
Dim ws As Worksheet
Set ws = ActiveSheet    'with button
'--
Dim sText As String
sText = sHTML       '*VorlageText aus _Text
sText = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(sText, "[@Name]", sEmail_Name), "[@KName]", sKName), "[@KTelefon]", sKTelefon), "[@KMail]", sKMail), "[@KAdresse]", sKAdresse), "[@AErrichter]", sAErrichter), "[@AZModule]", sAZModule), "[@ALModule]", sALModule), "[@AGModule]", sAGModule), "[@AWeri]", sAWeri), "[@KZaehler]", sZaehler), "[@Trafo]", sTrafo), "[@UW]", sUW), "[@AEMail]", sAEMail), "[@AETelefon]", sAETelefon), "[@Zusatztext]", sZusatztext), "[@DatumAngelegt]", sDatumAngelegt)
'---- Send with Outlook >----
'----
'On Error Resume Next ignoriert fehler
Dim app_Outlook As Object
Set app_Outlook = CreateObject("Outlook.Application")
Dim objEmail As Object
Set objEmail = app_Outlook.CreateItem(0)
objEmail.To = sKMail
objEmail.Subject = sTitle
objEmail.BodyFormat = 2 '* 1=Text olFormatPlain, 2=olFormatHTML, 3=olFormatRichText
objEmail.HTMLBody = sText  '*.HTMLBody for HTML
objEmail.Display False
'// Attachment wird nur ausgeführt wenn die variable sAttachment gefüllt ist
If (sAttachment  ““) Then objEmail.Attachments.Add sAttachment
'objEmail.Attachments.Add sAttachment // nimmt das Attachment und gibt Fehler aus wenn nicht vorhanden
'objEmail.Send
'-- Send Email >--
'    '
Set objEmail = Nothing
Set app_Outlook = Nothing
'   
'Variable für Timestamp
Dim zUser As Integer
zUser = "85"
Dim zAnTL As Integer
zAnTL = "82"
Dim zAnKunde As Integer
zAnKunde = "83"
Dim zAnKontrolle As Integer
zAnKontrolle = "84"
For iRow = 13 To 3999
Dim sUser As String
sUser = Application.UserName
If Cells(iRow, zMailanTobi) = "x" Then
Cells(iRow, zUser) = sUser
Cells(iRow, zUser).Replace ",*", "", xlPart
End If
If Cells(iRow, zMailanTobi) = "x" Then
If Cells(iRow, zUser) = "c" Then
Cells(iRow, zUser) = "BC"
sUser = "BC"
End If
End If
If Cells(iRow, zMailanTobi) = "x" Then
If Cells(iRow, zUser) = "k" Then
Cells(iRow, zUser) = "TK"
sUser = "TK"
End If
End If
Dim sDatum As Date
If Cells(iRow, zMailanTobi) = "x" Then
sDatum = Now
End If
If Cells(iRow, zMailanTobi) = "x" Then
Cells(iRow, zAnKontrolle) = sUser & " | " & WorksheetFunction.Text(sDatum, "dd.mm. | hh:mm") & " h"
End If
Next
Sheets("PV").Range(wscountRange).ClearContents
Call protectwspv
End Sub