|
Hallo an alle :)
Könnte mir jemand vielleicht sagen ob dieser code irgend einen Schaden verursachen kann. Ich hab immer den eindruck das excel immer langsammer wird je öfter ich ihn ausführe uund es gibt einen komischen fehler in dem teil der die Bottens entfernen soll. Manchmal bleiben sie in der per mail versendeteten kopie drin und ich hab keine achnung warum Bzw. wie kann ich ihn etwas Eleganter gestallten?
Sub Blatt_senden()
'** Das aktive Tabellenblatt wird ¸ber Outlook versendet
Dim strBlatt As String, strPfad As String
Dim strDatei As String, strBodyText As String, strSP As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
On Error GoTo Fehlermeldung
Dim outObj As Object
Dim Mail As Object
Set outObj = CreateObject("Outlook.Application")
Set Mail = outObj.CreateItem(0)
ThisWorkbook.Worksheets("Meldung").PageSetup.PrintArea = "B1:m" & Range("D500").End(xlUp).Row + 8
ThisWorkbook.Save
ActiveSheet.Unprotect ""
strSP = Date & "_" & ActiveSheet.Range("B1").Value
strPfad = "C:\TEMP"
strBlatt = ActiveSheet.Name
Sheets(strBlatt).Copy
ActiveWorkbook.SaveAs strPfad & "\" & strSP & ".xlsx"
ActiveSheet.Shapes.Range(Array("Schaltfl‰che 1")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Schaltfl‰che 2")).Select
Selection.Delete
strDatei = ActiveWorkbook.FullName
strBodyText = _
"Text Text Text"
With Mail
.To = "Mail@Adresse"
'.CC = ""
.Subject = strSP
.BodyFormat = 2
.Attachments.Add strDatei
.Body = strBodyText
End With
Workbooks(Dir(strDatei)).Close
Kill (strDatei)
Mail.send
ActiveSheet.Protect ""
Set Mail = Nothing
Set outObj = Nothing
Speichern_PFD
ThisWorkbook.Worksheets("Meldung").Range("A4:M250").ClearContents
MsgBox "E-Mail wurde gesendet." & vbCrLf & _
"Sie Finden die E-mail unter Gesendete in Outlook"
Exit Sub
Fehlermeldung:
MsgBox Err.Description & vbCrLf & "Mail an SP1 wurde NICHT gesendet"
Workbooks(Dir(strPfad & "\" & strSP & ".xlsx")).Close
Kill (strPfad & "\" & strSP & ".xlsx")
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function Speichern_PFD()
Dim DateiName As String, DateiName1 As String
Dim DSOb, oshell, wshnet, Benutzer, User
Dim Pfad, Verzeichnis, strUserprofile, ownfiles
Set DSOb = CreateObject("Scripting.FileSystemObject")
Set wshnet = CreateObject("wscript.network")
Set oshell = CreateObject("wscript.shell")
User = UCase(wshnet.UserName)
Benutzer = UCase(Right(wshnet.UserName, 3))
strUserprofile = oshell.ExpandEnvironmentStrings("%USERPROFILE%")
DateiName1 = "Name der Datei"
DateiName = Year(Now) & Format(Month(Now), "00") & Format(Day(Now), "00") _
& "_" & DateiName1 & ".pdf"
If DSOb.FolderExists(strUserprofile & "\documents\") Then
ownfiles = "documents"
Else
ownfiles = "eigene dateien"
End If
Pfad = oshell.ExpandEnvironmentStrings("%Userprofile%") & "\" & ownfiles & "\"
Set Verzeichnis = DSOb.GetFolder(Pfad)
DateiName = Pfad & DateiName
ActiveWorkbook.Sheets("Meldung").ExportAsFixedFormat xlTypePDF, _
DateiName, xlQualityMinimum, IncludeDocProperties:=False, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Set oshell = Nothing
Set wshnet = Nothing
Set DSOb = Nothing
End Function
Danke im Voraus
Gruß Simpel
|