Search Directory for file(s) mask VB Code
Tarih
14/05/2012 12:46
Konu Sahibi
accessman
Yorumlar
0
Okunma
1036
Konuyu Oyla:
  • Derecelendirme: 0/5 - 0 oy
  • 5
  • 4
  • 3
  • 2
  • 1

Derecelendirme: 0/5 - 0 oy



accessman

Kullanici Avatari
Onursal
2.367
31/10/2008
425
Denizli
Ofis 2003
20/09/2016,00:20

Kod:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
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

birsi bunu örnek haline getirebilir mi

@benbendedeilem
Cevapla







Konuyu Okuyanlar: 1 Ziyaretçi


Konu ile Alakalı Benzer Konular
Konular Yazar Yorumlar Okunma Tarih Son Yorum
  Arama süzme örneği Dynamic Search Form accessman 0 1.884 02/03/2010, 15:42 accessman


Türkçe Çeviri: MCTR, Forum Yazılımı: MyBB, © 2002-2016 MyBB Group.
DMCA.com Protection Status
© Desing by XSTYLED| Develops by ozanakkaya