Cesta pro uložení souboru podle obsahu buňky Vyřešeno

[luko02420]

Zdravím všechny místní odborníky. Používám makro pro uložení listu do pdf a následné odeslání pdf emailem.
Potřeboval bych makro upravit a to tak, aby se mi pdf uložilo do složky podle obsahu buňky F7.
Teď je cesta nastavena do jednoho místa a pdf musím vždy ručně přesouvat do dané složky.
Žlutě označená část cesty v kódu musí být zachována
Složka pro uložení je vždy vytvořena před ukládáním souboru.
Děkuji všem za pomoc.

Kód: Vybrat vše

Sub OutlookPrilohav()
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("G13") ' toto je buňka kde se na listě vypíše datum a čas
            .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
       
     
        Soubor = "[highlight=yellow]Z:\Mistr výroby\Neshodný výrobek[/highlight]\" & .Range("F7") & "_" & .Range("D14") & "_" & .Range("M2") & "" & ".pdf" ' Tady se vylní cesta kam chcete soubor uložit, C35
             .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 = Range("O1") ' emailová adresa příjemce
   
   
    With OutMail
        'adresát
        .To = adresat
       
        'kopie pro
        '.CC = Range("R2")
       
        'skrytá kopie pro
        '.BCC = ""
               
        'předmět zprávy
        .Subject = "Protokol"
       
             
        '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

[Reklama]

[elninoslov]

Treba ujasniť pár vecí.
Čo myslíte pod pojmom "do zložky" ?

Kód: Vybrat vše

C:\niečo\obsah F7\

alebo

Kód: Vybrat vše

obsah F7

Daná zložka/podzložka existuje, alebo sa má vytvoriť?

Určite F7? Lebo F7 je súčasť názvu súboru.

Určite chcete nahradiť to čo je v tagu Highlight za obsah bunky F7 ? Opäť lebo F7 je súčasť názvu súboru.

[luko02420]

Dobrý den, je mysleno to co uvadite C:\neco\obsah F7\.
Daná podsložka bude existovat.
F7 je název podsložky a součastně i část názvu souboru

[elninoslov]

Tak iba doplnte zložku a podzložku, napr.:

Kód: Vybrat vše

Sub OutlookPrilohav()
Dim objNsp As Object, colSyc As Object, objSyc As Object, i As Integer, adresat As String, Soubor As String
Dim Slozka As String, Podslozka 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
   
   Slozka = "Z:\Mistr výroby\Neshodný výrobek\"

    With ActiveSheet
        Podslozka = .Range("F7").Value
        If Len(Podslozka) < 2 Or Len(Dir(Slozka & Podslozka, vbDirectory)) = 0 Then MsgBox "Špatně zadaná složka v F7.", vbCritical: Exit Sub
       
        With .Range("G13") ' toto je buňka kde se na listě vypíše datum a čas
            .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
       
        Soubor = Slozka & Podslozka & "\" & Podslozka & "_" & .Range("D14") & "_" & .Range("M2") & ".pdf"  ' Tady se vylní cesta kam chcete soubor uložit, C35
             .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 = Range("O1") ' emailová adresa příjemce
   
   
    With OutMail
        'adresát
        .To = adresat
       
        'kopie pro
        '.CC = Range("R2")
       
        'skrytá kopie pro
        '.BCC = ""
               
        'předmět zprávy
        .Subject = "Protokol"
       
             
        '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]

Dobrý den, opět výborná práce,
Jenom si nevím rady s malou drobností, zapomněl jsem Vám říct, že do F7, mi hodnotu doplňuje vzorec. Takže kod nefunguje. Jakmile F7 vyplním ručně jede bez problému.
Omlouvám se za chybu.
Pise mi to, že dokument nebyl ulozen nebo je otevren, nebo doslo k chybe pri ukladáni. Tato cast kodu je zluta

Kód: Vybrat vše

.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Soubor, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

[elninoslov]

A čo je v tej bunke? Aký vzorec a čo je jeho výsledkom?

[luko02420]

Kód: Vybrat vše

=KDYŽ(M7>0;M7;"")

Do F7 se kopíruje se název firmy, který se do M7 zapisuje z comboboxu.
Vím že je to krkolomné ale před touto úpravou to normálně fungovalo.
Jenom me napadlo nebylo by lepsi to makro na ukladaní co jste mi napsal udelat jako samostatné makro?

[elninoslov]

Ak je ComboBox napojený na M7, tak do F7 žiaden názov firmy nedostanete. Lebo ComboBox vkladá do bunky M7 číslo indexu v zozname, nie textovú hodnotu názvu firmy. Takže sa odkazujete asi na neexistujúci adresár s číslom, nie názvom firmy. Nedávkujte ďalšie info, ale poskytnite prílohu. Zbavte ju citlivých dát, ale ponechajte formáty, vzorce a obdobné zadané vymyslené údaje v dotyčných bunkách a ComboBoxe.