vba - Missing hyperlinks when exporting from excel to email -
so starting working this, beginner. made macro allows me export excel sheet email when doing hyperlinks not exported. has ideea how fix this? here code:
sub mail_selection_range_outlook_body()
'working in excel 2000-2016 dim rng range dim outapp object dim outmail object
set rng = nothing on error resume next set rng = selection.specialcells(xlcelltypevisible) on error goto 0 if rng nothing msgbox "the selection not range or sheet protected" & _ vbnewline & "please correct , try again.", vbokonly exit sub end if application .enableevents = false .screenupdating = false end set outapp = createobject("outlook.application") set outmail = outapp.createitem(0) on error resume next outmail .to = "maria@domain.com" .cc = "" .bcc = "" .subject = "this subject line" .htmlbody = rangetohtml(rng) .display end on error goto 0 application .enableevents = true .screenupdating = true end set outmail = nothing set outapp = nothing
end sub
function rangetohtml(rng range)
dim fso object dim ts object dim tempfile string dim tempwb workbook tempfile = environ$("temp") & "\" & format(now, "dd-mm-yy h-mm-ss") & ".htm" rng.copy set tempwb = workbooks.add(1) 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 tempwb.publishobjects.add( _ sourcetype:=xlsourcerange, _ filename:=tempfile, _ sheet:=tempwb.sheets(1).name, _ source:=tempwb.sheets(1).usedrange.address, _ htmltype:=xlhtmlstatic) .publish (true) end 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
Comments
Post a Comment