Vytvoření kopií obrázku pomocí VBA Vyřešeno

Programy pro práci v kanceláři (Word, Excel, Access…=>Office)

Moderátor: Mods_senior

luko02420
Level 2
Level 2
Příspěvky: 203
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Vytvoření kopií obrázku pomocí VBA

Příspěvekod luko02420 » 09 kvě 2020 13:41

Dobrý den, rád bych místní odborníky poprosil o vytvoření makra, pro vytvoření kopií obrázků.
Potřebuji ze složky "D:\výkresy", udělat vícenásobné kopie souborů "jpg" do složky "D:\Rozkopírované".
Mám soubor s názvem např. "A380067.jpg" a potřebuji aby se mi podle hodnoty ve sloupci C udělaly kopie do složky "D:\Rozkopírované", tak jak je uvedeno ve sloupci"B".
Ve sloupci A budou vždy názvy obrázků v tomto tvaru A380067.jpg a budou jedinečné. cesta k nim je se složky "D:\výkresy"
Pokud by bylo potřeba do nově vytvořených kopií přidat třeba pořadové číslo, tak pokud to bude na konci neměl by to být problém třeba takto:"A380067_1.jpg".
Rozkopírovám denně i třeba 20-30 výkresů, to že je to zdlouhavé je jedna věc, ale často se mi stane, že to rozkopíruji špatně a potom má výkres jiný název než skutečný výrobek. A malér je na světě.
Děkuji všem za ochotu a pomoc.
Přílohy
Sešit1.xlsx
(9.02 KiB) Staženo 55 x

Reklama
MePExG
Level 2
Level 2
Příspěvky: 193
Registrován: srpen 16
Pohlaví: Muž
Stav:
Offline

Re: Vytvoření kopií obrázku pomocí VBA

Příspěvekod MePExG » 12 kvě 2020 18:42

Vytvorte si bat, alebo cmd súbor/y a pomocou obyčajného textového editoru, robte jeho modifikácie (názov súboru nahradiť, doplniť, alebo vypustiť cestu..) a všetko budete mať presne a dokonalo pod kontrolou.

luko02420
Level 2
Level 2
Příspěvky: 203
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Re: Vytvoření kopií obrázku pomocí VBA

Příspěvekod luko02420 » 13 kvě 2020 05:35

Dobrý den, mohl bych poprosit o nějaky vzor, vůbec totiz nevím jak na to.
Děkuji za ochotu
Neco jsem sice nasel na netu, ale stejne to nedokazu rozchodit

Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Vytvoření kopií obrázku pomocí VBA

Příspěvekod elninoslov » 13 kvě 2020 08:07

Príklad: Treba vytvoriť 123_1.jpg, 123_2.jpg, 123_3.jpg, 666_1.jpg, 666_2.jpg
Čo ak v rozkopírovaných už nejaké súbory budú?
Prepísať ?
Čo ak tam budú iba niektoré ? Napr. tam budú 123_1.jpg, 123_2.jpg, 666_3.jpg, ABC_1.jpg
Teda pri prepísaní tam bude
123_1.jpg, 123_2.jpg, 123_3.jpg, 666_1.jpg, 666_2.jpg, 666_3.jpg, ABC_1.jpg
Ale ja som 666_3.jpg, ABC_1.jpg nechcel, to tam bolo od neviem od kedy.
Pridať za posledné nájdené číslo?
Teda nastane
123_1.jpg, 123_2.jpg, 123_3.jpg, 23_4.jpg, 123_5.jpg, 666_3.jpg, 666_4.jpg, 666_5.jpg, ABC_1.jpg
Zase je tam to ABC_1.jpg, a ostatné požadované majú iné číslovanie.
Alebo pridávať vždy ďalšiu úroveň? Teda najskôr zistiť, aká je použitá najvyššia úroveň v názvoch, ktoré tam už sú, napr.
123_1.jpg, 123_2.jpg, 123_1_1.jpg, 123_1_2.jpg, 123_1_1_1.jpg
Najvyššia je 3 úroveň u 123_1_1_1.jpg, teda najbližšie pomenovanie bude začínať 123_1_1_1_1.jpg ?
Alebo sa budú všetky súbory v danom adresári mazať?
Čo ak z nejakého dôvodu dôjde k chybe, alebo nebude môcť byť operácia dokončená (málo miesta, niekto počas toho zmaže súbor, ...), čo sa má stať? Majú sa zmazať tie, ktoré sa podarilo rozkopírovať? Teda treba si počas behu makra udržiavať zoznam úspešných.
...

Ešte by som to na Vašom mieste upresnil. Toto nieje problém naprogramovať, ale napísať všeobjímajúce na všetko mysliace makro, nieje možné. :-)

luko02420
Level 2
Level 2
Příspěvky: 203
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Re: Vytvoření kopií obrázku pomocí VBA

Příspěvekod luko02420 » 13 kvě 2020 08:59

