Thema Datum  Von Nutzer Rating
Antwort
Rot Code verursacht Probleme
14.09.2015 17:58:09 Simpel
NotSolved

Ansicht des Beitrags:
Von:
Simpel
Datum:
14.09.2015 17:58:09
Views:
1610
Rating: Antwort:
  Ja
Thema:
Code verursacht Probleme

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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Code verursacht Probleme
14.09.2015 17:58:09 Simpel
NotSolved