Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 68012 Skopiuj do schowka Outlook zapis załączników do poszczególnych katalogów
Autor Wiadomość
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 2 razy
Posty: 445
Wysłany: 30-04-2020, 10:22   Outlook zapis załączników do poszczególnych katalogów

Witajcie

Udało mi się posklejać makro, które zamontowane w module Outlooka poprawnie wykonuje swoje zadanie.
Mianowicie ma zapisać wszystkie załączniki z wybranego otwartego emaila do konkretnego katalogu. Ma znaleźć w nazwie załącznika np. "-01" co oznacza styczeń i do katalogu styczeń ma zapisać załącznik. Na koniec usunąć dopisek miesiąca, bo jak już plik jest w konkretnym dla niego miejscu, ten numer na końcu tylko przeszkadza.

Wszystko działa jak należy, ale brakuje mi tu 1 rzeczy.
Potrzebuje zabezpieczenie jeśli przy danym pliku nie będzie znacznika miesiąca np.
5001234_10-01 'poprawna nazwa
5001234_20-02 'poprawna nazwa
Poprawna nazwa ma mieć zawsze myślnik i numer "-01", "-06", "-11". Każda inna forma jest zła.

5001234_10-1 'źle
5001234_10_01 'źle

Chciał bym mieć komunikat, z nazwą załącznika który jest źle, do szybkiej identyfikacji np.
"Załącznik "5001234_10-1" ma złą nazwę, nie mogę określić katalogu"

Prosił bym o ewentualną pomoc na sucho, załącznika nie mam jak spreparować.
Kod:
Option Explicit

Public Sub SaveAttachments()

Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String

Dim st As String, lu As String, ma As String, kw As String, mj As String, cz As String, li As String, si As String, wr As String, pz As String, lis As String, gr As String

Dim rok As String, sciezka As String

