Elikäst.
Miten sais esim. kahdella Listbox objektilla näytettyä vaikkapa Mp3-CD:n Kansiot/Alikansiot ja Kappaleet?
Tyyliin näin.
List1 |-------------------------------| |Kansiot........|Alikansiot.....| |---------------|---------------| |MP3 - 1........|Eput...........| |...............|Yö.............| |...............|jne. jne.......| |-------------------------------|
List2 |------------------------------------| |Tiedostot.........|Tiedostotyyppi...| |------------------------------------| |Diipa daipa.......|mp3..............| |Diipa diipa.......|wma..............| |jne. jne..........|jne.jne..........| |------------------------------------|
(Saakohan tosta mitää tolkkua ;] )
Eli List1 keräis tiedot kaikista kansioista ja alikansioista, ja List2 listais kaikkien kansioiden ja alikansioiden tiedostot.
Moikka Happy!
voisit taas käytellä sitä Scripting.FileSystemObject'a & listata kaman ListBox'in...
Eipä tuu mitää.
Löysin tälläsen koodin pätkän täältä ohjelmointiputkasta, joka kyllä listaa kansiot ja alikansiot Listbox:iin.
Private Sub Form_Load() asema$ = "D:\" List1.AddItem asema$ HaeAliHakemistot asema$, 0 End Sub Sub HaeAliHakemistot(hak$, kerros%) kerros% = kerros% + 1 ReDim hakemistot(255) As String x$ = Dir(hak$, vbDirectory) Do While x$ <> "" If GetAttr(hak$ + x$) = vbDirectory And Left$(x$, 1) <> "." Then haki% = haki% + 1 hakemistot(haki%) = x$ End If x$ = Dir Loop For i = 1 To haki% List1.AddItem String$(kerros% * 6, "-") + hakemistot(i) HaeAliHakemistot hak$ + hakemistot(i) + "\", kerros% Next kerros% = kerros% - 1 DoEvents End Sub
Mutta miten sais vielä kaikista listattavista kansioista tiedostoluettelon,
(Eli listaa KAIKKI levyn tiedostot) esim. toiselle listboxi:lle?
-Happy-
Moikka Happy!
tässä nyt tämmönen puolihuolimaton lisävääntö tohon etsimääsi jutskaan...
ei tarvii paljon säätää niin sulla on valmis oma pikku WinStyle-Find...
Dim asema$, root$, tiedosto$ 'Formille: pari ListBoxia, Nappi & Radio-nappi 'Radio-napin Index-arvoksi: 0 - Appearance: Flat Dim asema$, root$, tiedosto$, polku$ Dim fso As FileSystemObject, kerrosTag% Dim delay As Single, loopExit As Boolean Private Sub Form_Load() Set fso = CreateObject("Scripting.FileSystemObject") Dim drv As Scripting.Drive, i As Integer For Each drv In fso.Drives With drv If i > 0 And drv.IsReady Then Load Option1(i) Option1(i).Top = Option1(i - 1).Top Option1(i).Left = Option1(i - 1).Left + _ Option1(i - 1).Width + 150 Option1(i).Visible = True Option1(i).TabIndex = Option1(i - 1).TabIndex + 1 End If If drv.IsReady Then Option1(i).Caption = .Path End If i = i + 1 End With Next drv Set fso = Nothing Me.Caption = asema$ & " asema" Command1.Caption = "ANNA PALAA" Option1(0).Value = True Command1.TabIndex = Option1.Count List1.TabIndex = Command1.TabIndex + 1 List2.TabIndex = List1.TabIndex + 1 End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Me.MousePointer = 0: loopExit = True: Close: End End Sub Private Sub Command1_Click() 'referenssi: Microsoft Scripting Runtime 'C:\WINDOWS\system32\scrrun.dll For i = 0 To Option1.Count - 1 Option1(i).Enabled = False Next i Set fso = CreateObject("Scripting.FileSystemObject") ChDrive$ (asema$) root$ = asema$ + "\" If fso.FileExists(root$ & "fileInfo.dat") Then _ Kill root$ & "fileInfo.dat": Set fso = Nothing Me.Caption = asema$ & " asema - listataan..." Me.MousePointer = 11 Command1.Enabled = False List1.AddItem root$ GetFilesInRoot HaeAliHakemistot root$, 0 Command1.Enabled = True Me.MousePointer = 0 For i = 0 To Option1.Count - 1 Option1(i).Enabled = True Next i Me.Caption = asema$ & " asema - listattu" End Sub Sub GetFilesInRoot() ChDir (root$) Shell ("cmd /c dir *.* /o /a:-d /b /d >" & _ root$ & "fileInfo.dat"), vbHide delay = Timer + 0.5 Do While delay > Timer DoEvents: If loopExit Then Exit Sub Loop Open root$ & "fileInfo.dat" For Input As #1 If LOF(1) > 0 Then List2.AddItem root$ Do While Not EOF(1) If loopExit Then Exit Sub Input #1, tiedosto$ CharFix List2.AddItem " ___ " & tiedosto$ Loop List2.AddItem " " End If Close #1 delay = Timer + 0.1 Do While delay > Timer DoEvents: If loopExit Then Exit Sub Loop Kill root$ & "fileInfo.dat" End Sub Sub HaeAliHakemistot(hak$, kerros%) kerros% = kerros% + 1 ReDim hakemistot(255) As String x$ = Dir(hak$, vbDirectory) Do While x$ <> "" If loopExit Then Exit Sub If GetAttr(hak$ + x$) = vbDirectory _ And Left$(x$, 1) <> "." Then haki% = haki% + 1 hakemistot(haki%) = x$ End If x$ = Dir Loop For i = 1 To haki% List1.AddItem String$(kerros% * 6, "-") + hakemistot(i) If kerros% < 2 Then polku$ = root$ ElseIf kerros% > 1 And kerros% <= kerrosTag% Then polku$ = Left(polku$, Len(polku$) - 1): flash% = 0 Select Case Abs(kerros% - kerrosTag%) Case 0 For j = Len(polku$) To 3 Step -1 If Mid(polku$, j, 1) = "\" Then polku$ = Left(polku$, j): Exit For End If Next j Case Else For j = Len(polku$) To 3 Step -1 If Mid(polku$, j, 1) = "\" Then flash% = flash% + 1 If flash% = Abs(kerros% - kerrosTag%) + 1 Then polku$ = Left(polku$, j): Exit For End If Next j End Select End If kerrosTag% = kerros% polku$ = polku$ + hakemistot(i) ChDir (root$) ChDir (polku$) polku$ = polku$ + "\" Polku$ = Polku$ + "\" 'vaihtele parametrejä jos siltä tuntuu Shell ("cmd /c dir *.* /o /a:-d /b /d >" & _ root$ & "fileInfo.dat"), vbHide 'mikäli tökkii niin kasvata hieman viivettä delay = Timer + 0.5 Do While delay > Timer DoEvents: If loopExit Then Exit Sub Loop Open root$ & "fileInfo.dat" For Input As #1 If LOF(1) > 0 Then List2.AddItem Polku$ Do While Not EOF(1) If loopExit Then Exit Sub Input #1, tiedosto$: CharFix List2.AddItem " ___ " & tiedosto$ Loop List2.AddItem " " End If Close #1 delay = Timer + 0.1 Do While delay > Timer DoEvents: If loopExit Then Exit Sub Loop Kill root$ & "fileInfo.dat" HaeAliHakemistot hak$ + hakemistot(i) + "\", kerros% Next kerros% = kerros% - 1 End Sub Sub ChkCmdState() 'referenssi: Microsoft WMI Scripting V1.2 Library '(C:\WINDOWS\system32\wbem\wbemdisp.TLB) Dim Prosessit As SWbemObjectSet Dim Prosessi As SWbemObject Set Prosessit = GetObject _ ("winmgmts:{impersonationLevel=impersonate}") _ .InstancesOf("Win32_Process") For Each Prosessi In Prosessit With Prosessi If LCase(.Name) = "cmd.exe" Then .Terminate End If End With Next Set Prosessit = Nothing End Sub Private Sub Option1_Click(Index As Integer) List1.Clear List2.Clear asema$ = Option1(Index).Caption Me.Caption = asema$ & " asema" End Sub Sub CharFix() tiedosto$ = Replace(tiedosto$, "ÿ", " ") 'Alt + 255 tiedosto$ = Replace(tiedosto$, "†", "å") tiedosto$ = Replace(tiedosto$, "„", "ä") tiedosto$ = Replace(tiedosto$, "”", "ö") tiedosto$ = Replace(tiedosto$, "", "Å") tiedosto$ = Replace(tiedosto$, "Ž", "Ä") tiedosto$ = Replace(tiedosto$, "™", "Ö") End Sub
-Nea-
En kerinny paljon perehtyy tähän, pitää mennä töihin :(
Kokeilin pikkasen ja heitti virheen Run time Error '76 Kun yritti lukea CD-asemaa.
Sitte kun yritti lukea C-asemaa virhe oli Run time error '52.
Pitää perehtyä pikkasen enemmän ku pääsen töistä..
Tästä voisi lähteä liikkeelle vähän helpommin...
Subi tulostaa kaikki tiedostot(myös alikansioista) parametrinä annetusta hakemistosta.
Lisäät sopivat list.Additem lauseet tuon MsgBox käskyn tilalle.
Sub allfiles_in_folder(Folder As String) Dim Subfolder As Variant, File As Variant, Rootfolder As Variant Dim fs As Variant, f As Variant Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(Folder) Set Rootfolder = f.Files For Each File In Rootfolder MsgBox Folder & "\" & File.Name Next Set Subfolder = f.subfolders For Each Subfolder In Subfolder allfiles_in_folder Subfolder.Path Next End Sub
Moikka taas Happy & Hycke!
joo, kyllä syvältä on toi edellinen vääntö...Hycke'n esimerkin pohjalta jutska alkaa pelittään huomattavan paljon helpommin & vauhdikkaammin...
Dim fso As FileSystemObject Dim asema As String, tagFolder As Variant Dim loopEXIT As Boolean, fileArray() Private Sub Form_Load() 'Formille - pari ListBoxia, Radio-nappi, 'CheckBoxi & Nappi 'List1 säätö - Sorted: True 'Radio-napin säätö - Appearance: Flat, Index: 0 ' & Style: 1 'referenssi: Microsoft Scripting Runtime 'C:\WINDOWS\system32\scrrun.dll Set fso = CreateObject("Scripting.FileSystemObject") Dim drv As Scripting.drive, i As Integer For Each drv In fso.Drives With drv If i > 0 And drv.IsReady Then Load Option1(i) Option1(i).Top = Option1(i - 1).Top Option1(i).Left = Option1(i - 1).Left + _ Option1(i - 1).Width + 150 Option1(i).Visible = True Option1(i).TabIndex = Option1(i - 1).TabIndex + 1 End If If drv.IsReady Then Option1(i).Caption = .Path End If i = i + 1 End With Next drv Set fso = Nothing Me.Caption = asema & " - asema" Command1.Caption = "ANNA PALAA" Option1(0).value = True Check1.TabIndex = Option1.Count Command1.TabIndex = Check1.TabIndex + 1 List1.TabIndex = Command1.TabIndex + 1 List2.TabIndex = List1.TabIndex + 1 End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Me.MousePointer = 0: loopEXIT = True: End End Sub Private Sub Option1_Click(Index As Integer) List1.Clear List2.Clear asema = Option1(Index).Caption Me.Caption = asema & " asema" End Sub Private Sub Command1_Click() Me.MousePointer = 11 For i = 0 To Option1.Count - 1 Option1(i).Enabled = False Next i Set fso = CreateObject("Scripting.FileSystemObject") ChDrive$ (asema) ChDir (asema & "\") Me.Caption = asema & " asema - listataan..." Check1.Enabled = False Command1.Enabled = False tagFolder = "" GetFoldersAndFiles (asema) Command1.Enabled = True Check1.Enabled = False For i = 0 To Option1.Count - 1 Option1(i).Enabled = True Next i Me.Caption = asema & " asema - listattu" Me.MousePointer = 0 End Sub Sub GetFoldersAndFiles(Folder As String) Dim Subfolder As Variant, File As Variant Dim f As Variant If Check1.value = 1 Then ReDim fileArray(0) Set fso = CreateObject("Scripting.FileSystemObject") Set f = fso.GetFolder(Folder) Set Rootfolder = f.Files DoEvents For Each File In Rootfolder If loopEXIT Then Exit For If tagFolder <> Folder Then If Right(Folder, 1) = ":" Then _ Folder = Folder & "\" List1.AddItem Folder If Right(Folder, 1) <> "\" Then _ Folder = Folder & "\" List2.AddItem Folder End If If Check1.value = 0 Then List2.AddItem File.Name Else If File.Name <> "" Then fileArray(UBound(fileArray)) = File.Name ReDim Preserve fileArray(UBound(fileArray) + 1) End If End If tagFolder = Folder Next If Check1.value = 1 Then z& = SortArray(fileArray, , False) For i = 0 To UBound(fileArray) If Trim(fileArray(i)) <> "" Then _ List2.AddItem fileArray(i) Next i End If If Len(Folder) > 3 And _ Len(List2.List(List2.ListCount - 1)) > 1 Then _ List2.AddItem " " 'Alt + 255 Set Subfolder = f.SubFolders For Each Subfolder In Subfolder If loopEXIT Then Exit For GetFoldersAndFiles Subfolder.Path Next Set Rootfolder = Nothing Set f = Nothing Set fso = Nothing End Sub Function SortArray(arr As Variant, Optional numEls As Variant, _ Optional descending As Boolean) Dim value As Variant, temp As Variant Dim sp As Integer Dim leftStk(32) As Long, rightStk(32) As Long Dim leftNdx As Long, rightNdx As Long Dim i As Long, j As Long DoEvents If IsMissing(numEls) Then _ numEls = UBound(arr) leftNdx = LBound(arr) rightNdx = numEls sp = 1 leftStk(sp) = leftNdx rightStk(sp) = rightNdx Do If loopEXIT Then Exit Function If rightNdx > leftNdx Then value = arr(rightNdx) i = leftNdx - 1 j = rightNdx If descending Then Do: If loopEXIT Then Exit Function Do: If loopEXIT Then Exit Function: i = i + 1: Loop Until arr(i) <= value Do: If loopEXIT Then Exit Function j = j - 1: Loop Until j = _ leftNdx Or arr(j) >= value temp = arr(i) arr(i) = arr(j) arr(j) = temp Loop Until j <= i Else Do: If loopEXIT Then Exit Function Do: If loopEXIT Then Exit Function i = i + 1:: If loopEXIT Then Exit Function Loop Until arr(i) >= value Do: j = j - 1: If loopEXIT Then Exit Function Loop Until j = leftNdx Or arr(j) <= value temp = arr(i) arr(i) = arr(j) arr(j) = temp Loop Until j <= i End If temp = arr(j) arr(j) = arr(i) arr(i) = arr(rightNdx) arr(rightNdx) = temp sp = sp + 1 If (i - leftNdx) > (rightNdx - i) Then leftStk(sp) = leftNdx rightStk(sp) = i - 1 leftNdx = i + 1 Else leftStk(sp) = i + 1 rightStk(sp) = rightNdx rightNdx = i - 1 End If Else leftNdx = leftStk(sp) rightNdx = rightStk(sp) sp = sp - 1 If sp = 0 Then Exit Do End If Loop End Function
Moikka taas.
Jo vain, nyt rupes Lyyti kirjottaa!
Kyllä pelittää just niinku pitääki, mutta to checkbutton??? En oikee käsitä.
Mikä vaikutus sillä pitäs olla?
Listata pelkät tiedostonimet jos ei oo klikattu, ja listata kansio\tiedostonimet jos on klikattu? Ymmärsinkö oikein?
Niin, ja sitte kun yritin "ANTAA PALAA" C: kansiolla tuli virhe 'Premission diened'.
Ei sinänsä mitään merkitystä, koska tartten jutskaa pelkästään CD\DVD levyjen lukemiseeen...
Kiitos Hycke ja Nea!
-Happy-
Moikka taas Happy & Hycke!
rupes senverran jurppiin toi Hycke'n hieno esimerkki että päätin vääntää vielä tämän...ilman Extra Dll'iä...
Private Const ARKISTOITU = 0 Private Const NORMAALI = 1 Private Const VAIN_LUKU = 2 Private Const PIILOTETTU = 3 Private Const SYSTEEMI = 4 Private Const EI_ATTR = 5 Dim asema$, root$, tiedosto$, polku$ Dim kerrosTag%, kerros%, loopExit As Boolean Dim valinta As Integer, fileArray() Private Sub Form_Load() 'Formille: pari ListBoxia, 6 Radio-nappulaa 'CheckBoxi & Nappi 'säädöt: 'Option1() - Appearance: Flat, Index: 0, Style: 1 'Option2() - Indeksit 0-5 Dim Drv() As String, i As Integer, j As Integer For i = 65 To 90 On Error Resume Next ChDrive$ (Chr(i) & ":") If Err = 0 Then ReDim Preserve Drv(j) Drv(j) = Chr(i) & ":" j = j + 1 Else Err.Clear End If Next i For i = 0 To UBound(Drv) Load Option1(i) Option1(i).Top = Option1(i - 1).Top Option1(i).Left = Option1(i - 1).Left + _ Option1(i - 1).Width + 150 Option1(i).Visible = True Option1(i).TabIndex = Option1(i - 1).TabIndex + 1 Option1(i).Caption = Drv(i) Next i For i = Option1.Count To _ Option2.Count - 1 + Option1.Count Option2(i - Option1.Count).TabIndex = i Next i Erase Drv Me.Caption = asema$ & " - asema" Command1.Caption = "ANNA PALAA" Option1(0).value = True Option2(Option2.Count - 1).value = True Command1.TabIndex = Option1.Count + Option2.Count List1.TabIndex = Command1.TabIndex + 1 List2.TabIndex = List1.TabIndex + 1 End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Me.MousePointer = 0: loopExit = True: End End Sub Private Sub Command1_Click() SetCtlState List1.Clear List2.Clear ChDrive$ (asema$) root$ = asema$ + "\" List1.AddItem root$ Me.MousePointer = 11 Me.Caption = asema$ & " asema - listataan..." Command1.Enabled = False kerrosTag% = 0: kerros% = 0 polku$ = "" GetFoldersAndFiles root$, 0 Me.MousePointer = 0 SetCtlState Me.Caption = asema$ & " asema - listattu" End Sub Private Sub Option1_Click(Index As Integer) List1.Clear List2.Clear asema$ = Option1(Index).Caption Me.Caption = asema$ & " asema" End Sub Sub SetCtlState() For i = 0 To Option1.Count - 1 Option1(i).Enabled = Not Option1(i).Enabled Next i For i = 0 To Option2.Count - 1 Option2(i).Enabled = Not Option2(i).Enabled Next i Check1.Enabled = Not Check1.Enabled Command1.Enabled = Not Command1.Enabled End Sub Sub GetFoldersAndFiles(hak$, kerros%) ReDim hakemistot(0) ReDim fileArray(0) x$ = Dir(hak$, vbDirectory) Do While x$ <> "" DoEvents If loopExit Then Exit Sub If GetAttr(hak$ + x$) = vbDirectory _ And Left$(x$, 1) <> "." Then hakemistot(UBound(hakemistot)) = x$ ReDim Preserve hakemistot(UBound(hakemistot) + 1) End If x$ = Dir Loop For i = 0 To UBound(hakemistot) - 1 DoEvents If loopExit Then Exit Sub List1.AddItem String$((kerros% + 1) * 4, "- -") + hakemistot(i) List1.ListIndex = List1.ListCount - 1 If kerros% < 2 Then polku$ = root$ ElseIf kerros% > 1 And kerros% <= kerrosTag% Then polku$ = Left(polku$, Len(polku$) - 1): flash% = 0 Select Case Abs(kerros% - kerrosTag%) Case 0 For j = Len(polku$) To 3 Step -1 If Mid(polku$, j, 1) = "\" Then polku$ = Left(polku$, j): Exit For End If Next j Case Else For j = Len(polku$) To 3 Step -1 If Mid(polku$, j, 1) = "\" Then flash% = flash% + 1 If flash% = Abs(kerros% - kerrosTag%) + 1 Then polku$ = Left(polku$, j): Exit For End If Next j End Select End If kerrosTag% = kerros% polku$ = polku$ + hakemistot(i) Select Case valinta Case ARKISTOITU: y$ = Dir$(hak$, vbArchive) Case NORMAALI: y$ = Dir$(hak$, vbNormal) Case VAIN_LUKU: y$ = Dir$(hak$, vbReadOnly) Case PIILOTETTU: y$ = Dir$(hak$, vbHidden) Case SYSTEEMI: y$ = Dir$(hak$, vbSystem) Case EI_ATTR: y$ = Dir$(hak$) End Select polku$ = polku$ + "\" List2.AddItem polku$ Do While y$ <> "": DoEvents: If loopExit Then Exit Sub fileArray(UBound(fileArray)) = y$ ReDim Preserve fileArray(UBound(fileArray) + 1) If UBound(fileArray) > 0 Then If Check1.value = 0 Then List2.AddItem fileArray(UBound(fileArray) - 1) If List2.ListIndex < 32766 Then _ List2.ListIndex = List2.ListIndex + 1 End If End If y$ = Dir Loop If Check1.value = 1 Then sArr& = SortArray(fileArray, , False) For k = 0 To UBound(fileArray) - 1 DoEvents If loopExit Then Exit Sub List2.AddItem fileArray(k) If List2.ListIndex < 32766 Then _ List2.ListIndex = List2.ListIndex + 1 Next End If List2.AddItem " " 'Alt + 255 kerros% = kerros% + 1 GetFoldersAndFiles hak$ + hakemistot(i) + "\", kerros% Next i kerros% = kerros% - 1 End Sub Function SortArray(arr As Variant, _ Optional numEls As Variant, _ Optional descending As Boolean) Dim value As Variant, temp As Variant Dim sp As Integer Dim leftStk(32) As Long, rightStk(32) As Long Dim leftNdx As Long, rightNdx As Long Dim i As Long, j As Long DoEvents If IsMissing(numEls) Then _ numEls = UBound(arr) leftNdx = LBound(arr) rightNdx = numEls sp = 1 leftStk(sp) = leftNdx rightStk(sp) = rightNdx Do: If loopExit Then Exit Function If rightNdx > leftNdx Then value = arr(rightNdx) i = leftNdx - 1 j = rightNdx If descending Then Do: If loopExit Then Exit Function Do: If loopExit Then Exit Function: i = i + 1: Loop Until arr(i) <= value Do: If loopExit Then Exit Function j = j - 1: Loop Until j = _ leftNdx Or arr(j) >= value temp = arr(i) arr(i) = arr(j) arr(j) = temp Loop Until j <= i Else Do: If loopExit Then Exit Function Do: If loopExit Then Exit Function i = i + 1:: If loopExit Then Exit Function Loop Until arr(i) >= value Do: j = j - 1: If loopExit Then Exit Function Loop Until j = leftNdx Or arr(j) <= value temp = arr(i) arr(i) = arr(j) arr(j) = temp Loop Until j <= i End If temp = arr(j) arr(j) = arr(i) arr(i) = arr(rightNdx) arr(rightNdx) = temp sp = sp + 1 If (i - leftNdx) > (rightNdx - i) Then leftStk(sp) = leftNdx rightStk(sp) = i - 1 leftNdx = i + 1 Else leftStk(sp) = i + 1 rightStk(sp) = rightNdx rightNdx = i - 1 End If Else leftNdx = leftStk(sp) rightNdx = rightStk(sp) sp = sp - 1 If sp = 0 Then Exit Do End If Loop End Function Private Sub Option2_Click(Index As Integer) valinta = Index End Sub
ai niin se CheckBox lättää sorttauksen siihen List2:een niin, että filut listautuu aakkosjärjestyksessä kansioittain. Tässä viimeisimmässä viritelmässä on vähän vielä lisää säätöjä...
No niin :)
Sitten seuraavaksi pitää yrittää saada tämä zysteemi näkyvii Listview objektilla...(On vaan niin paljon siistimpi ;) )
Jotain kehitelmiä on jo päässä, mutta apuja saa toki antaa...
Kiitti Nea ja Hycke.
-Happy-
Heippa taas Happy!
Joo, kyllä ListView on siisti - ehdottaisin kuitenkin, että toteutat homman ihan vaan perinteiseen Windows tyyliin, elikä hakemistolistaus TreeView-kontrolliin ja tiedostolistaus ListView-kontrolliin ja sitten sulla onkin aivan ikioma Explorer...
Heippa Taas!
Tassä olis nyt sellanen listview hässäkkä.....
Kokeilkaa juttua, ja kertokaa miksi se heittää jonkun saamarin errorin ku yrittää listata c:-aseman juurta. Muutenhan toi näyttäis aika hyvältä ;)
On siinä vielä sellanen juttu että kun käy jossain muualla esim d:-asemassa, niin sen jälkeen Text1 ei päivitä itseään vaikka kuinka räppää Dir1:stä
Ja sen jälkee se yrittää lukea C:-aseman juuresta, ja sitte tulee se saamarin tiltti..... APUVA !
No tossa on toi koodin pätkä....
' Referenssi - Microsoft Scripting Runtime ' Komponenteista - Microsoft windows common controls 6.0 (SP6) ' Formille: ' 1 kpl Listview ' 1 kpl DriveListBox ' 1 kpl TextBox ' 1 kpl DirListBox ' 3 kpl CommandButton Option Explicit Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long Private Const MAX_PATH = 260 Private Const FILE_ATTRIBUTE_DIRECTORY As Long = &H10 Private Const vbDot = 46 'Private m_fi As CFileInfo 'Private m_vi As CFileVersionInfo Public Keskeytä As Boolean Dim filecount As Integer Dim searchcount As Integer Dim columncount As Integer Dim count_dir As Integer Dim file_count As Integer Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Private Type FILE_PARAMS bRecurse As Boolean sFileRoot As String sFileNameExt As String End Type Private Sub command2_Click() Keskeytä = MsgBox("Listaus keskeytetty.", vbInformation) Command2.Visible = False Command1.Visible = True End Sub Private Sub Command1_Click() Dim fp As FILE_PARAMS Dim tstart As Single Dim tend As Single, i As Integer, found As Integer Command1.Visible = False With fp .sFileRoot = Text1.Text .sFileNameExt = "*.*" .bRecurse = 1 End With ListView1.Enabled = True ListView1.ListItems.Clear DoEvents Call Etsitiedot(fp) Command1.Visible = True End Sub Private Sub Dir1_Change() Text1.Text = Dir1.Path ListView1.Enabled = False ListView1.ListItems.Clear End Sub Private Sub Drive1_Change() On Error GoTo Eilevyä Dir1.Path = Drive1.Drive Text1.Text = Drive1.Drive ListView1.Enabled = False ListView1.ListItems.Clear Exit Sub Eilevyä: Dim Levy As Integer Levy = MsgBox("Asemassa ei levyä, aseta levy...", vbOKOnly + vbCritical) Drive1.Drive = "C:" Text1.Text = Dir1.Path Exit Sub End Sub Private Sub Form_Load() Dim appDir As String, nextline As String Dim found As Integer, pos1 As Integer, pos2 As Integer, i As Integer Dim lResult As Long Dim tempname As String With ListView1 .FullRowSelect = True .GridLines = True .HideSelection = False .View = lvwReport End With Command1.Caption = "Listaa" Command2.Caption = "Keskeytä" Command3.Caption = "Lopeta Ohjelma" Drive1.Drive = "C:\" Dir1.Path = Drive1.Drive Text1.Text = Dir1.Path Call Otsikot End Sub Private Sub Otsikot() ListView1.ColumnHeaders.Add 1, , "Tiedosto polku" ListView1.ColumnHeaders.Add 2, , "Tiedosto" ListView1.ColumnHeaders.Add 3, , "Tiedosto Luotu" ListView1.ColumnHeaders.Add 4, , "Koko (kb)" End Sub Public Sub dolist(file As String, root As String) Dim lItem As ListItem Set lItem = ListView1.ListItems.Add(, , root & file) lItem.SubItems(1) = file lItem.SubItems(2) = Format(FileDateTime(root & file), "DD-MMM-YYYY") lItem.SubItems(3) = Format((Round(FileLen(root & file))), "###,###,###0") End Sub Private Sub Etsitiedot(fp As FILE_PARAMS) Dim wfd As WIN32_FIND_DATA Dim hFile As Long Dim sPath As String Dim sRoot As String sRoot = QualifyPath(fp.sFileRoot) sPath = sRoot & "*.*" hFile = FindFirstFile(sPath, wfd) Call Haetiedot(fp) Do DoEvents If (wfd.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then If fp.bRecurse Then If Asc(wfd.cFileName) <> vbDot Then fp.sFileRoot = sRoot & TrimNull(wfd.cFileName) count_dir = count_dir + 1 If Keskeytä Then Exit Sub End If Call Etsitiedot(fp) End If End If End If Loop While FindNextFile(hFile, wfd) hFile = FindClose(hFile) If Keskeytä Then Exit Sub End If End Sub Private Function Haetiedot(fp As FILE_PARAMS) As Long Dim wfd As WIN32_FIND_DATA, t As WIN32_FIND_DATA Dim hFile As Long, sPath As String, sRoot As String, sTmp As String, sExt As String sRoot = QualifyPath(fp.sFileRoot) sPath = sRoot & fp.sFileNameExt hFile = FindFirstFile(sPath, wfd) If Keskeytä Then End If Do sTmp = TrimNull(wfd.cFileName) If (sTmp = "..") Or (sTmp = ".") Then Else filecount = filecount + 1 file_count = file_count + 1 searchcount = searchcount + 1 Call dolist(sTmp, sRoot) End If Loop While FindNextFile(hFile, wfd) hFile = FindClose(hFile) End Function Public Function TrimNull(startstr As String) As String Dim pos As Integer pos = InStr(startstr, Chr$(0)) If pos Then TrimNull = Left$(startstr, pos - 1) Exit Function End If TrimNull = startstr End Function Private Function QualifyPath(sPath As String) As String If Right$(sPath, 1) <> "\" Then QualifyPath = sPath & "\" ' Else: QualifyPath = sPath End If End Function Private Sub Command3_click() Unload Me End Sub
Antakaa palautetta, ja ois kiva jos joku löytäis "vastauksen"/ korjaus ehdotuksen noihin virhe hässäköihin.
-Happy-
Heippa taas Happy!
Text1 ei päivittele ohjelmassasi yhtään mitään ei varsinkaan itseään. Riittää, että päivitys tapahtuu Dir1_Change - tapahtumassa kokeile vaikkapa näin...
Private Sub Form_Load() '.... '.... '.... Command3.Caption = "Lopeta Ohjelma" Dir1.Path = Left(Dir1.Path, 3) Text1 = Dir1.Path Call Otsikot End Sub Private Sub Drive1_Change() On Error GoTo Eilevyä Dir1.Path = Drive1.Drive 'ListView1.Enabled = False 'tai True mihin tarvit..? ListView1.ListItems.Clear Exit Sub Eilevyä: Err.Clear MsgBox "Asemassa ei levyä, aseta levy...", vbOKOnly + vbCritical Exit Sub End Sub
Muuten toi sun jutskas toimii kyllä ainaski mun kooneella ihan OK. Voisi ehkä olla kuitenkin hyödyllistä nollata laskurit (filecount etc.) aina sopivassa välissä. Olet aikaisemminkin palautellut kommentteja C:-aseman juuressa operoidessasi tapahtuvista tilttauksista, mikä on hieman ihmetyttänyt... Operoitko Admin-oikeuksin or Not? Tsekkaa mitä se virhe palauttaa elikä rakenna virheenkäsittelijä siihen aliohjelmaan, jonka ajaminen palauttaa virheen siirryttäessä C:-aseman juureen...esim.
Sub theAliohjelma() On Error GoTo theAliohjelmaErrorHandler '... '... '... Exit_Proc: Exit Sub theAliohjelmaErrorHandler: MsgBox "Virhenumero: " & Err & VbCrLf _ & "Virhe: " Error$ Err.Clear GoTo Exit_Proc End Sub
EDIT: yks pikku jutska nyt kun luin ton koodin kokonaan...
Boolean - bRecurse
Mikäli arvoksi halutaan asettaa True
.bRecurse = -1
Mikäli arvoksi halutaan asettaa False
.bRecurse = 0
Moikka taas.
Lisäsin sen virheenkäsitteliän...
Ja nyt se herjaa jokaisella asemalla.
c: aseman juuressa virhe = "Invalid procedure call (Error 5)", jos
.bRecurse = true.
Jos taas
.bRecurse = false
virhe = "0"
muissa c:-aseman kansioissa ja muilla asemilla virhe = "0"
mun käsityksen mukaan "0" virhettä ei edes ole, mutta silti se ilmottaa tollasesta virheestä.
Oikeudet on muuten Admin..
-Happy-
Kuules nyt Happy!
Jos sun aliohjelmasi alussa on lause On Error Goto theAliohjelmaErrorHandler
ja aliohjelmasi viimeiset rivit on seuraavanlaisia...
Exit_Proc: '** takaisin tänne jos Err oli > 0 Exit Sub 'ja tässä poistutaan aliohjelmasta oli Err >= 0 theAliohjelmaErrorHandler: '...niin täälä ei edes käydä mikäli Err = 0 MsgBox "Virhenumero: " & Err & VbCrLf _ & "Virhe: " Error$ Err.Clear 'tassä nollataan virhe jos päästään tänne asti GoTo Exit_Proc 'ja tästä hypätään ** End Sub
...ja sit toinen jutska...jos sun virustorjuntaohjelmasi mahdollistaa C:-aseman juuren listaamisen ulkoisilla ohjelmilla niin varmasti tökkii tahi sitten sulla on virus joka yrittää estää paljastumisensa...
EDIT: pistä jokaisen aliohjelmasi alkuun vielä seuraavanlainen pikku testi...
If Right(Text1, 1) = ":" Or Right(Dir1.Path, 1) = ":" Then MsgBox "TÖÖT! homma kusee, koska: " & vbCrLf & _ "pelkkä asematunnuskirjain" & vbCrLf & _ "ja kaksoispiste ei ole polku..." & vbCrLf & _ "eli ei siis välttämättä kannata" & vbCrLf & _ "hakea samaa tietoa samaan aikaan" & vbCrLf & _ "kahdesta eri paikasta..." & vbCrLf & _ "vrt. esim. Text1 & Dir1..." & vbCrLf & _ "MISSÄ muuten luuraa " & _ Chr(34) & "\" & Chr(34) & " ?" End If
Heippa Taas Nea.
Toi mun virheenkäsittelijä oli päin per....ä!
Tein sen sitte uudelleen niinku olit tohon tuon mallin laittanu...
No.
Ei tuu virheilmotuksia, mutta eipä tuo vieläkään listaa C:-asemaa ku ehkä jonkun 20-30 kansiota (En oo laskenu, ei kuitenkaa kokonaan.)
Otin sitte uudellee ton virheenkäsittelijän pois ja debuggasin koodia...
Public Sub dolist(file As String, root As String) Dim lItem As ListItem Set lItem = ListView1.ListItems.Add(, , root & file) lItem.SubItems(1) = file ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' TÄHÄN KOHTAAN SE TOKSÄHTÄÄ ' ' ' ' lItem.SubItems(2) = Format(FileDateTime(root & file), "DD-MMM-YYYY") ' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' lItem.SubItems(3) = Format((Round(FileLen(root & file))), "###,###,###0") End Sub
Eli root = "C:\$Recycle.bin\S ja aivan pirusti numeroita\"
ja file = ""
Eli ei kait sitte löydy tiedostoa/luontipäivää????
Kokelin sitte sellasta ETTÄ, vaikka tulis virhe, jatketaa silti.
Elikkä tälläviisii.
Private Function Haetiedot(fp As FILE_PARAMS) As Long On Error GoTo virhe Dim wfd As WIN32_FIND_DATA, t As WIN32_FIND_DATA Dim hFile As Long, sPath As String, sRoot As String, sTmp As String, sExt As String sRoot = QualifyPath(fp.sFileRoot) sPath = sRoot & fp.sFileNameExt hFile = FindFirstFile(sPath, wfd) If Keskeytä Then End If Do sTmp = TrimNull(wfd.cFileName) If (sTmp = "..") Or (sTmp = ".") Then Else filecount = filecount + 1 file_count = file_count + 1 searchcount = searchcount + 1 Call dolist(sTmp, sRoot) End If Loop While FindNextFile(hFile, wfd) hFile = FindClose(hFile) virhe: Dim Virheet As Integer Virheet = Virheet + 1 Exit Function End Function
Nyt kyllä listaa pidemmälle, mutta ei siltikään koko c:- asemaa...
Niin ja sitte vielä toi sun EDIT: juttu. Text1 kyllä näyttää just oikein... eli "C:\".
Viruksiakaan ei mukamas löytyny (McAfee VirusSscan ver.12)
Pitää vielä räpätä tätä lisää...
Ps. Eikö sulla muka herjaa mistään, ja listaako se koko sun c:-aseman (Kokeilistiko...Please?)
Terv. -Happy-
EDIT:
Tein tohon ohjelmaan laskurin joka laskee kansiot....
Kyllä se sittenkin lukee kaikki kansiot ja tiedostot.
Kansioita oli 14638
Tiedostoja oli 32767
(Taitaa kyllä laskea kansiotkin tiedostoiksi...vaan eipä sillä oo väliä.)
Mutta toi ListView objekti ei vissiin pysty käsittelemään noin paljon mazkua?
-Happy-
dir /s *.mp3 > filut.txt :D
Heippa taas Happy & groovyb
@groovyb: esimerkkisihän toimii...lähes sellaisenaan...
'formille: rtfBoxi & nappi 'viittaus: Microsoft WMI Scripting V1.2 Library '(C:\WINDOWS\system32\wbem\wbemdisp.TLB) 'esitellään API-funktio Private Declare Function ShellExecute Lib _ "Shell32.dll" Alias "ShellExecuteA" (ByVal _ hwnd As Long, ByVal lpOperation As String, _ ByVal lpFile As String, ByVal lpParameters As _ String, ByVal lpDirectory As String, ByVal _ nshowcmd As Long) As Long 'alustetaan taulukko ja merkkijonomuuttuja 'kaikkien formin aliohjelmien käyttöön Dim Drv() As String, kama As String Private Sub Form_Load() Dim i As Integer, j As Integer 'esi-asetetaan taulukolle raja... ReDim Drv(0) As String 'asetetaan laskurin rajarvoiksi kirjainten: 'A-Z ASCII arvot... For i = 65 To 90 On Error Resume Next 'yritetään siirtymistä silmukan laskuriarvon, ASCII-merkiksi 'muutetun arvon, ja kaksoispisteen yhdistelmän muodostaman 'asematunnuksen osoittamaan asemaan... ChDrive$ (Chr(i) & ":") 'jos ei aiheudu virhettä... If Err = 0 Then '...kasvatetaan taulukon kokoa 1:llä... ReDim Preserve Drv(j) '...ja lisätään taulukkoon silmukan laskuriarvon 'ASCII-merkiksi muutetun arvon & kaksoispisteen 'yhdistelmästä muodostuva asematunnus... Drv(j) = Chr(i) & ":" j = j + 1 'jos aiheutui virhe... Else 'nollataan virhe-olio Err.Clear End If Next i End Sub Private Sub Form_QueryUnload( _ Cancel As Integer, UnloadMode As Integer) 'tuhotaan taulukko ja lopetetaan ohjelma... Erase Drv: End End Sub Private Sub Command1_Click() 'jos taulukon ensimmäinen alkio ei ole tyhjä niin... If Drv(0) > "" Then For i = 0 To UBound(Drv) 'annetaan tilapäisesti prosessoriaikaa... z& = Not DoEvents() '"vain" tätä tehtävää varten... 'eli suoritetaan komentorivillä dir listaus 'komentorivi-parametrien ehdoilla... z& = ShellExecute(Me.hwnd, vbNullString, _ "cmd", "/c dir /s /b *.mp3; *.wma; *.jne >" & Drv(0) & "\" _ & Left(Drv(i), 1) & "audiokama.dat", Drv(i) & "\", 2) Next i kama = "" 'siirrytään aliohjelmaan tutkimaan komentorivin tila... TsekkaaCmd 'siirrytään aliohjelmaan tutkimaan listattujen tiedostojen tila... OnkoKamaa (0) TapaFilut (0) Else MsgBox "Ohjelmassa on pahasti bugeja!", _ vbCritical, "Virheilmot": Unload Me End If End Sub Sub TsekkaaCmd() '1* sallitaan jälleen tapahtumien suorittaminen DoEvents 'alustetaan objekti & tarvittavat muuttujat... Dim Prosessit, Prosessi, IsRunning As Boolean Set Prosessit = GetObject _ ("winmgmts:{impersonationLevel=impersonate}") _ .InstancesOf("Win32_Process") 'tsekataan prosesseista 'pyöriikö' cmd.exe yhä... For Each Prosessi In Prosessit With Prosessi If LCase(.Name) = "cmd.exe" Then '...ja jos cmd.exe 'pöyörii' asetetaan 'muuttujan totuusarvoksi TOSI... 'ja poistutaan silmukasta... IsRunning = True: Exit For End If End With Next 'tuhotaan objekti... Set Prosessit = Nothing 'jos muuttujan totuusarvo on TOSI... If IsRunning Then '4* käydään silmukassa "nukkumassa"... '...ja tsekataan tila uudestaan... Viive 0.5: TsekkaaCmd End If End Sub Sub OnkoKamaa(i As Integer) '1* DoEvents '2* virheen aiheutuessa: 'siirrytään seuraavaan tehtävään... On Error Resume Next 'käydään silmukassa läpi taulukon kaikki alkiot... For i = 0 To UBound(Drv) '3* yriteään avata taulukon ensimmäisen alkion 'ja kenoviivan yhdistelmästä muodostetusta 'kansiopolusta laskurin arvon osoittaman 'taulukon alkion ensimmäisen merkin ja 'merkkijonon "audiokama.dat" yhdistelmästä 'muodostuvan tiedostonimen mukainen tiedosto... Open Drv(0) & "\" & Left(Drv(i), 1) _ & "audiokama.dat" For Input As #1 'jos aiheutui virhe... If Err > 0 Then 'nollataan virhe, aiheutetaan viive & tsekataan uudestaan... Err.Clear: Viive 0.5: OnkoKamaa (i) End If kama = kama & Input$(LOF(1), 1): Close #1 Next i 'vaihdetaan DOS-ääkköset WIN-ääkkösiin... kama = Replace(kama, "†", "ö") kama = Replace(kama, "ä", "ä") kama = Replace(kama, "ö", "ö") kama = Replace(kama, "", "Å") kama = Replace(kama, "Ž", "Ä") kama = Replace(kama, "™", "Ö") RichTextBox1 = kama 'nollataan virheolio... On Error GoTo 0 End Sub Sub TapaFilut(i As Integer) 'suljetaan "kaikki" avoimet tiedostot Close '2* On Error Resume Next 'käydään läpi taulukon kaikki alkiot... For i = 0 To UBound(Drv) '3* ja poistetaan... Kill Drv(0) & "\" _ & Left(Drv(i), 1) & "audiokama.dat" Next i If Err > 0 Then '4* Err.Clear: Viive 0.5: TapaFilut (i) End If Err.Clear On Error GoTo 0 End Sub Sub Viive(aika As Single) aika = Timer + aika Do While aika > Timer: DoEvents: Loop End Sub
Aihe on jo aika vanha, joten et voi enää vastata siihen.