Příspěvky uživatele
< návrat zpět
No este pockam ak sa nik nepodujme tak tam skusim toto dat aspon 6x a to by mi malo stacit.
For Each kategorie In objFolder.subfolders
For Each film In kategorie.subfolders
Ten súbor som našiel a snažil som sa to upraviť no je to namna moc zložité a nepodarilo sa mi to.
Skúsim to vysvetliť asi som spravil chybu že som dal len časť kódu, myslel som že to bude stačiť. Ak je cesta H:\Filmy\Robocop\Robocop.mkv
funguje to.
Ak je cesta dlhšia o jeden alebo viac podpriečinkov napr.
H:\Filmy\Robocop\novy\Robocop.mkv
tak to už nefunguje.
S tým "PrintFiles" sa dalej pracuje ale tam podla mna problém nieje ale tu je celý kód.
Má to nájsť všetky filmy na disku a vytvoriť zoznam s podrobnostami cestami velkostami atd.
Sub PrintFolders() 'testovaci
Dim objFSO As Object
Dim objFolder As Object
Dim kategorie As Object
Dim film As Object
Dim folder As String
Sheets("Hárok2").Range("A2:F" & Sheets("Hárok2").Range("A99999").End(xlUp).Row).ClearContents
Application.StatusBar = ""
folder = Sheets("Hárok1").Range("B2").Value & ":\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(folder)
i = 1
'On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
For Each kategorie In objFolder.subfolders
For Each film In kategorie.subfolders
Call PrintFiles(film.Path)
Call ShowVolumeInfo
Next film
Next kategorie
handleCancel:
If Err = 18 Then
MsgBox "You cancelled"
End If
End Sub
Sub PrintFiles(ByVal FolderName As String)
Dim fsObj, FD, fs, Fl As Object
Dim FullPath, nameoffile As String
Dim Velikost As Long
Dim radek As Long
radI = 2
Set fsObj = CreateObject("Scripting.FileSystemObject")
Set FD = fsObj.GetFolder(FolderName)
Set fs = FD.Files
For Each Fl In fs
radek = Sheets("Hárok2").Range("A99999").End(xlUp).Row + 1
nameoffile = Fl.Name
Sheets("Hárok2").Cells(radek, 1) = Fl.Path
Sheets("Hárok2").Cells(radek, 2) = GetProperties(Fl.Path, 0) 'nazov
Sheets("Hárok2").Cells(radek, 3) = GetProperties(Fl.Path, 190) 'priecinok v ktorom je subor
Sheets("Hárok2").Cells(radek, 4) = GetProperties(Fl.Path, 164) 'pripona
Sheets("Hárok2").Cells(radek, 5) = GetProperties(Fl.Path, 1) 'velkost
Sheets("Hárok2").Cells(radek, 6) = GetProperties(Fl.Path, 27) 'trvanie
Next
Set fsObj = Nothing
Set FD = Nothing
Set fs = Nothing
End Sub
Sub ShowVolumeInfo() 'ziska nazov disku
Dim fs, d, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(Range("A2").Value)))
s = d.VolumeName
Range("G2") = s
End Sub
Zdravím. Kód mi robí to že nájde súbor v priečinkoch, avšak ide iba do 2 podpriečinkov ak je ich viac vypíše chybu. Vedeli by ste mi pomôct? Ako mám spraviť to aby súbor našlo aj ked bude podpriečinkov povedzme 10. Vedel by som tam pridať 10x for each ale čo ak bude podpriečinkov 11 chcel by som to mať nejak automacické snád chápete ako to myslím.Sub PrintFolders() 'testovaci
Dim objFSO As Object
Dim objFolder As Object
Dim kategorie As Object
Dim film As Object
Dim folder As String
Sheets("Hárok2").Range("A2:F" & Sheets("Hárok2").Range("A99999").End(xlUp).Row).ClearContents
Application.StatusBar = ""
folder = Sheets("Hárok1").Range("B2").Value & ":\"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(folder)
i = 1
'On Error GoTo handleCancel
Application.EnableCancelKey = xlErrorHandler
For Each kategorie In objFolder.subfolders
For Each film In kategorie.subfolders
Call PrintFiles(film.Path)
Next film
Next kategorie
handleCancel:
If Err = 18 Then
MsgBox "You cancelled"
End If
End Sub
Dakujem skúšal som a funguje,len s chybičkami.Ak sú v priečinku 2 alebo viac filmov vypíše len jeden. A každým spustením sa hodnoty zapíšu už pod existujúci zoznam čiže tam potom vznikajú duplicity. Vlastne ked som tak rozmýšlal, lepšie by bolo aby sa tie hodnoty čo už v tabulke sú znova neprepisovali a nové sa pridaly naspodok.
Tak som znova niečo skúsil a ten modul 3 mi dáva všetky informácie v takom tvare ako by som chcel, len tam treba zadať kompletnú cestu k súboru nevyhladá súbory sám.
Teraz ma čaká skombinovať všetky tri moduly čo tam mám nejak do jedného. S tým budem asi potrebovať pomoc.
Našiel som spôsob ako čítať názov disku je v module 2
Dotazy mi nikdy nefungovali správne vždy to nejak sekalo a nešlo to. Skúšal som ten čo si mi poslala ale nejak nechce načitavať údaje.
Ja sa s tým ešte pohrám a dám vedieť lebo ešte sám nemám premyslené ako by som to vlastne chcel.
No celu cestu k súboru potrebujem nato aby som si vedel v stlpcoch C D vytiahnut vzorcami informacie lebo vo vba by to bolo pre mna moc komplikovane. Cesta by vyzerala
D:\Filmy\Kukurica\Kukurica.txt
D:\viac dielne filmy\Avengers\black panter.txt
Do D potrebujem prvy priečinok napr. Filmy
Disky budem mat 2 a neviem či písmeno disku je spolahlive že sa priradi vždy k tomu disku tak by som chcel aby sa čital názov disku ale to musim zisťit ci vie vba prečitať to by šlo do C
Do E
Samotny film bez pripony
Ešte som rozmyšlal že by sa tam dalo dať rozlíšenie filmu ale to som ešte nehladal len ma to v noci napadlo, tak ak budem za pc pozriem či to vba dokáže vytiahnuť.
Zdravím minule ste mi tu pomohli tak skúsim znova. Cchel by som si spraviť excel na triedenie filmov a trochu to zautomatizovať. Jeden teraz mám hotový ale všetko robím ručne tak by som to chcel vylepšiť. V priloženom exceli na hárku2 je zhruba moja predstava ako by to malo vyzerať. Makro by malo vyťiahnuť cestu k všetkým súborom a potom aj velkosť. Vzorcami v exceli by som si to už tú cestu porozdeloval. No zasekol som sa hned na začiatku. Našiel som si makro ktoré mi čiastočne funguje, ale nedarí sa mi ho upraviť na viac podpriečinkov funguje iba na dva. Tu je pôvodné makro
Sub Example4()
Dim varDirectory As Variant
Dim flag As Boolean
Dim i As Integer
Dim strDirectory As String
strDirectory = "D:\cdd\"
i = 1
flag = True
varDirectory = Dir(strDirectory, vbDirectory)
While flag = True
If varDirectory = "" Then
flag = False
Else
Cells(i + 1, 1) = varDirectory
Cells(i + 1, 2) = strDirectory + varDirectory
'returns the next file or directory in the path
varDirectory = Dir
i = i + 1
End If
Wend
End Sub
Takto som sa ho snažil upraviťSub Example4()
Dim varDirectory As Variant
Dim varDirectory2 As Variant
Dim flag As Boolean
Dim i As Integer
Dim strDirectory As String
strDirectory = "D:\cdd\"
i = 1
flag = True
varDirectory = Dir(strDirectory, vbDirectory)
varDirectory2 = Dir(varDirectory, vbDirectory)
While flag = True
If varDirectory = "" Then
flag = False
Else
Cells(i + 1, 3) = strDirectory + varDirectory + varDirectory2
'returns the next file or directory in the path
varDirectory = Dir
varDirectory2 = Dir
i = i + 1
End If
Wend
End Sub
Neviem ako opísať problém proste to nejde viac do hlbky chcel som tam pridať dalšiu čast a potom dalšiu ale už tá prvá mi nešla.Proste vypíše to len
D:\cdd\Filmy
a malo by to vypísať
D:\cdd\Filmy\Kukurica\Kukurica.txt
Úpravy som spravil a fungujú. Čo si poslal teraz to asi nebude dobré.Ja to budem kopírovať do takého zariadenia čo sa správa ako usb a tam sa nebudú vytvárať priečinky. Mal som to len takto pracovne v priečinku, lebo to zariadenie má pomalý zápis. Mal som to napísať skôr prepáč.
Ale všimol som si že si tam dal progress bar tak tú časť kódu som využil a hladal som si niečo o tom a až bude čas skúsim tam nejak dostať niečo takéto https://www.excel-easy.com/vba/examples/progress-indicator.html
Načo je dobré vyprádznovať tie premenné týmto príkazom
Set oFolder = Nothing:
Veď pri znovu spustení makra by sa tam uložili nové a fungovalo by to aj bez toho. či sa mýlim?
Skúsim to prepísať a dám vedieť. Tá chyba čo spomínaťe môže nastane kedy za akých okolností.
Vau je to dokonalé ešte aj msgbox ste tam dali. Ďakujem Vám.
Ahojte sa mi zdá dosť pekné, ale nabudúce skúsim nájsť peknejšie.
Zabudol som súbor.
Ahojte som tu nový potreboval by som pomôcť. Robím si zošit na zautomatizovanie práce a zasekol som sa.
Konkrétne mi robí problém makro. Rozdelil som si to na časti a chcel by som aby to fungovalo takto:
Je zošit a dva priečinky priečinok songy v ktorom sú pesničky a priečinok ffff ktorý je prázdny.
Makro by malo:
1.Skopírovať názvy pesničiek v priečinku songy do stlpca C. (to mám vyriešené)
2.Skopírovať pesničky v priečinku songy a prekopírovať ich do priečinku ffff (to mám vyriešené)
3.Premenovať pesničky v priečinku ffff tak aby sa zhodovali so stĺpcom B (to sa mi nedarí)
Uživatelské menu
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články