' gdzie zapisujemy
    rok = "2020"
    sciezka = "sciezka"   

     st = sciezka & rok & "\01 - styczen\"
     lu = sciezka & rok & "\02 - luty\"
     ma = sciezka & rok & "\03 - marzec\"
     kw = sciezka & rok & "\04 - kwiecien\"
     mj = sciezka & rok & "\05 - maj\"
     cz = sciezka & rok & "\06 - czerwiec\"
     li = sciezka & rok & "\07 - lipiec\"
     si = sciezka & rok & "\08 - sierpien\"
     wr = sciezka & rok & "\09 - wrzesien\"
     pz = sciezka & rok & "\10 - pazdziernik\"
     lis = sciezka & rok & "\11 - listopad\"
     gr = sciezka & rok & "\12 - grudzien\"

    On Error Resume Next
    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection   

    For Each objMsg In objSelection ' dla wszystkich zaznaczonych maili

    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count   

    If lngCount > 0 Then ' moga nie miec załączników       

    For i = lngCount To 1 Step -1 ' od ostatniego załącznika do pierwszego   

    strFile = objAttachments.Item(i).FileName ' pobieramy nazwe pliku załącznika   

        ' sprawdzamy czy to jest włąściwa nazwa

        If LCase(strFile) Like "*-01*" Then         ' styczeń
            strFile = st & strFile
            strFile = Replace(strFile, "-01", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-02*" Then     ' luty
            strFile = lu & strFile
            strFile = Replace(strFile, "-02", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-03*" Then     ' marzec
            strFile = ma & strFile
            strFile = Replace(strFile, "-03", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-04*" Then     ' kwiecień
            strFile = kw & strFile
            strFile = Replace(strFile, "-04", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-05*" Then     ' maj
            strFile = mj & strFile
            strFile = Replace(strFile, "-05", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-06*" Then     ' czerwiec
            strFile = cz & strFile
            strFile = Replace(strFile, "-06", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-07*" Then     ' lipiec
            strFile = li & strFile
            strFile = Replace(strFile, "-07", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-08*" Then     ' sierpień
            strFile = si & strFile
            strFile = Replace(strFile, "-08", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-09*" Then     ' wrzesień
            strFile = wr & strFile
            strFile = Replace(strFile, "-09", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-10*" Then     ' październik
            strFile = pz & strFile
            strFile = Replace(strFile, "-10", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-11*" Then     ' listopad
            strFile = lis & strFile
            strFile = Replace(strFile, "-11", "")
            objAttachments.Item(i).SaveAsFile strFile
        ElseIf LCase(strFile) Like "*-12*" Then     ' grudzień
            strFile = gr & strFile
            strFile = Replace(strFile, "-12", "")
            objAttachments.Item(i).SaveAsFile strFile
        End If
    Next i
    End If   

    Next   

ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing

MsgBox "Zalaczniki skopiowane do odpowiednich katalogów", vbInformation, "Kopiowanie zalaczników"

End Sub


PS.
Makro jest to Outlooka, słyszałem o jakimś forum jemu przeznaczonym, ale zamieszczam je tutaj bo Was już znam :)
ID posta: 386689 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 718 razy
Posty: 3871

Wysłany: 30-04-2020, 13:24   

Cytat:
Was już znam :)
Niektórych znajdziesz też na https://www.outlook.pl/forum/ (np. http://www.excelforum.pl/profiles/13969.htm ).
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
Chcesz precyzyjną odpowiedź - zadaj precyzyjne pytanie.
ID posta: 386704 Skopiuj do schowka
 
 
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 2 razy
Posty: 445
Wysłany: 30-04-2020, 19:57   

umiejead,
Dzięki za linki.
Mimo wszystko mam tu do czynienia z "prostym" (dla każdego kto lepiej ogarnia :) ) kodem VBA, może ktoś się skusi, i podpowie co tu zrobić.
ID posta: 386720 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3015 razy
Posty: 9948
Wysłany: 01-05-2020, 01:32   

stingtanner napisał/a:
Kod:
' gdzie zapisujemy
    rok = "2020"
    sciezka = "sciezka"   

     st = sciezka & rok & "\01 - styczen\"
Nie wygląda to dobrze. Dłubać w kodzie co rok?
Praktycznie może być tak:
Kod:
rok = CStr(Year(Date))

Ale...
Mamy przełom roku, w zasadzie już nowy rok, np 2021, a jeszcze nam spływają pliki dotyczące 2020. Trzeba ten problem jakoś rozwiązać. Np. przez styczeń (może jeszcze luty) wszystko co ma numer miesiąca większy od np. 07 (a może 10) zapisywać jeszcze w starym roku.

stingtanner napisał/a:
"Załącznik "5001234_10-1" ma złą nazwę, nie mogę określić katalogu"
Jeżeli przy tym pliku mamy pewność, że jest on mimo wszystko tym, którego się spodziewamy, to nie widzę problemu by go jednak zapisać bez zbędnego komunikatu. Natomiast jeżeli istnieje cień szansy na to, że jest to nieoczekiwany plik, to faktycznie musi być komunikat.

Przeanalizuj poniższe makro
Kod:
Sub AAA()
  Dim strFile As String
  Dim strMies As String
  Dim strRok As String
  Dim varrMiesiace As Variant
  Dim strFolderDocelowy  As String
  Dim sciezka As String
  Dim strPlikFullPath As String
 
  varrMiesiace = Split("styczen,luty,marzec,kwiecien,maj,czerwiec,lipiec," & _
                       "sierpien,wrzesien,pazdziernik,listopad,grudzien", ",")
 
  sciezka = "\\serwer\Folder1\Folder2\"
  strRok = Year(Date)
 
  'prawidłowa nazwa
  strFile = "5001234_10-01.pdf"
 
  strMies = Split(Split(strFile, "-")(1), ".")(0)
 
  strFolderDocelowy = sciezka & strRok & "\" & _
                      Format(CLng(strMies), "00") & " - " & _
                      varrMiesiace(CLng(strMies) - 1) & "\"
 
  strPlikFullPath = Replace(strFile, "-" & strMies & ".", ".")
  strPlikFullPath = strFolderDocelowy & strPlikFullPath
  Debug.Print strPlikFullPath
  '----------------------------------------------------
  'dopuszczalna nazwa
  strFile = "500123456_10-7.pdf"
 
  strMies = Split(Split(strFile, "-")(1), ".")(0)
 
  strFolderDocelowy = sciezka & strRok & "\" & _
                      Format(CLng(strMies), "00") & " - " & _
                      varrMiesiace(CLng(strMies) - 1) & "\"
 
  strPlikFullPath = Replace(strFile, "-" & strMies & ".", ".")
  strPlikFullPath = strFolderDocelowy & strPlikFullPath
  Debug.Print strPlikFullPath
   
Stop
End Sub

Przetraw poniższe
Kod:
        'poniższy wzorzec mówi, że nazwa pliku musi składać się z:
        '- pierwszy człon - co najmniej 7 cyfr (we wzorcu cyfry oznaczone "#")
        '- drugi człon - co najmniej dwie cyfry
        '- trzeci - dokładnie dwie cyfry
        '- po trzecim jest kropka i rozszerzenie pliku co najmniej 3 znakowe
        '(we wzorcu dowolne znaki oznaczone "?")

        If strFile Like "#######*_##*-##.???*" Then


Właściwa procedura mogła by przyjąć kształt:
Kod:
Public Sub SaveAttachments()

    Dim objOL       As Outlook.Application
    Dim objMsg      As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i           As Long
    Dim lngCount    As Long
    Dim strFile     As String
    Dim strFolderpath As String
    Dim strPlikFullName As String
    Dim rok As Long, lRok As Long
    Dim sciezka     As String
    Dim varrMiesiace As Variant
    Dim lMies

    varrMiesiace = Split("styczen,luty,marzec,kwiecien,maj,czerwiec,lipiec," & _
                         "sierpien,wrzesien,pazdziernik,listopad,grudzien", ",")

    ' gdzie zapisujemy
    sciezka = "\\serwer\Folder1\Folder2\"

    lRok = Year(Date)


    On Error Resume Next
    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection

    For Each objMsg In objSelection    ' dla wszystkich zaznaczonych maili

        Set objAttachments = objMsg.Attachments
        lngCount = objAttachments.Count

        If lngCount > 0 Then    ' moga nie miec załączników
            rok = lRok

            For i = lngCount To 1 Step -1    ' od ostatniego załącznika do pierwszego

                strFile = objAttachments.Item(i).Filename    ' pobieramy nazwe pliku załącznika

                ' sprawdzamy czy to jest włąściwa nazwa (dopuszczony miesiąc 2- i 1-znakowy)
                If strFile Like "#######*_##*-##.???*" Or strFile Like "#######*_##*-#.???*" Then

                    lMies = CLng(Split(Split(strFile, "-")(1), ".")(0))

                    'jl. miesiąc pliku > bieżącego miesiąca,
                    'to zapisz w poprzednim roku
                    If lMies > Month(Date) Then
                        rok = rok - 1
                    End If

                    strFolderpath = sciezka & rok & "\" & _
                                    Format(lMies, "00") & " - " & _
                                    varrMiesiace(lMies - 1) & "\"

                    strFile = Replace(strFile, "-" & lMies & ".", ".")
                    strPlikFullName = strFolderpath & strFile

                    objAttachments.Item(i).SaveAsFile strPlikFullName

                Else
                    MsgBox "Załącznik jakiś taki wybrakowany!", vbExclamation, strFile
                    Stop
                    'trzeba podjąć decyzję co dalej; przerwać makro, czy ignorować?
                End If
            Next i

        End If    'lngCount > 0

    Next objMsg

ExitSub:

    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing

    MsgBox "Zalaczniki skopiowane do odpowiednich katalogów", vbInformation, "Kopiowanie zalaczników"

End Sub

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 386724 Skopiuj do schowka
 
 
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 2 razy
Posty: 445
Wysłany: 01-05-2020, 06:34   

Artik
Czytam, analizuje i się nadziwić nie mogę.
Bardzo dziękuję za czas i że miałeś siłę o 2:32 na myślenie.
90% rozumiem co tu się wydarzyło, ale jak miał bym sam napisać coś chociaż w 10% podobnego to nie ma szans.

W pierwszym makro jeśli dobrze rozumiem, pokazałeś mi w jaki sposób mogę fajnie rozebrać na konkretne części podany tekst, porównać ze zbiorem (tu miesięcy).
Następnie wskazać odpowiedni miesiąc.
Tu pytanie.
Czy w "varrMiesiace" do każdego miesiąca licząc od lewej przypisywana jest automatycznie liczba 1-12? Dlatego niżej jeśli określiłeś 1,to ma wziąć 1 element z "varrMiesiace"?

Dalej już oczyszczenie i wynik.

Cytat:
'trzeba podjąć decyzję co dalej; przerwać makro, czy ignorować?

Tu nie chce stopować, makro ma się wykonać do końca, i dopiero na samym końcu ma się pojawić komunikat, ze wskazaniem jeśli jakiś plik miał błędną nazwę. Wtedy to już ręcznie szybkie zapisanie 1-2 plików (ewentualnie)

Pytanie tylko jak zebrać w tym "Else" ewentualne błędy?

Całość przetestuję na spokojnie po majówce :)
ID posta: 386725 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3015 razy
Posty: 9948
Wysłany: 01-05-2020, 19:07   

7:34, stingtanner, przecież marsze pierwszomajowe w tym roku odwołane. Chyba zapomniałeś, że żeś się tak szybko zerwał. :mrgreen:
stingtanner napisał/a:
2:32
To taki późnawy wieczór. Ale spróbuj do mnie zadzwonić przed 9:00 choćby 8:59, to zabiję, a przynajmniej wiązankę puszczę. :mrgreen:
stingtanner napisał/a:
90% rozumiem co tu się wydarzyło
Bardzo dobry wynik :clap
stingtanner napisał/a:
Czy w "varrMiesiace" do każdego miesiąca licząc od lewej przypisywana jest automatycznie liczba 1-12? Dlatego niżej jeśli określiłeś 1,to ma wziąć 1 element z "varrMiesiace"?
I tak i nie. :-)
Do zmiennej varrMiesiace zostaje przekazana tablica nazw miesięcy, w kolejności jak zapisano. Jednak należy pamiętać, że Split zawsze tworzy tablicę indeksowaną od zera (nawet jak na początku modułu jest wymuszenie indeksacji od 1 - nie rozwijam tego tematu).
Dalej w
Kod:
strMies = Split(Split(strFile, "-")(1), ".")(0)
wydłubuję numer miesiąca (Split zwraca elementy w formie stringów!).
I teraz
Kod:
(...) & varrMiesiace(CLng(strMies) - 1) & "\"
Rozbierzmy to. Zmienna strMies przechowuje numery miesięcy w formie stringów w zakresie od "01" do "12" lub "1" do "12", w zależności od tego co było w strFile. CLng konwertuje string na liczbę - otrzymujemy numer miesiąca. Ale, że varrMiesiace jest indeksowana od zera (varrMiesiace(0 To 11)), to musimy odjąć 1, by odwołać się do właściwego elementu tablicy. Bez odjęcia otrzymywalibyśmy nazwę miesiąca następnego, a za grudzień - błąd Index poza zakresem, bo nie istnieje varrMiesiace(12).
Poniał? Pewnie poniał. :-)
Mam tylko nadzieję, że mechanizm tworzący nazwy plików (przechowywanych potem w strFile) pilnuje by numery miesięcy zawierały się w zakresie 1-12. A jak nie, to trzeba go stworzyć. Wtenczas nawet powyższa weryfikacja wydaje się być zbędną. Przy automatyzacji nie może być mowy o samowolce. :-)

stingtanner napisał/a:
Pytanie tylko jak zebrać w tym "Else" ewentualne błędy?
Troszkę złożony temat. To znaczy samo zebranie nazw plików nie spełniających kryterium to nie problem, ale... Ponieważ biegasz pętlą po wielu mail-ach, sam zbiór nazw plików jest mało użyteczny, bo nie wiadomo w których mail-ach ukryte są wadliwe załączniki. Czyli poza nazwami plików należałoby zbierać także np. tematy mail-i z błędnymi nazwami załączników. Druga sprawa, to samo wyświetlenie w MsgBox-ie zbioru błędów będzie mało użyteczne. Kto spamięta więcej jak 3 błędy (nazwę załącznika i temat)? Ja pewnikiem już przy drugim bym zapomniał. :-) Komunikat, poza ewentualnym MsgBox-em powinien pojawić się w jakiś trwalszy sposób. W jaki? Nie wiem. Może np. w Notatniku (zapis błędów do pliku txt, otwarcie pliku w Notatniku, wyświetlenie i usunięcie pliku txt), albo w niemodalnej formie - przemyśl.
_________________
Persistence is a virtue in the world of programming.
ID posta: 386749 Skopiuj do schowka
 
 
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 2 razy
Posty: 445
Wysłany: 02-05-2020, 07:31   

Artik
O 7:34 to ja posta skończyłem pisać :) a od 6 ze świeżutką kawą w ręce, analizowałem twoje cuda. Dla jednych noc, dla innych początek dnia :) Mimo że z głosu wnioskuję, że jesteś starszy ode mnie, to że tak powiem, kiedyś też tak miałem że do rana siedziałem, a do południa spałem :) Młode lata :mrgreen:

Wracając do tematu. Z każdym opisem wszystko robi się coraz jaśniejsze, aczkolwiek czułem że się w jednej kwestii źle zrozumiemy. Mianowicie chodzi o tego "Else", który to miałby zbierać błędy.
Tutaj w nim chodzi mi tylko o jednego na raz otwartego maila. Nie będzie zaznaczania wielu i sprawdzania co się w nich znajduje. Mail z takimi załącznikami przychodzi 2-3 razy w ciągu dnia, o przeróżnych porach. Wtedy to od razu się go realizuje.
No i jeśli taki mail będzie miał np. 10 załączników, 9 jest poprawnych, a 1 ma jakiegoś kwiatka na końcu, to fajnie by było go wyłapać. Walczę oto ponieważ nie chciał bym sprawdzać poszczególnych katalogów i porównywać czy coś brakuje.
W późniejszym etapie pewnie by wyszło, że coś się nie zapisało bo była błędną nazwa, ale to mogło by wywołać już falę stresu.

Reasumując.
1 na raz otwarty mail, zapis załączników, jeśli wystąpi kwiatek to info i ręczne zapisanie załącznika.
ID posta: 386758 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3015 razy
Posty: 9948
Wysłany: 02-05-2020, 18:29   

stingtanner napisał/a:
    Set objOL = CreateObject("Outlook.Application")
Dopiero jak się nieco przysiadłem do kodu, to zobaczyłem.
To jest bez sensu. Zastosowałbyś powyższe przypisanie gdybyś kod uruchamiał spoza Outlook-a. A skoro z niego, to wystarcza
Kod:
    Set objOL = Application
a za chwilę zobaczysz, że w ogóle nie potrzebne. :-) Jeszcze na moment pozostańmy przy CreateObject. Użyte do otwarcia np. Excela spowoduje utworzenie nowej instancji Excela, nawet jak już jakaś by istniała (czyli już wcześniej Excel był otwarty). Outlook zachowuje się inaczej. Jeśli kod uruchomimy np. z Excela, a Outlook zamknięty, to CreateObject obudzi zwierza. Natomiast jak aplikacja jest już uruchomiona, CreateObject nie powoduje utworzenia nowej instancji, tylko zwróci tą otwartą. Ten typ aplikacji ma jakąś tam swoją nazwę, ale nie pamiętam teraz.
Dobra. Do rzeczy.
Ponieważ ja użytkownikom nie wierzę, że będą zaznaczać tylko jednego mail-a, więc kod poprawiłem tak, że obsługuje wiele zaznaczonych. W pętli biegamy po mail-ach i jeśli w badanym natrafimy na nieprawidłową nazwę załącznika(-ów), to przed przejściem do badania następnego mail-a należy poprawić nazwę felernego załącznika. Jeśli nowa nazwa nie będzie pasować do wzorca lub użytkownik nacisnął Cancel, to taki plik nie zostanie skopiowany. Na koniec zostaniesz powiadomiony o plikach nieskopiowanych. Tyle, że nie będzie informacji w których mailach.
Przyznam, że na kolanie robione, więc może będzie wymagać jakichś poprawek.
Kod:
Public Sub SaveAttachments()

    Dim objMsg      As Outlook.MailItem
    Dim objAttach   As Outlook.Attachment
    Dim objSelection As Outlook.Selection
    Dim i           As Long
    Dim lngCount    As Long
    Dim strFile     As String
    Dim rok As Long, lRok As Long
    Dim sciezka     As String
    Dim vBledneZalaczniki As Variant
    Dim strNowaNazwa As String
    Dim strNiezapisaneZalaczniki As String

    ' gdzie zapisujemy
    sciezka = "\\serwer\Folder1\Folder2\"

    lRok = Year(Date)


    On Error Resume Next
    Set objSelection = Application.ActiveExplorer.Selection

    If TypeName(objSelection.Item(1)) <> "MailItem" Then
        'błędny kontekst wywołania makra
    Else
        For Each objMsg In objSelection    ' dla wszystkich zaznaczonych mailach

            If objMsg.Attachments.Count > 0 Then    ' moga nie miec załączników
                rok = lRok
                vBledneZalaczniki = vbNullString

                For Each objAttach In objMsg.Attachments    'po załącznikach maila

                    strFile = objAttach.FileName    ' pobieramy nazwe pliku załącznika

                    ' sprawdzamy czy to jest właściwa nazwa (dopuszczony miesiąc 2- i 1-znakowy)
                    If strFile Like "#######*_##*-##.???*" Or strFile Like "#######*_##*-#.???*" Then
                        Call ZapiszZalacznik(objAttach, rok, sciezka)
                    Else
                        vBledneZalaczniki = vBledneZalaczniki & strFile & ","
                    End If
                Next objAttach


                If Len(vBledneZalaczniki) > 0 Then
                    vBledneZalaczniki = Split(vBledneZalaczniki, ",")

                    For i = 0 To UBound(vBledneZalaczniki) - 1
                        rok = lRok
                        strNowaNazwa = InputBox("Podaj nową nazwę załącznika '" & vBledneZalaczniki(i) & "':", _
                                                "Załącznik o nieprawidłowej nazwie", vBledneZalaczniki(i))

                        If strNowaNazwa Like "#######*_##*-##.???*" Or strNowaNazwa Like "#######*_##*-#.???*" Then
                            Call ZapiszZalacznik(objMsg.Attachments.Item(vBledneZalaczniki(i)), rok, sciezka, strNowaNazwa)
                        Else
                            strNiezapisaneZalaczniki = strNiezapisaneZalaczniki & vBledneZalaczniki(i) & vbLf
                        End If

                    Next i

                End If

            End If    'lngCount > 0

        Next objMsg

        If Len(strNiezapisaneZalaczniki) > 0 Then
            MsgBox "Niezapisane załączniki:" & vbLf & strNiezapisaneZalaczniki, vbExclamation, "Kopiowanie zalaczników"
        End If

        MsgBox "Zalaczniki skopiowane do odpowiednich katalogów", vbInformation, "Kopiowanie zalaczników"

    End If

ExitSub:

    Set objAttach = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
End Sub



Private Sub ZapiszZalacznik(AttachItem As Outlook.Attachment, ByVal rok As Long, sciezka As String, Optional strNowaNazwa As String)
    Dim lMies       As Long
    Dim varrMiesiace As Variant
    Dim strFolderpath As String
    Dim strPlikFullName As String
    Dim strFile     As String

    varrMiesiace = Split("styczen,luty,marzec,kwiecien,maj,czerwiec,lipiec," & _
                         "sierpien,wrzesien,pazdziernik,listopad,grudzien", ",")

    If Len(strNowaNazwa) = 0 Then
        strFile = AttachItem.FileName
    Else
        strFile = strNowaNazwa
    End If

    lMies = CLng(Split(Split(strFile, "-")(1), ".")(0))

    'jl. miesiąc pliku > bieżącego miesiąca,
    'to zapisz w poprzednim roku
    If lMies > Month(Date) Then
        rok = rok - 1
    End If

    strFolderpath = sciezka & rok & "\" & _
                    Format(lMies, "00") & " - " & _
                    varrMiesiace(lMies - 1) & "\"

    strFile = Replace(strFile, "-" & lMies & ".", ".")
    strPlikFullName = strFolderpath & strFile

    AttachItem.SaveAsFile strPlikFullName

