scandirs.frm

不错的一个VB菜单设计 界面和功能都不错

VERSION 5.00
Begin VB.Form frmScanDirs 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Scan directories"
   ClientHeight    =   3870
   ClientLeft      =   45
   ClientTop       =   360
   ClientWidth     =   7320
   Icon            =   "ScanDirs.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3870
   ScaleWidth      =   7320
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Begin VB.TextBox txtPatern 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   330
      Left            =   5445
      TabIndex        =   4
      Text            =   "*.*"
      Top             =   315
      Width           =   1725
   End
   Begin VB.TextBox txtPath 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   330
      Left            =   135
      TabIndex        =   2
      Text            =   "c:\"
      Top             =   315
      Width           =   5190
   End
   Begin VB.CommandButton cmdSearch 
      Caption         =   "Search"
      Default         =   -1  'True
      Height          =   390
      Left            =   135
      TabIndex        =   1
      Top             =   765
      Width           =   1215
   End
   Begin VB.ListBox lstFile 
      Height          =   2400
      Left            =   135
      TabIndex        =   0
      Top             =   1350
      Width           =   7050
   End
   Begin VB.Label lblLabel 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Pattern"
      Height          =   195
      Index           =   1
      Left            =   5445
      TabIndex        =   5
      Top             =   90
      Width           =   510
   End
   Begin VB.Label lblLabel 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Directory to scan"
      Height          =   195
      Index           =   0
      Left            =   135
      TabIndex        =   3
      Top             =   90
      Width           =   1200
   End
End
Attribute VB_Name = "frmScanDirs"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit


Private Const MAX_PATH = 260

Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_NORMAL = &H80


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 Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) 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 Sub cmdSearch_Click()
  Dim vntDir   As Variant
  Dim lngDirs  As Long
  Dim cllDirs  As New Collection
  
  Screen.MousePointer = vbHourglass
  lngDirs = FindDirs(txtPath, cllDirs)
  Screen.MousePointer = vbArrow
  
  Call lstFile.Clear

  If lngDirs > 0 Then
    Screen.MousePointer = vbHourglass
    For Each vntDir In cllDirs
      Call lstFile.AddItem(vntDir)
    Next
    Screen.MousePointer = vbArrow
  Else
    Call MsgBox("Error accesing " & Me.txtPath & " or no subdirs found")
  End If
End Sub



' BORRAME
Private Function x(ByVal xx As String) As String
  x = VBA.Mid$(xx, 1, InStr(xx, VBA.Chr$(0)) - 1)
End Function

Public Function FindDirs(ByVal DirPath As String, _
                         ByRef cllDirs As Collection) As Long
  Dim FindData       As WIN32_FIND_DATA
  Dim FindHandle     As Long
  Dim FindNextHandle As Long
  Dim strBuffer      As String
  Dim lngDirs        As Long
  
  DirPath = VBA.Trim$(DirPath)

  If VBA.Right$(DirPath, 1) <> "\" Then
    DirPath = DirPath & "\"
  End If

  ' Find the first file in the selected directory

  FindHandle = FindFirstFile(DirPath & "*.*", FindData)
  If FindHandle <> 0 Then
    strBuffer = x(FindData.cFileName)
    If FindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY Then
      ' It's a directory
      If Left$(strBuffer, 1) <> "." And Left$(strBuffer, 2) <> ".." Then
        Call cllDirs.Add(DirPath & strBuffer & "\")
        lngDirs = lngDirs + 1
        lngDirs = lngDirs + FindDirs(DirPath & VBA.Trim$(strBuffer) & "\", cllDirs)
      End If
    End If
    
    Do
      FindNextHandle = FindNextFile(FindHandle, FindData)
      If FindNextHandle <> 0 Then
        strBuffer = x(FindData.cFileName)
        If FindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY Then
          ' It's a directory
          If Left$(strBuffer, 1) <> "." And Left$(strBuffer, 2) <> ".." Then
            Call cllDirs.Add(DirPath & strBuffer & "\")
            lngDirs = lngDirs + 1
            lngDirs = lngDirs + FindDirs(DirPath & VBA.Trim$(strBuffer) & "\", cllDirs)
          End If
        End If
      Else
        Exit Do
      End If
    Loop
  End If
  FindDirs = lngDirs
  Call FindClose(FindHandle)
End Function