14/05/2012, 12:46
Kod:
Option Compare Database
Option Explicit
Private Type tRESULTS
strName As String
strFullPath As String
strTypeName As String
lngSize As Long
varTimeCreated As Variant
varTimeAccessed As Variant
varTimeWritten As Variant
strMajorVersion As String
strMinorVersion As String
strMajorBuild As String
strMinorBuild As String
End Type
Private WithEvents mclsFO As FileSystemEx.FileObject
Private atResults() As tRESULTS
Private mblnCancel As Boolean
Private mblnSingleFile As Boolean
Private mclsFiles As FileSystemEx.Files
Private mclsFile As FileSystemEx.File
Public Property Get SearchItem() As FileSystemEx.File
If mblnSingleFile Then
Set SearchItem = mclsFiles
Else
Set SearchItem = mclsFO.FilesFound( _
Me.lstResults)
End If
End Property
Private Sub cmdCancel_Click()
mblnCancel = True
End Sub
Private Sub cmdGetInfo_Click()
On Error GoTo ErrHandler
Dim strFile As String
Dim clsCommDlg As CCommonDialog
Set clsCommDlg = New CCommonDialog
With clsCommDlg
.hWnd = Me.hWnd
.StartDir = CurDir()
.Title = "Please select a file to view details"
.Filter = "All Files (*.*)|*.*"
.ModeOpen = True
strFile = .Action
End With
If Len(strFile) > 0 Then
Set mclsFiles = New FileSystemEx.Files
Set mclsFile = mclsFiles.GetInfoForFile(strFile)
mblnSingleFile = True
DoCmd.OpenForm "frmDetails", windowMode:=acDialog
End If
ExitHere:
Exit Sub
ErrHandler:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description, _
vbOKOnly + vbCritical, Err.Source
Resume ExitHere
End Sub
Private Sub cmdStartSearch_Click()
On Error GoTo ErrHandler
Set mclsFO = New FileObject
ReDim atResults(0)
With Me
.txtSearchCriteria.SetFocus
.cmdCancel.Enabled = True
.cmdStartSearch.Enabled = False
.lstResults.RowSourceType = vbNullString
End With
With mclsFO
.LocalDrivesOnly = Me.chkLocalDrivesOnly
.SearchPath = Me.txtSearchPath
.IncludeSubFolders = Me.chkIncludeSubFolders
.FindFile Me.txtSearchCriteria
End With
Me.lstResults.RowSourceType = "fListFill"
Me.lblSearchStatus.Caption = vbNullString
ExitHere:
With Me
.txtSearchCriteria.SetFocus
.cmdCancel.Enabled = False
.cmdStartSearch.Enabled = True
End With
Me.lblFilesFound.Caption = vbNullString
mblnCancel = False
Exit Sub
ErrHandler:
With Err
MsgBox "Error: " & .Number & vbCrLf & .Description, _
vbCritical + vbOKOnly, .Source
End With
Resume ExitHere
End Sub
Private Sub lstResults_AfterUpdate()
DoCmd.OpenForm "frmDetails", windowMode:=acDialog
End Sub
Private Sub mclsFO_Found(ByVal FileInfo As FileSystemEx.[_File])
Dim intI As Integer
With Me.lblFilesFound
.Caption = "Found " & mclsFO.FilesFound.Count & " file(s)."
End With
intI = UBound(atResults)
With atResults(intI)
.lngSize = FileInfo.Size
.strFullPath = FileInfo.FullPath
.strMajorBuild = FileInfo.MajorBuild
.strMajorVersion = FileInfo.MajorVersion
.strMinorBuild = FileInfo.MinorBuild
.strMinorVersion = FileInfo.MinorVersion
.strName = FileInfo.Name
.strTypeName = FileInfo.TypeName
.varTimeAccessed = FileInfo.TimeLastAccessed
.varTimeCreated = FileInfo.TimeCreated
.varTimeWritten = FileInfo.TimeLastWritten
End With
ReDim Preserve atResults(intI + 1)
End Sub
Private Sub mclsFO_SearchStatus(ByVal CurrentFolder As String, Cancel
As Boolean)
Me.lblSearchStatus.Caption = CurrentFolder
Cancel = mblnCancel
End Sub
Function fListFill(ctl As Control, varID As Variant, varRow As
Variant, _
varCol As Variant, varCode As Variant) As Variant
'Callback function to fill the multirow-multicolumn listbox
'
Dim varRet As Variant
Const TWIPS = 1440
Const COLUMN_COUNT = 3
On Error GoTo ErrHandler
Select Case varCode
Case acLBInitialize
varRet = True
Case acLBOpen
varRet = Timer
Case acLBGetRowCount
varRet = UBound(atResults)
Case acLBGetColumnWidth
'Set the widths of the column
'TWIPS converts to the appropriate
'VBA Units of measurements, TWIPS.
Select Case varCol
Case 0:
varRet = 2.8 * TWIPS
Case 1:
varRet = 0.5 * TWIPS
Case 2:
varRet = 0.5 * TWIPS
End Select
Case acLBGetColumnCount
varRet = COLUMN_COUNT
Case acLBGetValue
'Return the particular class member's value
'depending on which column is being populated
Select Case varCol
Case 0:
' First row contains column headings
If varRow = 0 Then
varRet = "Path"
Else
varRet = atResults(varRow).strFullPath
End If
Case 1:
If varRow = 0 Then
varRet = "Size"
Else
varRet = atResults(varRow).lngSize
End If
Case 2:
If varRow = 0 Then
varRet = "Type"
Else
varRet = atResults(varRow).strTypeName
End If
End Select
End Select
fListFill = varRet
ExitHere:
Exit Function
ErrHandler:
Resume ExitHere
End Function
Option Compare Database
Option Explicit
Private Type OPENFILENAME
lStructSize As Long
hWnd As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function GetOpenFileName Lib _
"comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib _
"comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_SAVE = 0
Private Const OFN_OPEN = 1
Private lngHwnd As Long
Private wMode As Integer
Private szDialogTitle As String
Private szFileName As String
Private szFilter As String
Private szDefDir As String
Private szDefExt As String
Private szFileTitle As String
Private szFileDir As String
Private intFilterIndex As Integer
Public Function Action() As String
Dim x As Long, OFN As OPENFILENAME
Call SetDefs
With OFN
.lStructSize = Len(OFN)
.hWnd = lngHwnd
.lpstrTitle = szDialogTitle
.lpstrFile = szFileName & String$(250 - Len(szFileName), 0)
.nMaxFile = 255
.lpstrFileTitle = String$(255, 0)
.nMaxFileTitle = 255
.lpstrFilter = szFilter
.nFilterIndex = intFilterIndex
.lpstrInitialDir = szDefDir
.lpstrDefExt = szDefExt
If wMode = 1 Then
OFN.Flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or
OFN_FILEMUSTEXIST
x = GetOpenFileName(OFN)
Else
OFN.Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or
OFN_PATHMUSTEXIST
x = GetSaveFileName(OFN)
End If
If x <> 0 Then
If InStr(.lpstrFile, Chr$(0)) > 0 Then
szFileName = Left$(.lpstrFile, InStr(.lpstrFile, Chr$(0)) - 1)
szFileTitle = Left$(.lpstrFileTitle, InStr(.lpstrFileTitle,
Chr$(0)) - 1)
Call getFile_Dir
End If
Else
szFileName = ""
End If
End With
Action = szFileName
End Function
'Pass a bar separated string and returns a Null separated string
Private Function NullSepString(ByVal BarString As String) As String
Dim intInstr As Integer
Const vbBar = "|"
Do
intInstr = InStr(BarString, vbBar)
If intInstr > 0 Then Mid(BarString, intInstr, 1) = vbNullChar
Loop While intInstr > 0
NullSepString = BarString
End Function
Private Sub getFile_Dir()
Dim intInstr As Integer
intInstr = InStr(szFileName, szFileTitle) - 1
szFileDir = Left(szFileName, intInstr)
End Sub
Property Let hWnd(SourceHwnd As Long)
lngHwnd = SourceHwnd
End Property
Property Let ModeOpen(DialogMode As Boolean)
wMode = DialogMode * -1
End Property
Property Let Title(DialogTitle As String)
szDialogTitle = DialogTitle
End Property
Property Let FileName(DefaultFile As String)
szFileName = DefaultFile
End Property
Property Get FileName() As String
FileName = szFileName
End Property
Property Let Filter(FilterList As String)
szFilter = NullSepString(FilterList)
End Property
Property Let StartDir(InitialDir As String)
szDefDir = InitialDir
End Property
Property Let DefaultExtension(DefExt As String)
szDefExt = DefExt
End Property
Property Get FileTitle()
FileTitle = szFileTitle
End Property
Property Get FileDir() As String
FileDir = szFileDir
End Property
Private Sub SetDefs()
If lngHwnd = 0 Then lngHwnd = 0
If szFilter = "" Then szFilter = NullSepString("All Files|*.*")
If szDefDir = "" Then szDefDir = "C:\"
If intFilterIndex = 0 Then intFilterIndex = 1
End Sub