End Sub

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 386775 Skopiuj do schowka
 
 
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 2 razy
Posty: 445
Wysłany: 04-05-2020, 07:19   

Artik
Testuję, testuję i widzę kilka rzeczy.

1 rzecz:
Kod zapisuje piki poprawnie tylko z 1 znakowym numerem miesiąca.
2 znakowe "01" są zapisywane w całości, bez korekty nazwy tj. 5001234_10-01

Skorygowałem to w ten sposób:
Kod:
     strFile = Replace(strFile, "-" & Format(lMies, "00") & ".", ".")
     strFile = Replace(strFile, "-" & lMies & ".", ".")
     strPlikFullName = strFolderpath & strFile

     AttachItem.SaveAsFile strPlikFullName

Nie wiem czy dobrze, czy źle że jest podwójne strFile, ale zapisuje załączniki poprawnie, czy to 1 znak czy 2.
Jeśli nazwa się zdubluje: 5001234_10-1 oraz 5001234_10-01 (teoretyczne założenie, ale może przez przypadek wystąpić) no to robi tylko 1 plik, nadpisując 1 zrobiony (jeśli dobrze rozumiem, to tak to działa)

2 rzecz:
Nie widzę tego w kodzie, ale czy makro ma jakieś ograniczenia co do miesiąca i zapisu?
O co mi chodzi :) Stworzyłem załączniki na każdy miesiąc od 1 do 12 z 1 znakowym i 2 znakowym miesiącem. Teraz mamy już Maj, zapisują się tylko do Maja, od Czerwca do Grudnia puściutko :(

W sumie te 2 rzeczy jeśli chodzi o coś nie prawidłowego.

Jeśli chodzi o wykrywanie błędów to działa chyba poprawnie, zrobiłem kilka bubli w postaci "001" "013" "13" "501234". Wychodzi na że wzór trzyma w rydzach poprawność nazwy.
ID posta: 386830 Skopiuj do schowka
 
 
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 2 razy
Posty: 445
Wysłany: 04-05-2020, 10:47   

Sprawa się komplikuje ;/
Padła prośba aby nazwa pliku wyglądała 50012345_10_01.pdf
Są dwie podłogi "_", zmieniłem sam w kodzie, ale oczywiście nie zadziała to tak jak było przewidziane, bo znajduje 1 podłogę od lewej, a po niej 10 a nie numer miesiąca.
ID posta: 386837 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3015 razy
Posty: 9948
Wysłany: 04-05-2020, 11:20   

stingtanner napisał/a:
Nie wiem czy dobrze, czy źle że jest podwójne strFile, ale zapisuje załączniki poprawnie, czy to 1 znak czy 2.
Moim zdaniem niedobrze.
Założenie początkowe było takie, że miesiąc w nazwie zapisywanego pliku ma być zawsze dwucyfrowy. Nie dopuszczamy możliwości zapisu jednocyfrowego.
Sprawa duplikowania się plików, to osobny temat - do rozwiązania.

stingtanner napisał/a:
Padła prośba aby nazwa pliku wyglądała 50012345_10_01.pdf
Moim zdaniem zapis z myślnikiem przed miesiącem jest logicznie lepszy. Oddzielamy nazwę rysunku (czy ogólnie dokumentu) od miesiąca, którego dotyczy.
Jeśli nie przeforsujesz pozostawienia obecnego formatu, to się nad tym pochylimy.

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 386841 Skopiuj do schowka
 
 
stingtanner
Stały bywalec Excelforum


Wersja: Win Office 2019
Pomógł: 2 razy
Posty: 445
Wysłany: 04-05-2020, 11:27   

Artik,
Ok rozumiem, w takim razie ustawiam:
Kod:
strFile = Replace(strFile, "-" & Format(lMies, "00") & ".", ".")

i działa cacy :)

