Senden und Speichern Tabellenblatt
05.05.2008 13:58:37
Mazilu
habe ein für mich unlösbares Problem. Ich möchte per Makro eine Datei speichern und danach per E-Mail senden. Dabei soll jedoch nur das Tabellenblatt "Formular" ohne die Makros versendet werden um Speicherplatz zu sparen.
Habe dafür folgendes Makro:
Leider versendet es die Ausgangsdatei mit 3 MB und das ist zuviel das Tabellenblatt hat nur 300 KB
Sub speichern_senden()
ActiveSheet.Unprotect
'Datei speichern
Dim varPfad As Variant
If Workbooks.Count = 0 Then Exit Sub
On Error Resume Next
Sheets("formular").Range("A6").Select
varPfad = Application.GetSaveAsFilename(Date & "_" & Hour(Time) & "." & Minute(Time) & "." & _
Second(Time) & "_" & [AJ6] & ".XLS")
If varPfad = False Then
Exit Sub
End If
If Dir(varPfad) "" Then
MsgBox "Die Datei " & varPfad & " existiert bereits." & vbNewLine & vbNewLine & "Bitte _
wiederholen Sie den Vorgang und vergeben Sie einen anderen Dateinamen oder wählen Sie einen _
anderen Ordner.", vbOKOnly + vbInformation, "Datei existiert"
Exit Sub
End If
If optBlattSpeichern.Value = True Then
ActiveSheet.Copy
If chkMakrosWeg.Value = True Then Alle_Makros_löschen
ActiveWorkbook.SaveAs varPfad
Else
ActiveWorkbook.SaveAs varPfad
Workbooks.Open varPfad
If chkMakrosWeg.Value = True Then
Alle_Makros_löschen
End If
ActiveWorkbook.Save
End If
If MsgBox("Reisekostenabrechnung an Finance zur Archivierung schicken?" & vbNewLine & "Bitte _
beachte: die Abrechnung kann nur bearbeitet werden, wenn" & vbNewLine & vbNewLine & "1. Auf _
jedem Belege, die Belegnummer aus der Belegerfassung steht" & vbNewLine & "2. Bewirtungsbelege alle erforderlichen Angaben enthalten (siehe FAQ´s)" & vbNewLine & "3. Alle Belege auf Papier aufgeklebt wurden" & vbNewLine & vbNewLine & "VIELEN DANK!" & vbNewLine & vbNewLine & "Bitte diese Anforderungen mit JA bestätigen!", vbYesNo) = vbYes Then
'Datei per E-Mail versenden
Dim outl, Mail As Object
AktDatei = ActiveWorkbook.Name
Set outl = CreateObject("Outlook.Application")
Set Mail = outl.CreateItem(0)
Mail.Subject = AktDatei
Mail.To = "Christian.Mazilu@ciao-group.com"
'Wichtigkeit Hoch (1 = normal, 0 = niedrig)
Mail.Importance = 0
'Standardtext
Mail.Body = "Hallo Kollegen!" & vbCrLf & vbCrLf & _
"Neue Reisekostenabrechnung! Bitte archivieren." & vbCrLf & vbCrLf & _
"Vielen Dank!" & vbCrLf & vbCrLf & _
"xxx" & vbCrLf & vbCrLf
'oder: die aktive Exceldatei als Anhang mitsenden...
Mail.Attachments.Add ThisWorkbook.FullName
'Mail anzeigen
Mail.Display
'Ein sofortiger Mail-Versand geht in Firmen wegen Sicherheitseinstellungen oft nicht:
'Mail.Send
'aber es gibt eine Lösung mit SendKeys per Windows Scripting Host (Verweis ins VB-Projekt _
einfügen!):
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
WshShell.AppActivate Mail
'Sendet ein "Alt-S", Outlook sendet Mail sofort ohne Sicherheitsabfrage:
WshShell.SendKeys ("%s")
Set Mail = Nothing
Set outl = Nothing
Set WshShell = Nothing
Else
Exit Sub
End If
'Datei drucken
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub Alle_Makros_löschen() 'Für das Versenden des Übersichtsblattes
ActiveSheet.Unprotect
Dim objKompo As Object
On Error Resume Next
With ActiveWorkbook.VBProject
For Each objKompo In .VBComponents
Select Case objKompo.Type
Case 1, 2, 3
.VBComponents.Remove .VBComponents(objKompo.Name)
Case 100
With objKompo.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next
End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Vielen DAnk!
Gruß
Christian