Advertisement
Guest User

Untitled

a guest
Jul 18th, 2019
114
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 3.13 KB | None | 0 0
  1. Sub Mail_Sheets_Array()
  2. 'Working in Excel 2000-2016
  3.  
  4. Dim FileExtStr As String
  5. Dim FileFormatNum As Long
  6. Dim Sourcewb As Workbook
  7. Dim Destwb As Workbook
  8. Dim TempFilePath As String
  9. Dim TempFileName As String
  10. Dim OutApp As Object
  11. Dim OutMail As Object
  12. Dim sh As Worksheet
  13. Dim TheActiveWindow As Window
  14. Dim TempWindow As Window
  15.  
  16. With Application
  17. .ScreenUpdating = False
  18. .EnableEvents = False
  19. End With
  20.  
  21. Set Sourcewb = ActiveWorkbook
  22.  
  23. 'Copy the sheets to a new workbook
  24. 'We add a temporary Window to avoid the Copy problem
  25. 'if there is a List or Table in one of the sheets and
  26. 'if the sheets are grouped
  27. With Sourcewb
  28. Set TheActiveWindow = ActiveWindow
  29. Set TempWindow = .NewWindow
  30. .Sheets(Array("REC_INT", "REC_EXT")).Copy
  31. End With
  32.  
  33. 'Close temporary Window
  34. TempWindow.Close
  35.  
  36. Set Destwb = ActiveWorkbook
  37.  
  38. 'Determine the Excel version and file extension/format
  39. With Destwb
  40. If Val(Application.Version) < 12 Then
  41. 'You use Excel 97-2003
  42. FileExtStr = ".xls": FileFormatNum = -4143
  43. Else
  44. 'You use Excel 2007-2016
  45. Select Case Sourcewb.FileFormat
  46. Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
  47. Case 52:
  48. If .HasVBProject Then
  49. FileExtStr = ".xlsm": FileFormatNum = 52
  50. Else
  51. FileExtStr = ".xlsx": FileFormatNum = 51
  52. End If
  53. Case 56: FileExtStr = ".xls": FileFormatNum = 56
  54. Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
  55. End Select
  56. End If
  57. End With
  58.  
  59. ' 'Change all cells in the worksheets to values if you want
  60. ' For Each sh In Destwb.Worksheets
  61. ' sh.Select
  62. ' With sh.UsedRange
  63. ' .Cells.Copy
  64. ' .Cells.PasteSpecial xlPasteValues
  65. ' .Cells(1).Select
  66. ' End With
  67. ' Application.CutCopyMode = False
  68. ' Destwb.Worksheets(1).Select
  69. ' Next sh
  70.  
  71. 'Save the new workbook/Mail it/Delete it
  72. TempFilePath = Environ$("temp") & ""
  73. TempFileName = "Part of " & Sourcewb.name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
  74.  
  75. Set OutApp = CreateObject("Outlook.Application")
  76. Set OutMail = OutApp.CreateItem(0)
  77.  
  78. With Destwb
  79. .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
  80. On Error Resume Next
  81. With OutMail
  82. .To = "hadi@siemens.com"
  83. .CC = ""
  84. .BCC = ""
  85. .Subject = "This is the Subject line"
  86. .Body = "Hi there"
  87. .Attachments.Add Destwb.FullName
  88. 'You can add other files also like this
  89. '.Attachments.Add ("C:test.txt")
  90. '.Send 'or use
  91. .Display
  92. End With
  93. On Error GoTo 0
  94. .Close savechanges:=False
  95. End With
  96.  
  97. 'Delete the file you have send
  98. Kill TempFilePath & TempFileName & FileExtStr
  99.  
  100. Set OutMail = Nothing
  101. Set OutApp = Nothing
  102.  
  103. With Application
  104. .ScreenUpdating = True
  105. .EnableEvents = True
  106. End With
  107. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement