Private
Sub
BeinaheunfallVerteilen_Click()
Worksheets(
"Beinaheunfall"
).Range(
"E3"
).Value =
Me
.ComboBox1.Value
Worksheets(
"Beinaheunfall"
).Range(
"A5"
) = TextBoxBeinaheunfallVorname
Worksheets(
"Beinaheunfall"
).Range(
"E5"
) = TextBoxBeinaheunfallNachname
Worksheets(
"Beinaheunfall"
).Range(
"A7"
) = TextBoxBeinaheunfallMaschine
Worksheets(
"Beinaheunfall"
).Range(
"E7"
) = TextBoxBeinaheunfallAbteilung
Worksheets(
"Beinaheunfall"
).Range(
"A10"
) = TextBoxBeinaheunfallUnfallhergang
Worksheets(
"Beinaheunfälle"
).Cells(Cells(Rows.Count,
"A"
).
End
(xlUp).Row + 1,
"A"
).Value = TextBoxBeinaheUnfallDatum
Worksheets(
"Beinaheunfälle"
).Cells(Cells(Rows.Count,
"B"
).
End
(xlUp).Row + 1,
"B"
).Value = ComboBox1
Worksheets(
"Beinaheunfälle"
).Cells(Cells(Rows.Count,
"C"
).
End
(xlUp).Row + 1,
"C"
).Value = TextBoxBeinaheunfallVorname
Worksheets(
"Beinaheunfälle"
).Cells(Cells(Rows.Count,
"D"
).
End
(xlUp).Row + 1,
"D"
).Value = TextBoxBeinaheunfallNachname
Worksheets(
"Beinaheunfälle"
).Cells(Cells(Rows.Count,
"E"
).
End
(xlUp).Row + 1,
"E"
).Value = TextBoxBeinaheunfallMaschine
Worksheets(
"Beinaheunfälle"
).Cells(Cells(Rows.Count,
"F"
).
End
(xlUp).Row + 1,
"F"
).Value = TextBoxBeinaheunfallAbteilung
Worksheets(
"Beinaheunfälle"
).Cells(Cells(Rows.Count,
"G"
).
End
(xlUp).Row + 1,
"G"
).Value = TextBoxBeinaheunfallUnfallhergang
ChDir "C:\Temp\"
Worksheets(
"Beinaheunfall"
).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Temp\Beinaheunfall.pdf"
Dim
sText
As
String
, sEmpfang
As
String
, sBetrifft
As
String
Dim
session
As
Object
, db
As
Object
, doc
As
Object
, rtobject
As
Object
Dim
rtitem
As
Object
, sKopie
As
String
Dim
AttachMe
As
Object
, DerAnhang
As
Object
Dim
user
As
String
, server
As
String
Dim
mailfile
As
String
, sBlindKopie
As
String
Dim
vAn
As
Variant
, vCopy
As
Variant
Dim
vBlind
As
Variant
, sAnhang
As
String
On
Error
GoTo
Fehler
sText =
"Diese eMail wurde automatisch generiert und dient der Informationspflicht des SGA-Managementbeauftragten an die Zentrale."
& vbCrLf &
"Bei Fragen wenden Sie sich bitte an den Absender."
sText = Replace(sText, vbCrLf, Chr(10))
sEmpfang =
"christoph.friedrich@scherdel.com"
sBetrifft =
"Beinaheunfall"
sKopie =
""
sBlindKopie =
""
vAn = Split(sEmpfang,
" ; "
)
sAnhang =
"C:\Temp\Beinaheunfall.pdf"
If
Len(sKopie) > 0
Then
vCopy = Split(sKopie,
" ; "
)
If
Len(sBlindKopie) > 0
Then
vBlind = Split(sBlindKopie,
" ; "
)
Set
session = CreateObject(
"notes.notessession"
)
user = session.UserName
server = session.GetEnvironmentString(
"MailServer"
,
True
)
mailfile = session.GetEnvironmentString(
"MailFile"
,
True
)
Set
db = session.getdatabase(server, mailfile)
Set
doc = db.createdocument()
doc.Form =
"Memo"
doc.SendTo = vAn
If
Len(sKopie) > 0
Then
doc.copyto = vCopy
If
Len(sBlindKopie) > 0
Then
doc.blindcopyto = vBlind
doc.Subject = sBetrifft
Set
rtitem = doc.CREATERICHTEXTITEM(
"body"
)
Call
rtitem.APPENDTEXT(sText)
doc.SAVEMESSAGEONSEND =
True
doc.PostedDate = Now
If
sAnhang <>
""
Then
Set
AttachMe = doc.CREATERICHTEXTITEM(
"Attachment"
)
Set
DerAnhang = AttachMe.EMBEDOBJECT(1454,
""
, sAnhang,
"Attachment"
)
End
If
Worksheets(
"Beinaheunfall"
).Range(
"A3:D3,E3:H3,A7:D7,E7:H7,A10:H44"
).ClearContents
Call
doc.Send(
False
)
Aufraeumen:
On
Error
Resume
Next
Set
rtitem =
Nothing
Set
AttachMe =
Nothing
Set
DerAnhang =
Nothing
Set
db =
Nothing
Set
doc =
Nothing
Set
session =
Nothing
Kill
"C:\Temp\Beinaheunfall.pdf"
Unload UserformBeinaheunfall
Exit
Sub
Fehler:
Resume
Aufraeumen
End
Sub
Private
Sub
UserForm_Activate()
Me
.TextBoxBeinaheUnfallDatum.Text = Worksheets(
"Beinaheunfall"
).Range(
"A3"
).Value
End
Sub