Schreibschutz bei kopieren, speichern, mailen

Sub Blatt_senden() Sheets("Rechnung").Copy ActiveWorkbook.SaveCopyAs Filename:="G:\Rechnungen\" & ThisWorkbook.Name Application.Dialogs(xlDialogSendMail).Show Application.DisplayAlerts = True ActiveWindow.Close Application.DisplayAlerts = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Christiane,
ich habe es so geregelt. Ist aber nicht die Superlösung:


Sub Makro1()
Sheets("Rechnung").Select
Cells.Select
Selection.Copy
Workbooks.Add
Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
pfadname = "G:\Rechnungen\" & ThisWorkbook.Name
Range("a1").Select
ActiveWorkbook.SaveAs Filename:=pfadname
Dim objExcelWD As Excel.Window
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim intRow As Integer, intCounter As Integer
Dim strFile As String, strFile2 As String, strRecipient As String, strSubject As String
Dim bolStatusBar
bolStatusBar = Application.DisplayStatusBar
Set objOutlook = CreateObject("Outlook.Application")
strRecipient = "Dein Empfänger@Mail.de"
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
Set objOutlookRecip = .Recipients.Add(strRecipient)
objOutlookRecip.Type = olTo
Set objOutlookAttach = .Attachments.Add(pfadname)
On Error Resume Next
.Subject = "Dein Betreff"
objOutlookRecip.Resolve
End With
Set objOutlook = Nothing
objOutlookMsg.Display
Application.StatusBar = False
Application.DisplayStatusBar = bolStatusBar
ActiveWorkbook.Close
Kill pfadname
Application.DisplayAlerts = False
Application.Quit
End Sub

Gruß
marcl

Sub Blatt_senden() On Error GoTo Terminator Application.ScreenUpdating = False Dim shtName As String shtName = ActiveSheet.Name Sheets("Rechnung").Copy ActiveWorkbook.SaveAs Filename:=Application.GetSaveAsFilename("Copy of " & _ ThisWorkbook.Name, "Microsoft Excel-Arbeitsmappe, *.xls") Application.DisplayAlerts = False Application.Dialogs(xlDialogSendMail).Show With ActiveWorkbook .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With Terminator: Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Sub Blatt_senden() On Error GoTo Terminator Application.ScreenUpdating = False Dim shtName As String shtName = ActiveSheet.Name Sheets("Rechnung").Copy Const Pfad As String = "g:\Arbeitsdaten\Rechnungen\" ActiveWorkbook.SaveAs Filename:=Application.GetSaveAsFilename("Copy of " & _ ThisWorkbook.Name, "Microsoft Excel-Arbeitsmappe, *.xls") Application.DisplayAlerts = False Application.Dialogs(xlDialogSendMail).Show With ActiveWorkbook .Close False End With Terminator: Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

Schreibschutz bei kopieren, speichern, mailen

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Schreibschutz bei kopieren, speichern, mailen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread