Keskustelu: Ohjelmointikysymykset: VBA: Kansiot, alikansiot, tiedostot

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

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

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

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

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

' 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

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

Sub theAliohjelma()
On Error GoTo theAliohjelmaErrorHandler

'...
'...
'...

Exit_Proc:
Exit Sub

theAliohjelmaErrorHandler:
MsgBox "Virhenumero: " & Err & VbCrLf _
& "Virhe: " Error$
Err.Clear
GoTo Exit_Proc

End Sub

 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

'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