chiellebeest
Gebruiker
- Lid geworden
- 5 jan 2010
- Berichten
- 86
Ik heb een macro waarmee ik een overzicht mail. Ik heb in Outlook meerdere emailadressen, ik heb in de macro aangeven welk adres er gebruikt moet worden, helaas gebeurd dit niet.
[/CODE]
Code:
' 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
Function GetOutlookAccount(objOutlook As Object, strEmailId As String) As Object
Dim objOAccount As Object
For Each objOAccount In objOutlook.Session.Accounts
If objOAccount.DisplayName = strEmailId Then
Set GetOutlookAccount = objOAccount
Exit For
End If
Next objOAccount
End Function
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Sub Create_Mail_List()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim cell As Range
Dim strto As String
Dim strbody As String
Dim SigString As String
Dim mailaccount As Object
Dim objOutlook As Object
Dim objoutlookaccount As Object
For Each cell In ThisWorkbook.Sheets("Blad1").Range("e2:e50")
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
Application.ScreenUpdating = False
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("Blad1").Range("f2:f3").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
strbody = "<BODY style=font-size:11pt;font-family:Calibri>Hallo allemaal,</BODY>"
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Chiel.htm"
'Change only Mysig.htm to the name of your signature
'de map signatures heet soms handtekeningen
SigString = Environ("appdata") & _
"\Microsoft\Handtekeningen\Chiel.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
Set objOutlook = CreateObject("Outlook.Application")
Set objoutlookaccount = GetOutlookAccount(objOutlook, "Chiel@chiel.nl")
With objOutlook.CreateItem(0)
Set .sendusingaccount = objoutlookaccount
.display
.BCC = strto
.Subject = Range("H2")
.HTMLbody = strbody & RangetoHTML(rng) & .HTMLbody
.display 'Or use send.
End With
On Error GoTo 0
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Laatst bewerkt:
