Hi there,
I have an excel file with many hyperlinks and until now I always had to copy and paste the range manually into a mail and send it. Now I tried to get a macro working, which basically does the same.
It sends mails, copies the right range but the hyperlinks open in Internet Explorer, normally they should open the Windows Explorer and direct it to a folder.
If I copy & paste manually everything works fine.
Here's the macro
I have an excel file with many hyperlinks and until now I always had to copy and paste the range manually into a mail and send it. Now I tried to get a macro working, which basically does the same.
It sends mails, copies the right range but the hyperlinks open in Internet Explorer, normally they should open the Windows Explorer and direct it to a folder.
If I copy & paste manually everything works fine.
Here's the macro
Code:
Option Explicit
Sub MailBodyDialog()
Dim rng As Range
Dim olapp As Object
Dim WsShell
Set olapp = CreateObject("Outlook.Application")
With olapp.CreateItem(0)
.HtmlBody = RangetoHTML(Range("A1:T6")) 'Bereich, der im HTML-Body angezeigt werden soll
.To = "marcel.riedel@volkswagen.de" 'Empfänger
.cc = "" 'optional Kopie an
'.bcc = "mail1@server.de,mail2@server.de,mail3@server.de" 'optional Blindkopie an
'.ReadReceiptRequested = True ' optional Lesbestätigung anfordern
.Subject = "offene ÄKOs vom " & Date
.Display
Rem Email sofort senden
Set WsShell = CreateObject("WScript.Shell")
WsShell.AppActivate olapp
WsShell.SendKeys "%s"
Set WsShell = Nothing
End With
End Sub
'
'
'Function RangetoHTML(rng As Range)
'Rem Diese Funktion darf nicht verändert werden
' 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"
' 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 = True
' On Error GoTo 0
' End With
' 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
' 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=")
' TempWB.Close savechanges:=False
' Kill TempFile
' Set ts = Nothing
' Set fso = Nothing
' Set TempWB = Nothing
'End Function
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-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 new workbook to past the data in
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
'~~~~~~~~~~~~~~~~~~~~ ADDED THIS ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim HyperL As Hyperlink
For Each HyperL In rng.Hyperlinks
TempWB.Sheets(1).Hyperlinks.Add _
Anchor:=TempWB.Sheets(1).Range(HyperL.Range.Address), _
Address:=HyperL.Address, _
TextToDisplay:=HyperL.TextToDisplay
Next HyperL
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'Publish the sheet to a 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 RangetoHTML
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 we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function