Forum

Send just page one ...
 
Notifications
Clear all

Send just page one of active sheet by email

17 Posts
4 Users
0 Reactions
306 Views
(@bogi)
Posts: 9
Active Member
Topic starter
 

Hi

I have following code and want to add to the code that just page one of the sheet will be sent in te email. Is there somene 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

 
Posted : 20/08/2020 4:31 am
(@purfleet)
Posts: 412
Reputable Member
 

What do you mean by only 1 page? how is the sheet formatted?

Its always best to add an example file so we know what you want and how stuff looks

 
Posted : 20/08/2020 1:22 pm
(@bogi)
Posts: 9
Active Member
Topic starter
 

Hi

I mean just sending the first page of the sheet

The button to send the mail is on the second page and I don`t want include that page to the sheet that is sent by the e-mail

 
Posted : 21/08/2020 1:33 am
(@rhysand)
Posts: 80
Trusted Member
 

Hello,

It would be easier to copy all the data of the rows and columns that you want to send by email and paste in a new sheet and from there send the email,

but I will leave here a way to identify the first page break, I hope I can help.

for this example I used a command button to call the page break identification procedure

Private Sub CommandButton1_Click()

Dim Wsheet As Worksheet
Dim HorizontalPageBreak As HPageBreak
Dim VerticalPageBreak As VPageBreak
Dim rng As Range

Set Wsheet = ActiveSheet ' OR CHANGE TO ANY SHEET NAME YOU WANT: Application.ThisWorkbook.Worksheets ("Sheet1")

' FOR HORIZONTAL PAGE BREAK
For Each HorizontalPageBreak In Wsheet.HPageBreaks
     Debug.Print HorizontalPageBreak.Location.Address
Next HorizontalPageBreak

' FOR VERTICAL PAGE BREAK
For Each VerticalPageBreak In Wsheet.VPageBreaks
     Debug.Print VerticalPageBreak.Location.Address
Next VerticalPageBreak

' FIRST PAGE BREAK IS ALWAYS (1) ... FOR SECOND PAGE BREAK IS (2) ... etc
Set rng = Wsheet.Range(Wsheet.HPageBreaks(1).Location.Offset(-1, 0), Wsheet.VPageBreaks(1).Location.Offset(0, -1))
Debug.Print rng.Address

rng.Select

MsgBox "All ranges of the page break: " & rng.Address

If Not Wsheet Is Nothing Then Set Wsheet = Nothing
If Not rng Is Nothing Then Set rng = Nothing

End Sub



Once the first page break is identified and selected, you can use it to copy this data or send...

Miguel,



 
Posted : 21/08/2020 5:46 am
(@bogi)
Posts: 9
Active Member
Topic starter
 

Hi

Miguel

Thanks for Your help. I think you are right that it is easier to copy rows and columns to New sheet, also because many cells in the sheet contains link to another sheet in the same Workbook.

Do you have the oppertunity to help me to Write the code for copy rows and columns and send by Outlook mail ?

Thanks for Your help

Bogi

 
Posted : 21/08/2020 6:14 am
(@purfleet)
Posts: 412
Reputable Member
 

As mentioned earlier - if you add an example workbook we can see what we are dealing with and it makes writting the code much easier

 
Posted : 21/08/2020 12:12 pm
(@bogi)
Posts: 9
Active Member
Topic starter
 

Hi

Her is the Attached file

In the sheet "Rep skjema" are information linked from the sheet "Generell informasjon"

I would like to send the sheet "Rep skjema" by e-mail without teh code, button and links if possible.

The code for sending the e-mail are linked to the button "Send to Nav" which is located on page 2 in the sheet "Rep Skjema"

Hope you can help to modify the code 🙂

 
Posted : 22/08/2020 1:17 am
Philip Treacy
(@philipt)
Posts: 1629
Member Admin
 

No file attached.

Instructions on attaching a file

https://www.myonlinetraininghub.com/excel-forum/forum-rules-and-guides/read-this-first

 
Posted : 22/08/2020 1:18 am
(@bogi)
Posts: 9
Active Member
Topic starter
 

Hi again

Forgot to Attached the file

 
Posted : 22/08/2020 2:50 am
(@purfleet)
Posts: 412
Reputable Member
 

If it just the button you want to remove then add in

ActiveSheet.Shapes.Range(Array("CommandButton1")).Delete

after the

Set Wb2 = ActiveWorkbook

 
Posted : 22/08/2020 9:22 am
(@bogi)
Posts: 9
Active Member
Topic starter
 

Thanks. This was very helpful.

Is it possible to also send the sheet without the code and the links to the other sheets?

 
Posted : 22/08/2020 9:52 am
(@rhysand)
Posts: 80
Trusted Member
 

Hello,

the Purfleet method is correct, but if you don't want to remove the command button, you can simply make it invisible at the beginning of the procedure and visible at the end
and as there is no more data on your excel sheet below line 53, there is no reason to copy and paste it on another sheet...

Something similar to this:

Application.ThisWorkbook.Worksheets("Rep skjema").Activate
Application.ThisWorkbook.Worksheets("Rep skjema").CommandButton1.Visible = False

&

Application.ThisWorkbook.Worksheets("Rep skjema").Activate
Application.ThisWorkbook.Worksheets("Rep skjema").CommandButton1.Visible = True


I highlighted the changes in blue, I tested it with my outlook and it worked perfectly


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

Application.ThisWorkbook.Worksheets("Rep skjema").Activate
Application.ThisWorkbook.Worksheets("Rep skjema").CommandButton1.Visible = False

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 = "ADD YOUR EMAIL HERE"
     .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

With Application
     .ScreenUpdating = True
     .EnableEvents = True
End With

Application.ThisWorkbook.Worksheets("Rep skjema").Activate
Application.ThisWorkbook.Worksheets("Rep skjema").CommandButton1.Visible = True

End Sub


Miguel,


 
Posted : 22/08/2020 1:38 pm
(@rhysand)
Posts: 80
Trusted Member
 

Hello,

Yes and for that you need to change the CommandButton of the sheet, instead of inserting an Active X control (CommandButton), a control (CommandButton) of the form must be inserted in sheet...

the code instead of being in the sheet module, must be inserted as macro in a module and sign / link the macro to shape (CommandButton control).

I attached a workbook with an example, added a userform that you can delete, just to illustrate how to get the name of the shapes and controls in the excel sheet and how the visible and invisible control works.

I tested it with my outlook and it worked perfectly, I made changes to the macro for this new control (hide or show) to send email.

 

Miguel,

 
Posted : 23/08/2020 5:03 am
(@bogi)
Posts: 9
Active Member
Topic starter
 

Hi Miguel

Thanks. It Works perfectly!

Just a last question. Is it possible to "kill" the links as well. The person who will receive this sheet shall fill in cell "H8" and "F35" and sendt it back to me by e-mail. When the person open the sheet he get this Message: "We cant`t update some links in your workbook right now. You can continue without opdating their values, or edit the links you think are wrong. "Continue"  "Edit Links..."And then the person who receive the mail have to click on "Continue"

It will be fantastic if it is possible to kill the links in the sheet as well so the sheet that is sendt is free for links.

I appreciate Your help very much

 
Posted : 23/08/2020 6:47 am
(@rhysand)
Posts: 80
Trusted Member
 

Hello,

in your code, change this part, I highlighted in blue what to add in the code

...

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

If Not IsEmpty(Wb2.LinkSources(xlExcelLinks)) Then
      For Each Link In Wb2.LinkSources(xlExcelLinks)
           Wb2.BreakLink Link, xlLinkTypeExcelLinks
      Next Link
End If

End With

...

 

Miguel,

 
Posted : 23/08/2020 9:49 am
Page 1 / 2
Share: