Hallo zusammen,
ich wurde leider im Net und auch in diversen foren nicht fündig. Nun hier meine Fragen an Euch:
Ich habe ein Workbook mit mehreren Sheets. Aus ausgewählten Sheets möchte ich jeweils die Druckbereiche als Excel workbook per email versenden.
Wie ich das mache indem ich die ganzen Sheets versende, habe ich hinbekommen. Aber dass nur jeweils der Druckbereich kopiert und versendet wird, klappt irgendwie nicht.
Mit .pagesetup.printarea habe ich bisher nur Fehlermeldungen erhalten.
Es wäre super wenn jemand von euch einen Tip hätte!
Mike
Hier ist mein code:
ich wurde leider im Net und auch in diversen foren nicht fündig. Nun hier meine Fragen an Euch:
Ich habe ein Workbook mit mehreren Sheets. Aus ausgewählten Sheets möchte ich jeweils die Druckbereiche als Excel workbook per email versenden.
Wie ich das mache indem ich die ganzen Sheets versende, habe ich hinbekommen. Aber dass nur jeweils der Druckbereich kopiert und versendet wird, klappt irgendwie nicht.
Mit .pagesetup.printarea habe ich bisher nur Fehlermeldungen erhalten.
Es wäre super wenn jemand von euch einen Tip hätte!
Mike
Hier ist mein code:
Quellcode
- Private Sub Button_versenden_Click()
- Dim FileExtStr As String
- Dim FileFormatNum As Long
- Dim Sourcewb As Workbook
- Dim Destwb As Workbook
- Dim TempFilePath As String
- Dim TempFileName As String
- Dim OutApp As Object
- Dim OutMail As Object
- Dim sh As Worksheet
- Dim TheActiveWindow As Window
- Dim TempWindow As Window
- With Application
- .ScreenUpdating = False
- .EnableEvents = False
- End With
- Set Sourcewb = ActiveWorkbook
- With Sourcewb
- Set TheActiveWindow = ActiveWindow
- Set TempWindow = .NewWindow
- TheActiveWindow.SelectedSheets.Copy
- End With
- With Destwb 'externe Verknüpfungen entfernen
- Dim Zelle As Range
- For Each Zelle In Worksheets(1).UsedRange
- If Left(Zelle.Formula, 1) = "=" And InStr(Zelle.Formula, "[") > 1 Then
- Zelle.Value = Zelle.Value
- End If
- Next Zelle
- End With
- TempWindow.Close
- Set Destwb = ActiveWorkbook
- 'Determine the Excel version and file extension/format
- With Destwb
- If Val(Application.Version) < 12 Then
- 'You use Excel 97-2003
- FileExtStr = ".xls": FileFormatNum = -4143
- Else
- 'You use Excel 2007-2013
- Select Case Sourcewb.FileFormat
- Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
- Case 52:
- If .HasVBProject Then
- FileExtStr = ".xlsm": FileFormatNum = 52
- Else
- FileExtStr = ".xlsx": FileFormatNum = 51
- End If
- Case 56: FileExtStr = ".xls": FileFormatNum = 56
- Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
- End Select
- End If
- End With
- TempFilePath = Environ$("temp") & "\"
- TempFileName = "Unterlagen " & Format(Now, "dd-mmm-yyyy hh-mm")
- Set OutApp = CreateObject("Outlook.Application")
- Set OutMail = OutApp.CreateItem(0)
- With Destwb
- .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
- On Error Resume Next
- With OutMail
- .To = ""
- .CC = ""
- .BCC = ""
- .Subject = "Unterlagen"
- .Body = "Siehe beiliegende Datei." & vbNewLine & .Signature
- .Attachments.Add Destwb.FullName
- .Display
- End With
- On Error GoTo 0
- .Close savechanges:=False
- End With
- Kill TempFilePath & TempFileName & FileExtStr
- Set OutMail = Nothing
- Set OutApp = Nothing
- With Application
- .ScreenUpdating = True
- .EnableEvents = True
- End With
- End Sub