Martwi mnie bardziej, dlaczego zapis następuje tylko do Maja.
Ahh to sprawdzanie psuje mi nerwy:
Kod:
'     If lMies > Month(Date) Then
'         rok = rok - 1
'     End If

Po za komentowaniu tego wkłada załączniki do każdego miesiąca. Ale już nie sprawdzi czy był to jeszcze poprzedni rok. Zastanawiam się czy jest w ogóle potrzeba cofania się, nie zauważyłem u nas takiej tendencji. Wstępnie zostawię to w komentarzu. Czas pokaże dokładnie.

Będę walczył z niemiecką okupacją o myślnik.
Ostatnio zmieniony przez stingtanner 04-05-2020, 11:44, w całości zmieniany 1 raz  
ID posta: 386842 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3015 razy
Posty: 9948
Wysłany: 04-05-2020, 11:43   

stingtanner napisał/a:
Martwi mnie to dlaczego działa zapis następuje tylko do Maja.

Bo
Kod:
    'jl. miesiąc pliku > bieżącego miesiąca,
    'to zapisz w poprzednim roku
    If lMies > Month(Date) Then
        rok = rok - 1
    End If
Makro w obecnym kształcie nie zakłada przetwarzania (porządkowania) danych historycznych. Nie jest także przystosowane do plików z miesiącami "na przyszłość" - miesiąc obecny lub poprzednie, ale jak miesiąc w pliku jest większy niż bieżący miesiąc, to zalicz go do poprzedniego roku.
Musisz szczegółowo określić czego oczekujesz w sprawie miesięcy.

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 386844 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe