Send just one page from Active sheet by email

%3CLINGO-SUB%20id%3D%22lingo-sub-1598272%22%20slang%3D%22en-US%22%3ESend%20just%20one%20page%20from%20Active%20sheet%20by%20email%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-1598272%22%20slang%3D%22en-US%22%3E%3CP%3EHi%3C%2FP%3E%3CP%3EI%20have%20following%20code%20that%20I%20want%20to%20change%3C%2FP%3E%3CP%3EI%20would%20like%20to%20add%20to%20the%20code%20that%20just%20page%201%20of%20the%20sheet%20should%20be%20sent.%20Is%20there%20someone%20who%20can%20help%3F%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3E%26nbsp%3B%3C%2FP%3E%3CP%3EPrivate%20Sub%20CommandButton1_Click()%3CBR%20%2F%3E%3CBR%20%2F%3EDim%20OlApp%20As%20Object%3CBR%20%2F%3EDim%20NewMail%20As%20Object%3CBR%20%2F%3EDim%20TempFilePath%20As%20String%3CBR%20%2F%3EDim%20FileExt%20As%20String%3CBR%20%2F%3EDim%20TempFileName%20As%20String%3CBR%20%2F%3EDim%20FileFullPath%20As%20String%3CBR%20%2F%3EDim%20FileFormat%20As%20Variant%3CBR%20%2F%3EDim%20Wb1%20As%20Workbook%3CBR%20%2F%3EDim%20Wb2%20As%20Workbook%3CBR%20%2F%3E%3CBR%20%2F%3EWith%20Application%3CBR%20%2F%3E.ScreenUpdating%20%3D%20False%3CBR%20%2F%3E.EnableEvents%20%3D%20False%3CBR%20%2F%3EEnd%20With%3CBR%20%2F%3ESet%20Wb1%20%3D%20ThisWorkbook%3CBR%20%2F%3EActiveSheet.Copy%3CBR%20%2F%3ESet%20Wb2%20%3D%20ActiveWorkbook%3CBR%20%2F%3E%3CBR%20%2F%3EWith%20Wb2%3CBR%20%2F%3EIf%20Val(Application.Version)%20%26lt%3B%2012%20Then%3CBR%20%2F%3EFileExt%20%3D%20%22.xls%22%3A%20FileFormat%20%3D%20-4143%3CBR%20%2F%3EElse%3CBR%20%2F%3ESelect%20Case%20Wb1.FileFormat%3CBR%20%2F%3ECase%2051%3A%20FileExt%20%3D%20%22.xlsx%22%3A%20FileFormat%20%3D%2051%3CBR%20%2F%3ECase%2052%3A%3CBR%20%2F%3EIf%20.HasVBProject%20Then%3CBR%20%2F%3EFileExt%20%3D%20%22.xlsm%22%3A%20FileFormat%20%3D%2052%3CBR%20%2F%3EElse%3CBR%20%2F%3EFileExt%20%3D%20%22.xlsx%22%3A%20FileFormat%20%3D%2051%3CBR%20%2F%3EEnd%20If%3CBR%20%2F%3ECase%2056%3A%20FileExt%20%3D%20%22.xls%22%3A%20FileFormat%20%3D%2056%3CBR%20%2F%3ECase%20Else%3A%20FileExt%20%3D%20%22.xlsb%22%3A%20FileFormat%20%3D%2050%3CBR%20%2F%3EEnd%20Select%3CBR%20%2F%3EEnd%20If%3CBR%20%2F%3EEnd%20With%3CBR%20%2F%3E%3CBR%20%2F%3ETempFilePath%20%3D%20Environ%24(%22temp%22)%20%26amp%3B%20%22%5C%22%3CBR%20%2F%3E%3CBR%20%2F%3ETempFileName%20%3D%20ActiveSheet.Name%20%26amp%3B%20%22-%22%20%26amp%3B%20Format(Now%2C%20%22dd-mmm-yy%20h-mm-ss%22)%3CBR%20%2F%3E%3CBR%20%2F%3EFileFullPath%20%3D%20TempFilePath%20%26amp%3B%20TempFileName%20%26amp%3B%20FileExt%3CBR%20%2F%3E%3CBR%20%2F%3EWb2.SaveAs%20FileFullPath%2C%20FileFormat%3A%3DFileFormat%3CBR%20%2F%3E%3CBR%20%2F%3E%3CBR%20%2F%3ESet%20OlApp%20%3D%20CreateObject(%22Outlook.Application%22)%3CBR%20%2F%3ESet%20NewMail%20%3D%20OlApp.CreateItem(0)%3CBR%20%2F%3E%3CBR%20%2F%3EOn%20Error%20Resume%20Next%3CBR%20%2F%3EWith%20NewMail%3CBR%20%2F%3E.To%20%3D%20%22%20receiver%22%3CBR%20%2F%3E.CC%20%3D%20%22%22%3CBR%20%2F%3E.Subject%20%3D%20%22Ident%22%3CBR%20%2F%3E.Body%20%3D%20%22Kan%20dere%20vennligst%20sende%20Ident%22%3CBR%20%2F%3E.Attachments.Add%20FileFullPath%3CBR%20%2F%3E.Display%3CBR%20%2F%3EEnd%20With%3CBR%20%2F%3EOn%20Error%20GoTo%200%3CBR%20%2F%3E%3CBR%20%2F%3EWb2.Close%20SaveChanges%3A%3DFalse%3CBR%20%2F%3EKill%20FileFullPath%3CBR%20%2F%3E%3CBR%20%2F%3ESet%20NewMail%20%3D%20Nothing%3CBR%20%2F%3ESet%20OlApp%20%3D%20Nothing%3CBR%20%2F%3E%3CBR%20%2F%3E'Now%20set%20the%20application%20properties%20back%20to%20true%3CBR%20%2F%3EWith%20Application%3CBR%20%2F%3E.ScreenUpdating%20%3D%20True%3CBR%20%2F%3E.EnableEvents%20%3D%20True%3CBR%20%2F%3EEnd%20With%3C%2FP%3E%3CP%3EEnd%20Sub%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-1598272%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E
Regular Visitor

