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: 173
Registrován: únor 12
Pohlaví: Nespecifikováno

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.
Nemáte oprávnění prohlížet přiložené soubory.



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

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: 173
Registrován: únor 12
Pohlaví: Nespecifikováno

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: 271
Registrován: červen 13
Pohlaví: Muž

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: 173
Registrován: únor 12
Pohlaví: Nespecifikováno

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: 173
Registrován: únor 12
Pohlaví: Nespecifikováno

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: 271
Registrován: červen 13
Pohlaví: Muž

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
Nemáte oprávnění prohlížet přiložené soubory.

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

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
  • Jak odstranit kopii tiskárny
    od TT85 » 20 led 2020 07:59 » v Problémy s hardwarem
    5
    367
    od TT85
    20 led 2020 09:01
  • Vytvoření image z oddílu, dd je pomalé
    od Serg012 » 22 lis 2020 23:24 » v LiNuX a ostatní alternativní OS
    3
    212
    od petr22
    23 lis 2020 06:45
  • Program na vytvoření Game Lanucheru nebo launcher na stahování aplikace
    od AngelikaB » 25 črc 2020 20:10 » v Vše ostatní (sw)
    6
    526
    od Akrej
    27 črc 2020 13:29
  • Kontextové menu pomocí DLL
    od rhsCZ » 05 črc 2020 03:04 » v Programování a tvorba webu
    1
    301
    od rhsCZ
    06 črc 2020 12:07
  • Soutěž na FB pomocí sdílení
    od PavelKilleR » 01 lis 2020 13:06 » v Komunikace na internetu
    0
    206
    od PavelKilleR
    01 lis 2020 13:06

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

Kdo je online

Uživatelé prohlížející si toto fórum: CommonCrawl [Bot], kubasCZ a 2 hosti