Új hozzászólás Aktív témák

• #14694 lappy őstag zhari #14692

  Új Válasz 2012-08-22 11:14:42 #14694

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  lappy

  őstag

  válasz zhari #14692 üzenetére

  Sub CallMailer()
  
  Dim lngLoop As Long 'Programming ethics 1. Always start your first line after leaving a line space, and 1 indentation level
  
  With ActiveSheet
  For lngLoop = 2 To .Cells(Rows.Count, 1).End(xlUp).Row ' Programming ethics 3. Always indent your loops, case statements and with constructors
  Call SendMessage(strTo:=.Cells(lngLoop, 1).Value, strCC:=.Cells(lngLoop, 2).Value, strBCC:=.Cells(lngLoop, 7).Value, strMessage:=.Cells(lngLoop, 8).Value, strSubject:=.Cells(lngLoop, 3).Value, strAttachmentPath:=.Cells(lngLoop, 6).Value, rngToCopy:=.Cells(lngLoop, 9))
  Next lngLoop
  End With 'Programming ethics 2. Always end your last line leaving a line space before ending the sub or function, and having indendation level of 1
  
  End Sub
  
  Sub SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional strAttachmentPath As String, Optional rngToCopy As Range, Optional blnShowEmailBodyWithoutSending As Boolean = False)
  
  Dim objOutlook As Outlook.Application
  Dim objOutlookMsg As Outlook.MailItem
  Dim objOutlookRecip As Outlook.Recipient
  Dim objOutlookAttach As Outlook.Attachment
  
  If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
  MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
  Exit Sub
  End If
  ' Create the Outlook session.
  On Error Resume Next
  Set objOutlook = GetObject(, "Outlook.Application")
  Err.Clear: On Error GoTo -1: On Error GoTo 0
  If objOutlook Is Nothing Then
  Set objOutlook = CreateObject("Outlook.Application")
  End If
  
  ' Create the message.
  Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
  
  With objOutlookMsg
  ' Add the To recipient(s) to the message.
  If Trim(strTo) <> "" Then
  Set objOutlookRecip = .Recipients.Add(strTo)
  objOutlookRecip.Type = olTo
  End If
  
  ' Add the CC recipient(s) to the message.
  If Trim(strCC) <> "" Then
  Set objOutlookRecip = .Recipients.Add(strCC)
  objOutlookRecip.Type = olCC
  End If
  
  ' Add the BCC recipient(s) to the message.
  If Trim(strBCC) <> "" Then
  Set objOutlookRecip = .Recipients.Add(strBCC)
  objOutlookRecip.Type = olBCC
  End If
  
  ' Set the Subject, Body, and Importance of the message.
  If strSubject = "" Then
  strSubject = "This is an Automation test with Microsoft Outlook"
  End If
  .Subject = strSubject
  If strMessage = "" Then
  strMessage = "This is the body of the message." & vbCrLf & vbCrLf
  End If
  .Importance = olImportanceHigh 'High importance
  If Not strMessage = "" Then
  .Body = strMessage & vbCrLf & vbCrLf
  End If
  If Not rngToCopy Is Nothing Then
  .HTMLBody = .Body & RangetoHTML(rngToCopy)
  End If
  
  ' Add attachments to the message.
  If Not IsMissing(strAttachmentPath) Then
  If Len(Dir(strAttachmentPath)) <> 0 Then
  Set objOutlookAttach = .Attachments.Add(strAttachmentPath)
  Else
  MsgBox "Unable to find the specified attachment. Sending mail anyway."
  End If
  End If
  
  ' Resolve each Recipient's name.
  For Each objOutlookRecip In .Recipients
  objOutlookRecip.Resolve
  Next
  
  ' Should we display the message before sending?
  If blnShowEmailBodyWithoutSending Then
  .Display
  Else
  .Save
  .Send
  End If
  End With
  
  Set objOutlook = Nothing
  Set objOutlookMsg = Nothing
  Set objOutlookAttach = Nothing
  Set objOutlookRecip = Nothing
  
  End Sub
  
  Function RangetoHTML(rng As Range)
  
  ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
  Dim fso As Object
  Dim ts As Object
  Dim TempFile As String
  Dim TempWB As Workbook
  
  TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  
  ' Copy the range and create a workbook to receive the data.
  rng.Copy
  Set TempWB = Workbooks.Add(1)
  With TempWB.Sheets(1)
  .Cells(1).PasteSpecial Paste:=8
  .Cells(1).PasteSpecial xlPasteValues, , False, False
  .Cells(1).PasteSpecial xlPasteFormats, , False, False
  .Cells(1).Select
  Application.CutCopyMode = False
  On Error Resume Next
  .DrawingObjects.Visible = True
  .DrawingObjects.Delete
  On Error GoTo 0
  End With
  
  ' Publish the sheet to an .htm file.
  With TempWB.PublishObjects.Add( _
  SourceType:=xlSourceRange, _
  Filename:=TempFile, _
  Sheet:=TempWB.Sheets(1).Name, _
  Source:=TempWB.Sheets(1).UsedRange.Address, _
  HtmlType:=xlHtmlStatic)
  .Publish (True)
  End With
  
  ' Read all data from the .htm file into the RangetoHTML subroutine.
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.ReadAll
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
  "align=left x:publishsource=")
  
  ' Close TempWB.
  TempWB.Close savechanges:=False
  
  ' Delete the htm file.
  Kill TempFile
  
  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
  
  End Function

Új hozzászólás Aktív témák