Telepítettem a kutoolokat, hogy segítsek egy projektben. Kezelek egy nagyvállalati jelentést is, amelyben van egy makró, amely e-mailt hoz létre a megadott adatokból. Ez a makró leállt a számítógépemen. Azokon a számítógépeken működik, amelyeken nincs kutool. Futott már valaki ilyesmibe? Íme a makró, amely jól működik más számítógépeken:
Sub Mail_Sheet_Outlook_Body()
"Munka az Excel 2000-2016 között
Application.ReferenceStyle = xlA1
Dim rng As Range
Dim OutApp mint objektum
Dim OutMail As Object
Dim xFolder As String
Dim xSht Munkalapként
Dim xSub As String
Dim Response As String
Dim Msg As String
Dim Style As String
Dim Title As String
Állítsa be az xSht = ActiveSheet
Msg = "Biztosan el akarja küldeni ezt az űrlapot e-mailben?" ' Határozza meg az üzenetet.
Stílus = vbYesNo + vbCritical + vbDefaultButton2 ' Gombok meghatározása.
Title = "E-mail küldés megerősítése" ' Cím meghatározása.
Válasz = MsgBox (üzenet, stílus)
Ha Response = vbYes Akkor
xFolder = Környezet("FELHASZNÁLÓI PROFIL") + "\Desktop\" + "\Field Audit Form--" + CStr(xSht.Cells(19, "A").Érték) + "--.pdf"
'xSub = "Üzlet helyszíni ellenőrzése " + CStr(xSht.Cells(19, "A").Érték)
Alkalmazással
.EnableEvents = Hamis
.ScreenUpdating = Hamis
Vége
Set rng = Semmi
Set rng = ActiveSheet.UsedRange
'Használhat lapnevet is
'Set rng = Sheets("YourSheet").UsedRange
Set OutApp = CreateObject("Outlook.Application")
OutMail beállítása = OutApp.CreateItem(0)
Dim varCellvalue As Long
On Error Resume Next
OutMail segítségével
.To = ""
.CC = ""
.BCC = ""
.Subject = "Összefoglaló"
.Attachments.Add xFolder
.HTMLBody = RangetoHTML(rng)
.Display 'vagy használja .Display
Vége
Hiba történt GoTo 0
Alkalmazással
.EnableEvents = Igaz
.ScreenUpdating = Igaz
Vége
Set OutMail = Semmi
OutApp beállítása = Semmi
Ha véget
End Sub
Funkció RangetoHTML(rng As Range)
Munka az Office 2000-2016 között
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB munkafüzetként
TempFile = Environ$("temp") & "\" & Format(Now, "nn-mm-yy h-mm-ss") & ".htm"
„Másolja a tartományt, és hozzon létre egy új munkafüzetet az adatok beillesztéséhez
rng.Másolás
Set TempWB = Workbooks.Add(1)
A TempWB.Sheets(1) segítségével
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Válassza ki
Application.CutCopyMode = Hamis
On Error Resume Next
.DrawingObjects.Visible = Igaz
.DrawingObjects.Delete
Hiba történt GoTo 0
Vége
„Tegye közzé a lapot htm fájlban
A TempWB.PublishObjects.Add(_) segítségével
SourceType:=xlSourceRange, _
Fájlnév:=TempFile, _
Sheet:=TempWB.Sheets(1).Név, _
Forrás:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatikus)
.Publish (igaz)
Vége
Olvassa be az összes adatot a htm fájlból RangetoHTML-be
Állítsa be az fso = CreateObject ("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Bezárás
RangetoHTML = Csere(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Zárja be a TempWB-t
TempWB.Close savechanges:=Hamis
„Törölje az ebben a funkcióban használt htm fájlt
Öld meg a TempFile-t
Set ts = Semmi
Set fso = Semmi
Set TempWB = Semmi
end Function
Sub Mail_Sheet_Outlook_Body()
"Munka az Excel 2000-2016 között
Application.ReferenceStyle = xlA1
Dim rng As Range
Dim OutApp mint objektum
Dim OutMail As Object
Dim xFolder As String
Dim xSht Munkalapként
Dim xSub As String
Dim Response As String
Dim Msg As String
Dim Style As String
Dim Title As String
Állítsa be az xSht = ActiveSheet
Msg = "Biztosan el akarja küldeni ezt az űrlapot e-mailben?" ' Határozza meg az üzenetet.
Stílus = vbYesNo + vbCritical + vbDefaultButton2 ' Gombok meghatározása.
Title = "E-mail küldés megerősítése" ' Cím meghatározása.
Válasz = MsgBox (üzenet, stílus)
Ha Response = vbYes Akkor
xFolder = Környezet("FELHASZNÁLÓI PROFIL") + "\Desktop\" + "\Field Audit Form--" + CStr(xSht.Cells(19, "A").Érték) + "--.pdf"
'xSub = "Üzlet helyszíni ellenőrzése " + CStr(xSht.Cells(19, "A").Érték)
Alkalmazással
.EnableEvents = Hamis
.ScreenUpdating = Hamis
Vége
Set rng = Semmi
Set rng = ActiveSheet.UsedRange
'Használhat lapnevet is
'Set rng = Sheets("YourSheet").UsedRange
Set OutApp = CreateObject("Outlook.Application")
OutMail beállítása = OutApp.CreateItem(0)
Dim varCellvalue As Long
On Error Resume Next
OutMail segítségével
.To = ""
.CC = ""
.BCC = ""
.Subject = "Összefoglaló"
.Attachments.Add xFolder
.HTMLBody = RangetoHTML(rng)
.Display 'vagy használja .Display
Vége
Hiba történt GoTo 0
Alkalmazással
.EnableEvents = Igaz
.ScreenUpdating = Igaz
Vége
Set OutMail = Semmi
OutApp beállítása = Semmi
Ha véget
End Sub
Funkció RangetoHTML(rng As Range)
Munka az Office 2000-2016 között
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB munkafüzetként
TempFile = Environ$("temp") & "\" & Format(Now, "nn-mm-yy h-mm-ss") & ".htm"
„Másolja a tartományt, és hozzon létre egy új munkafüzetet az adatok beillesztéséhez
rng.Másolás
Set TempWB = Workbooks.Add(1)
A TempWB.Sheets(1) segítségével
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Válassza ki
Application.CutCopyMode = Hamis
On Error Resume Next
.DrawingObjects.Visible = Igaz
.DrawingObjects.Delete
Hiba történt GoTo 0
Vége
„Tegye közzé a lapot htm fájlban
A TempWB.PublishObjects.Add(_) segítségével
SourceType:=xlSourceRange, _
Fájlnév:=TempFile, _
Sheet:=TempWB.Sheets(1).Név, _
Forrás:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatikus)
.Publish (igaz)
Vége
Olvassa be az összes adatot a htm fájlból RangetoHTML-be
Állítsa be az fso = CreateObject ("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Bezárás
RangetoHTML = Csere(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Zárja be a TempWB-t
TempWB.Close savechanges:=Hamis
„Törölje az ebben a funkcióban használt htm fájlt
Öld meg a TempFile-t
Set ts = Semmi
Set fso = Semmi
Set TempWB = Semmi
end Function
Erre a bejegyzésre még nem válaszoltak.