elninoslov píše:Príklad: Treba vytvoriť 123_1.jpg, 123_2.jpg, 123_3.jpg, 666_1.jpg, 666_2.jpg
Čo ak v rozkopírovaných už nejaké súbory budú?
Prepísať ?
Čo ak tam budú iba niektoré ? Napr. tam budú 123_1.jpg, 123_2.jpg, 666_3.jpg, ABC_1.jpg
Teda pri prepísaní tam bude
123_1.jpg, 123_2.jpg, 123_3.jpg, 666_1.jpg, 666_2.jpg, 666_3.jpg, ABC_1.jpg
Ale ja som 666_3.jpg, ABC_1.jpg nechcel, to tam bolo od neviem od kedy.
Pridať za posledné nájdené číslo?
Teda nastane
123_1.jpg, 123_2.jpg, 123_3.jpg, 23_4.jpg, 123_5.jpg, 666_3.jpg, 666_4.jpg, 666_5.jpg, ABC_1.jpg
Zase je tam to ABC_1.jpg, a ostatné požadované majú iné číslovanie.
Alebo pridávať vždy ďalšiu úroveň? Teda najskôr zistiť, aká je použitá najvyššia úroveň v názvoch, ktoré tam už sú, napr.
123_1.jpg, 123_2.jpg, 123_1_1.jpg, 123_1_2.jpg, 123_1_1_1.jpg
Najvyššia je 3 úroveň u 123_1_1_1.jpg, teda najbližšie pomenovanie bude začínať 123_1_1_1_1.jpg ?
Alebo sa budú všetky súbory v danom adresári mazať?
Čo ak z nejakého dôvodu dôjde k chybe, alebo nebude môcť byť operácia dokončená (málo miesta, niekto počas toho zmaže súbor, ...), čo sa má stať? Majú sa zmazať tie, ktoré sa podarilo rozkopírovať? Teda treba si počas behu makra udržiavať zoznam úspešných.
...

Ešte by som to na Vašom mieste upresnil. Toto nieje problém naprogramovať, ale napísať všeobjímajúce na všetko mysliace makro, nieje možné. :-)

Dobrý den, před zahajeni operace nebudou v cílové slozce zadne soubory.
Behem operace nikdo nic nesmaze.
Vzdy s cilovou složkou pracuji jenom ja.
V momente dokonceni rozkopirování, soubory prejmenuji a ulozim do databáze. Po te vse mazu.

Dodatečně přidáno po 1 hodině 13 minutách 18 vteřinách:
Tak se mi podařilo rozchodit kopirování pomoci scriptu s tímto kodem.

Kód: Vybrat vše

@ECHO OFF   
XCOPY c:\Users\Uzivatel\Documents\kopie\Zdroj c:\Users\Uzivatel\Documents\kopie\cil

jdu bojovat dále na to rozkopirovani

luko02420
Level 2
Level 2
Příspěvky: 203
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Re: Vytvoření kopií obrázku pomocí VBA

Příspěvekod luko02420 » 15 kvě 2020 19:31

Tak nemůžu na nic přijít.
Napadá mě varianta pomoci VBA ale ndokazi to napsat.
Neco v tom smylsu, ze se zjisti ve sloupci, ze bunka treba B3=B2, B4=B3, a v tom pripade to vytvori kopii obrazku ze slozky, vykresy do slozky rozkopirovane, s tím jak je uvedeno vyse, 123_1.jpg, 123_2.jpg, 123_3.jpg.
dík za pomoc

Uživatelský avatar
elninoslov
Level 2.5
Level 2.5
Příspěvky: 366
Registrován: červen 13
Pohlaví: Muž
Stav:
Offline

Re: Vytvoření kopií obrázku pomocí VBA

Příspěvekod elninoslov » 20 kvě 2020 00:00

+- autobus, s nejakými overeniami ... ale moc sa mi to šperkovať a testovať nece :) Dajte vedieť...

Kód: Vybrat vše

