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

[luko02420]

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.

[MePExG]

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]

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

[elninoslov]

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]

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]

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

[elninoslov]

+- 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

[luko02420]

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ě.