Nevíte někdo co s tím.
Děkuji za každou pomoc. Přikládám kód i screen.
Kód: Vybrat vše
Sub ExcelOutlookPriloha()
Dim objNsp As Object, colSyc As Object, objSyc As Object, i As Integer, adresat As String, Soubor As String, SouborXLSM As String, Cely As Boolean, O As Object, Pripona As String
'!!!!!Před použitím je třeba v Tools / References zaškrtnout volbu Microsoft Outlook xx.0 Object Library.!!!!!
'Tools / References / Microsoft Outlook x.x Object Library
'Celý zošit = True, iba aktívny list = False
Cely = False
Sheets("Odesílání").Select
With ActiveSheet
With .Range("A1")
.Value = Now()
.NumberFormat = "d/m/yy h:mm;@"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'.Range("D37:D38").ClearContents
' Uložení souboru
Pripona = .Range("M1")
Soubor = "\" & .Range("K1") & " " & .Range("L1") & "." & Pripona
Select Case Pripona
Case "xlsx", "xlsm": SouborXLSM = Replace(Soubor, ".xlsx", ".xlsm")
With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
Select Case Cely
Case True: ThisWorkbook.SaveCopyAs SouborXLSM
If Pripona = "xlsx" Then
With Workbooks.Open(SouborXLSM)
.SaveAs Soubor, 51
.Close
End With
Kill SouborXLSM
End If
Case False: ActiveSheet.Copy
With ActiveWorkbook
If Pripona = "xlsx" Then .SaveAs Soubor, 51 Else .SaveAs SouborXLSM, 52
.Close
End With
End Select
With Application: .ScreenUpdating = True: .DisplayAlerts = False: End With
Case "pdf": If Cely Then Set O = ThisWorkbook Else Set O = ActiveSheet
O.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Soubor, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Select
End With
Sheets("ssss ").Select
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set objNsp = OutApp.Application.GetNamespace("MAPI") 'CORRECTION to Refer to the OutLook Application correctly
Set colSyc = objNsp.SyncObjects
adresat = "sss@sss.com"
With OutMail
'adresát
.To = adresat
'předmět zprávy
.Subject = "ssss"
'aktivní (uložený) sešit jako příloha
.Attachments.Add Soubor
'Nastavení preferovaného účtu pro odeslání pošty - v tomto případě druhý v pořadí
'Dostupné od verze Office 2007
.SendUsingAccount = OutApp.Session.Accounts.Item(1)
'odeslání zprávy
.Send
End With
For i = 1 To colSyc.Count
Set objSyc = colSyc.Item(i)
objSyc.Start
Next i
'Kill Soubor
'OutApp.Quit
MsgBox "Zpráva byla odeslána na adresu: " & ".", vbInformation 'adresat
'uvolnění z paměti
Set OutMail = Nothing: Set objNsp = Nothing: Set colSyc = Nothing: Set objSyc = Nothing: Set OutApp = Nothing: Set O = Nothing
End Sub
Dodatečně přidáno po 2 hodinách 53 minutách 39 vteřinách:
Tak jsem teď zjistil, že je to zaviněno Officem 2010. Nějak nespolupracuje s WIN 10. Takže téma uzavírám