Sub Copy_pictures()
Dim R As Long, PCount As Long, i As Long, y As Long, tmp As String, ErCount1 As Long, ErCount2 As Long
Dim P(), CP() As String, n() As Long
Dim SPath As String, DPath As String, Ext As String, FName As String, DName As String, MSG As String
Dim FSO As Object, colDP As Collection, itemDP As Long

    SPath = "D:\výkresy"
    DPath = "D:\Rozkopírované"
    Ext = ".jpg"
   
    With List1                                  'Načítanie zoznamu výkresov v stĺpci B
        R = .Cells(Rows.Count, 2).End(xlUp).Row - 1
        If R = 0 Then MsgBox "Žiadne výkresy v stĺpci B.", vbInformation: Exit Sub
        If R = 1 Then
            ReDim P(1 To 1, 1 To 1): P(1, 1) = .Cells(2, 2).Value
        Else
            P = .Cells(2, 2).Resize(R).Value
        End If
    End With
   
    PCount = -1
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    With FSO
        If Not .FolderExists(SPath) Then MsgBox "Zdrojový adresár s výkresmi neexistuje." & vbNewLine & SPath, vbCritical: GoTo FINAL
        If Not .FolderExists(DPath) Then If Not Create_Dir_Structure(DPath) Then MsgBox "Nieje možné vytvoriť cieľový adresár" & vbNewLine & DPath, vbCritical: GoTo FINAL
        If .GetFolder(SPath).Files.Count = 0 Then MsgBox "Adresár s výkresmi je prázdny.", vbExclamation: GoTo FINAL
        If .GetFolder(DPath).Files.Count > 0 Then If MsgBox("Adresár s kópiami nieje prázdny." & vbNewLine & "Pokračovať ?", vbQuestion + vbYesNo) = vbNo Then GoTo FINAL
        SPath = SPath & IIf(Right$(SPath, 1) = "\", "", "\")
        DPath = DPath & IIf(Right$(DPath, 1) = "\", "", "\")
       
        Set colDP = New Collection
        On Error Resume Next
       
        For i = 1 To R                          'Zistenie koľko ktorých výkresov treba
            colDP.Add PCount + 1, P(i, 1)
           
            If Err.Number = 0 Then
                If .FileExists(SPath & P(i, 1) & Ext) Then
                    PCount = PCount + 1
                    ReDim Preserve CP(PCount)       'názvy výkresov
                    ReDim Preserve n(PCount)        'počet kópií od daného výkresu
                    n(PCount) = 1
                    CP(PCount) = P(i, 1)
                Else
                    colDP.Remove (P(i, 1))
                    ErCount1 = ErCount1 + 1
                End If
            Else
                itemDP = colDP(P(i, 1))
                n(itemDP) = n(itemDP) + 1
                Err.Clear
            End If
        Next i
       
       
        For i = 0 To PCount                     'kopírovanie výkresov (ak je viac ako 1, pridá sa "_1" ... "_01" podľa počtu
            FName = SPath & CP(i) & Ext
            tmp = Left$("_000000", Len(CStr(n(i))) + 1)
            DName = DPath & CP(i)
            For y = 1 To n(i)
                .CopyFile FName, DName & IIf(n(i) > 1, Format(y, tmp), "") & Ext
                If Err.Number <> 0 Then ErCount2 = ErCount2 + 1: Err.Clear
            Next y
        Next i
        On Error GoTo 0
    End With
   
    MSG = IIf(ErCount1 > 0, "Niektoré zdrojové výkresy (" & ErCount1 & ") neexistujú.", "")
    MSG = IIf(ErCount1 > 0, MSG & vbNewLine & vbNewLine, "") & IIf(ErCount2 > 0, "Niektoré kópie výkresov (" & ErCount2 & ") nemohli byť vytvorené.", "")
    If MSG <> "" Then MsgBox MSG, vbExclamation
   
FINAL:
    Set FSO = Nothing
End Sub


Kód: Vybrat vše

Function Create_Dir_Structure(D As String) As Boolean
Dim S() As String, i As Byte, Path As String

    If Len(D) < 3 Then Exit Function
    S = Split(D, "\")
    If UBound(S) = 0 Then Exit Function

    Path = S(0)
    On Error GoTo FINAL
    For i = 1 To UBound(S)
        Path = Path & "\" & S(i)
        If Len(Dir(Path, vbDirectory)) = 0 Then MkDir Path
    Next i

FINAL:
    Create_Dir_Structure = Err.Number = 0
End Function
Přílohy
Vykresy.xlsm
(27.46 KiB) Staženo 52 x

luko02420
Level 2
Level 2
Příspěvky: 203
Registrován: únor 12
Pohlaví: Nespecifikováno
Stav:
Offline

Re: Vytvoření kopií obrázku pomocí VBA  Vyřešeno

Příspěvekod luko02420 » 20 kvě 2020 06:21

Dobrý den, jste prostě kouzelník a hodně ochotný.
To je přesně to co jsem potřeboval.
Máte zlatý ruce.
Ještě jednou děkuji a smekám.
Funguje exceletně.


  • Mohlo by vás zajímat
    Odpovědi
    Zobrazení
    Poslední příspěvek
  • Skript na vytvoreni zastupce slozky
    od ajr » 01 úno 2024 21:21 » v Windows 11, 10, 8...
    1
    586
    od ITCrowd Zobrazit poslední příspěvek
    02 úno 2024 08:36
  • MS Outlook - Hromadné vytvoření složek Příloha(y)
    od czTANIScz » 22 zář 2023 11:36 » v Kancelářské balíky
    6
    2678
    od czTANIScz Zobrazit poslední příspěvek
    23 zář 2023 22:34
  • Vytvoření skriptu na zálohu hry, kterou vytvářím. Příloha(y)
    od xCloudGirl » 09 bře 2024 12:35 » v Vše ostatní (sw)
    11
    1010
    od MonikaVavrova Zobrazit poslední příspěvek
    11 bře 2024 22:24
  • Windows 11 nelze zrušit přihlášení pomocí hesla PIN)
    od nulka » 17 srp 2023 11:08 » v Windows 11, 10, 8...
    9
    3382
    od nulka Zobrazit poslední příspěvek
    17 srp 2023 16:02

Zpět na “Kancelářské balíky”

Kdo je online

Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 6 hostů