Here is my code below for a program that opens a user interface, lists all the names of tabs in the spreadsheet in a list box. By selecting an item (or sheet name) in the list box then clicking ‘email’ a specific area of that selected sheet is sent to an email address located on the sheet.
What I would like to have happen is with the click of a button email each sheet to the specified email address. So if there were 100 sheets rather than clicking on each name then clicking email, have one button to email the each individual sheet to the associated email address. I am guessing something like a ‘For’ loop would be required but am not quite sure how to implement.
Please help…
(I hope the above is understood)
What I would like to have happen is with the click of a button email each sheet to the specified email address. So if there were 100 sheets rather than clicking on each name then clicking email, have one button to email the each individual sheet to the associated email address. I am guessing something like a ‘For’ loop would be required but am not quite sure how to implement.
Please help…
(I hope the above is understood)
Code:
Private Sub CommandButton2_Click()
ActiveWorkbook.Close
End Sub
Private Sub ListBox1_Click()
'this will set the label caption depending on which sheet is selected in the list box
Label1.Caption = Sheets(ListBox1.Value).Range("b2").Value
End Sub
Private Sub CommandButton1_Click()
Dim r As Long
Dim c As Long
With Worksheets(ListBox1.Value).Range("b1:h18")
ListBox2.List = .Value
For r = 1 To .Rows.Count
For c = 1 To .Columns.Count
ListBox2.List(r - 1, c - 1) = .Cells(r, c).Text
Next c
Next r
End With
End Sub
Private Sub Email_Click()
Application.ScreenUpdating = False
'for each item selection do the following
Sheets(ListBox1.Value).Activate
Sheets(ListBox1.Value).Range("b1:h18").Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
Columns("a").ColumnWidth = 22
Columns("b:h").ColumnWidth = 12
Range("A1").Select
ChDir "C:\temp"
ActiveWorkbook.SaveAs Filename:="C:\temp\Scorecard.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
Application.Run ("SendWithLotus")
ActiveWorkbook.Close
Kill "C:\temp\Scorecard.xls"
'repeat up to here
End Sub
Private Sub UserForm_Initialize()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Visible = xlSheetVisible Then
ListBox1.AddItem ws.Name
End If
Next ws
TextBox1 = ListBox1.Value
End Sub
-----------------------------------
Sub SendWithLotus()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim obAttachment As Object, EmbedObject As Object
Dim stSubject As Variant, stAttachment As String
Dim vaRecipient As String
Dim vaMsg As Variant
Const EMBED_ATTACHMENT As Long = 1454
Const stTitle As String = "Active workbook status"
Const stMsg As String = "The active workbook must first be saved " & vbCrLf _
& "before it can be sent as an attachment."
'Check if the active workbook is saved or not
'If the active workbook has not been saved at all.
If Len(ActiveWorkbook.Path) = 0 Then
MsgBox stMsg, vbInformation, stTitle
Exit Sub
End If
'If the changes in the active workbook have been saved or not.
If ActiveWorkbook.Saved = False Then
If MsgBox("Do you want to save the changes before sending?", _
vbYesNo + vbInformation, stTitle) = vbYes Then _
ActiveWorkbook.Save
End If
'Get the name of the recipient from the user.
'Do
vaRecipient = Range("a1")
'Application.InputBox( _
'Prompt:="Please add name of the recipient such as:" & vbCrLf _
'& "johnqpublictest@hotmail.com", _
'Title:="Recipient", Type:=2)
'Loop While vaRecipient = ""
'If the user has canceled the operation.
'If vaRecipient = False Then Exit Sub
'Get the message from the user.
Do
vaMsg = Application.InputBox( _
Prompt:="Please enter the message such as:" & vbCrLf _
& "'Enclosed please find the weekly report.'", _
Title:="Message", Type:=2)
Loop While vaMsg = ""
'If the user has canceled the operation.
If vaMsg = False Then Exit Sub
'Add the subject to the outgoing e-mail
'which also can be retrieved from the users
'in a similar way as above.
Do
stSubject = Application.InputBox( _
Prompt:="Please add a subject such as:" & vbCrLf _
& "'Weekly Report.'", _
Title:="Subject", Type:=2)
Loop While stSubject = ""
'Retrieve the path and filename of the active workbook.
stAttachment = ActiveWorkbook.FullName
'Instantiate the Lotus Notes COM's Objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
Set obAttachment = noDocument.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
'Add values to the created e-mail main properties.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
.Body = vaMsg
.SaveMessageOnSend = True
End With
'Send the e-mail.
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
'Release objects from the memory.
Set EmbedObject = Nothing
Set obAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
AppActivate "Microsoft Excel"
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End Sub
