Úprava kodu pro odeslání pdf. Vyřešeno

[luko02420]

Dobrý den, potreboval bych poradit jak upravit kod aby mi jako priloha odesílal sobor ve formatu pdf. Nemuzu na to prijit.
Tak jak to mam ted tak vse funguje, ale chtel bych odesilat prave pdf. Prosim neukamenujte me za ten ruzne poskladaný kod. V kodu sice je jina příloha nez je sesit excelu ale nemuzu prijit na to jak pdf nacist do prilohy.Dekuji vsem.

Kód: Vybrat vše

Sub ExcelOutlookPriloha()
    '!!!!!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
   
    Range("C39").Select
    ActiveCell.FormulaR1C1 = "=NOW()"
    Range("C39").Select
    Selection.NumberFormat = "d/m/yy h:mm;@"
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("L24").Select
    Range("D37").Value = ""
    Range("D38").Value = ""
   
    ' Uložení souboru
   
    jmeno = Range("L1") 'Jméno
    jmeno1 = Range("C35") 'Datum jako jmeno souboru
    jmeno2 = Range("M2") 'přípona souboru
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "I:\\" & jmeno1 & (" " & jmeno & jmeno2), Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

    MsgBox "" & jmeno
   
    'Dim OutApp As Outlook.Application
    'Dim OutMail As Outlook.MailItem
    Dim objNsp As Object
    Dim colSyc As Object
    Dim objSyc As Object
    Dim i As Integer
    Dim adresat As String
   
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(olMailItem)
    Set objNsp = OutApp.Application.GetNamespace("MAPI")  'CORRECTION to Refer to the OutLook Application correctly
    Set colSyc = objNsp.SyncObjects
   
    adresat = ""
   
    With OutMail
   
        'adresát
        .To = adresat
       
        'kopie pro
        '.CC = "schranka@email.com"
       
        'skrytá kopie pro
        '.BCC = ""
       
        'předmět zprávy
        .Subject = ""
       
        'text zprávy a určení buňky
       
       
        'aktivní (uložený) sešit jako příloha
        .Attachments.Add ActiveWorkbook.FullName
       
        '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)

        'jiná příloha
        '.Attachments.Add ActiveWorkbook.Path & "\soubor.pdf"
       
        'zobrazení okna se zprávou (není nutné)
        '.Display
       
        'odeslání zprávy
        .Send
       
    End With
   
    For i = 1 To colSyc.Count
        Set objSyc = colSyc.Item(i)
        objSyc.Start
    Next

    'OutApp.Quit
    MsgBox "Zpráva byla odeslána na adresu: " & adresat, vbInformation
    'uvolnění z paměti
    Set OutMail = Nothing
    Set objNsp = Nothing
    Set colSyc = Nothing
    Set objSyc = Nothing
    Set OutApp = Nothing
   
End Sub


[Reklama]

[elninoslov]

-To chcete odosielať len aktívny list ako PDF alebo celý zošiť ako PDF ?
-Keď ťaháte príponu PDF z bunky, znamená to, že chcete mať na výber či poslať PDF alebo XLSX ?
-Ak chcete mať príponu na výber a má to byť celý zošit, tak sa musí urobiť kópia tohto súboru XLSM, tá sa musí skryto otvoriť a znovu uložiť bez makra ako XLSX. Chcete to tak, alebo sa má poslať súbor aj s makrom ako XLSM?

Podľa toho, ako odpoviete, bude makro zložité.

EDIT:
A ešte ma napadlo.
- Keď vytvorí súbor na poslanie mailom, teda buď kópia XLSM, alebo convert na XLSX, alebo export na PDF, po odoslaní sa má zmazať ?
- Čo sa má stať so súborom, z ktorého sa makro spúšťa ? Ten súbor sa má premenovať a uložiť ?
- Príde mi nelogické, aby posielaných súboroch bola bunka M2 s napísanou požadovanou príponou súboru. Obzvlášť ak to nebude XLSM.

Veď to je celé divné a plné nejasností.

[luko02420]

Tak jak to mám se mi vyexportuje aktivni list jako pdf., a tento potrebuji odeslat jako přílohu. Zatím mi to posílá soubor xlsm. Soubor ze kterého se odesílá si potom bud uložím nebo zůstane stejný. Jako záloha o odeslání mi postačí exportovaný list v pdf. Celý kód mi v minulosti někdo z vás udelal a slouzil mi tak jak byl napsán. Ted se ho jenom snazim upravit podle soucasné potreby. Snad jsem to popsal srozumitelne. To že mám příponu v bunce je tim, že zkousim jak mi to bude fungovat a snazim se na to přijit stylem pokus-omyl.

[elninoslov]

Skôr ako ste to napísal, som to prerobil na odosielanie podľa voľby PDF/XLSM/SLSX a ďalej podľa nastavenia hodnoty "Cely" na True/False. Poslaný súbor sa potom maže.

Vysomárite sa z toho, či to mám teda prerábať ?

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 = True
   
    With ActiveSheet
        With .Range("C39")
            .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("M2")
        Soubor = "D:\" & .Range("C35") & " " & .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
        'Soubor = "I:\\" & .Range("C35") & " " & .Range("L1") & .Range("M2")
    End With
   
    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 = "abc@gmail.com"
   
    With OutMail
        'adresát
        .To = adresat
        'předmět zprávy
        .Subject = "pokus"
       
        '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: " & adresat, vbInformation
    '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

[luko02420]

Děkuji, snad to nejak poskladam akorat potrebuji aby se mi soubor nemazal. Bude slouzit jako záloha. Zkusim to mazani nejak zrusit , pokud by se mi to nepovedlo tak bych si dovolil se jeste ozvat.

[elninoslov]

V tom prípade je to úplne jednoduché:

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
    '!!!!!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
   
    With ActiveSheet
        With .Range("C39")
            .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
        Soubor = "D:\" & .Range("C35") & " " & .Range("L1") & ".Pdf"
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=Soubor, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    End With
   
    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 = "abc@gmail.com"
   
    With OutMail
        'adresát
        .To = adresat
        'předmět zprávy
        .Subject = "pokus"
       
        '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
    'OutApp.Quit
    MsgBox "Zpráva byla odeslána na adresu: " & adresat, vbInformation
    'uvolnění z paměti
    Set OutMail = Nothing: Set objNsp = Nothing: Set colSyc = Nothing: Set objSyc = Nothing: Set OutApp = Nothing
End Sub

[luko02420]

Děkuji to je presne ono. jenom jsem musel umazat v nazvu ten excel. Psalo mi to dvoznacný název, ale jinak to dela přesné to co jsem potreboval.
Jeste jednou dekuji mnohokrát.