Sobota, 01 2018 září
  0 Odpovědi
  2.6 tis. Návštěv
Nainstaloval jsem kutools, abych pomohl s projektem práce. Spravuji také velký firemní report, který má makro vytvářející e-mail ze zadaných informací. To makro na mém počítači přestalo fungovat. Funguje na počítačích, které nemají kutools. Setkal se už někdo s něčím takovým? Zde je makro, které funguje dobře na jiných počítačích:

Sub Mail_Sheet_Outlook_Body()
'Práce v Excelu 2000-2016
Application.ReferenceStyle = xlA1
Dim Rng As Range
Ztlumit OutApp jako objekt
Dim OutMail As Object
Dim xFolder jako řetězec
Dim xSht jako pracovní list
Dim xSub jako řetězec
Tlumená odezva jako řetězec
Dim Msg As String
Dim Style As String
Ztlumit název jako řetězec

Nastavit xSht = ActiveSheet
Msg = "Opravdu chcete odeslat tento formulář e-mailem?" ' Definujte zprávu.
Styl = vbYesNo + vbCritical + vbDefaultButton2 ' Definice tlačítek.
Název = "Potvrzení odeslání e-mailem" ' Definujte název.
Odpověď = MsgBox (Zpráva, Styl)

If Response = vbYes Then
xFolder = Environ("USERPROFILE") + "\Desktop\" + "\Formulář auditu pole--" + CStr(xSht.Cells(19, "A").Value) + "--.pdf"
'xSub = "Audit pole pro obchod " + CStr(xSht.Cells(19, "A").Value)
S aplikací
.EnableEvents = False
.ScreenUpdating = False
Konec s

Nastavit rng = nic
Set rng = ActiveSheet.UsedRange
„Můžete také použít název listu
'Set rng = Sheets("YourSheet").UsedRange

Set OutApp = CreateObject("Outlook.Application")
Nastavit OutMail = OutApp.CreateItem(0)
Dim varCellvalue As Long




On Error Resume Next
S OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Rekapitulace"
.Přílohy.Přidat xFolder
.HTMLBody = RangetoHTML(rng)
.Zobrazte 'nebo použijte .Display

Konec s
Při chybě GoTo 0

S aplikací
.EnableEvents = True
.ScreenUpdating = True
Konec s

Nastavte OutMail = nic
Nastavte OutApp = Nic
End If
End Sub


Funkce RangetoHTML(rng As Range)
" Práce v Office 2000-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB jako sešit

TempFile = Environ$("temp") & "\" & Format(Nyní, "dd-mm-yy h-mm-ss") & ".htm"

'Zkopírujte rozsah a vytvořte nový sešit, do kterého vložíte data
rng.Kopírovat
Nastavit TempWB = Workbooks.Add(1)
S TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Buňky(1).Vybrat
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = Pravda
.DrawingObjects.Delete
Při chybě GoTo 0
Konec s

'Publikujte list do souboru htm
S TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Název souboru:=TempFile, _
List:=TempWB.Sheets(1).Název, _
Zdroj:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publikovat (pravda)
Konec s

'Přečíst všechna data ze souboru htm do RangetoHTML
Nastavit fso = CreateObject ("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Zavřít
RangetoHTML = Nahradit(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Zavřít TempWB
TempWB.Close savechanges:=False

'Smažte soubor htm, který jsme použili v této funkci
Kill TempFile
Nastavit ts = nic
Nastavit fso = nic
Nastavte TempWB = nic

End Function
Na tento příspěvek zatím nebyly učiněny žádné odpovědi.