Hi

I have following code that I want to change

I would like to add to the code that just page 1 of the sheet should be sent. Is there someone who can help?

 

 

Private Sub CommandButton1_Click()

Dim OlApp As Object
Dim NewMail As Object
Dim TempFilePath As String
Dim FileExt As String
Dim TempFileName As String
Dim FileFullPath As String
Dim FileFormat As Variant
Dim Wb1 As Workbook
Dim Wb2 As Workbook

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Wb1 = ThisWorkbook
ActiveSheet.Copy
Set Wb2 = ActiveWorkbook

With Wb2
If Val(Application.Version) < 12 Then
FileExt = ".xls": FileFormat = -4143
Else
Select Case Wb1.FileFormat
Case 51: FileExt = ".xlsx": FileFormat = 51
Case 52:
If .HasVBProject Then
FileExt = ".xlsm": FileFormat = 52
Else
FileExt = ".xlsx": FileFormat = 51
End If
Case 56: FileExt = ".xls": FileFormat = 56
Case Else: FileExt = ".xlsb": FileFormat = 50
End Select
End If
End With

TempFilePath = Environ$("temp") & "\"

TempFileName = ActiveSheet.Name & "-" & Format(Now, "dd-mmm-yy h-mm-ss")

FileFullPath = TempFilePath & TempFileName & FileExt

Wb2.SaveAs FileFullPath, FileFormat:=FileFormat


Set OlApp = CreateObject("Outlook.Application")
Set NewMail = OlApp.CreateItem(0)

On Error Resume Next
With NewMail
.To = " receiver"
.CC = ""
.Subject = "Ident"
.Body = "Kan dere vennligst sende Ident"
.Attachments.Add FileFullPath
.Display
End With
On Error GoTo 0

Wb2.Close SaveChanges:=False
Kill FileFullPath

Set NewMail = Nothing
Set OlApp = Nothing

'Now set the application properties back to true
With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub

0 Replies