Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Sub Mail_Sheets_Array()
- 'Working in Excel 2000-2016
- 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
- 'Copy the sheets to a new workbook
- 'We add a temporary Window to avoid the Copy problem
- 'if there is a List or Table in one of the sheets and
- 'if the sheets are grouped
- With Sourcewb
- Set TheActiveWindow = ActiveWindow
- Set TempWindow = .NewWindow
- .Sheets(Array("REC_INT", "REC_EXT")).Copy
- End With
- 'Close temporary Window
- 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-2016
- 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
- ' 'Change all cells in the worksheets to values if you want
- ' For Each sh In Destwb.Worksheets
- ' sh.Select
- ' With sh.UsedRange
- ' .Cells.Copy
- ' .Cells.PasteSpecial xlPasteValues
- ' .Cells(1).Select
- ' End With
- ' Application.CutCopyMode = False
- ' Destwb.Worksheets(1).Select
- ' Next sh
- 'Save the new workbook/Mail it/Delete it
- TempFilePath = Environ$("temp") & ""
- TempFileName = "Part of " & Sourcewb.name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
- 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 = "hadi@siemens.com"
- .CC = ""
- .BCC = ""
- .Subject = "This is the Subject line"
- .Body = "Hi there"
- .Attachments.Add Destwb.FullName
- 'You can add other files also like this
- '.Attachments.Add ("C:test.txt")
- '.Send 'or use
- .Display
- End With
- On Error GoTo 0
- .Close savechanges:=False
- End With
- 'Delete the file you have send
- Kill TempFilePath & TempFileName & FileExtStr
- Set OutMail = Nothing
- Set OutApp = Nothing
- With Application
- .ScreenUpdating = True
- .EnableEvents = True
- End With
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement