اوامر البحث

استعرض الموضوع السابق استعرض الموضوع التالي اذهب الى الأسفل

default اوامر البحث

مُساهمة من طرف Admin في الأحد يونيو 24, 2007 10:28 am

هذا الكود للبحث عن ملفات داخل الجهاز
Add 1 Command Button, 4 Text Boxes and 1 List Box to your Form.
'At Run-Time, Enter the path that you want to start to search from it to Text1,
'Enter the file pattern to Text2 (like *.* or *.exe), and press the button.
'List1 will be filled with all the matching files, Text3 will display the number of files found,
'And Text4 will display the total size of the found files.
'Insert the following code to your form:

Private Function FindFiles(path As String, SearchStr As String, _
FileCount As Integer, DirCount As Integer)
Dim FileName As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
On Error GoTo sysFileERR
If Right(path, 1) <> "\" Then path = path & "\"
nDir = 0
ReDim dirNames(nDir)
DirName = Dir(path, vbDirectory Or vbHidden)
Do While Len(DirName) > 0
If (DirName <> ".") And (DirName <> "..") Then
If GetAttr(path & DirName) And vbDirectory Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
sysFileERRCont:
End If
DirName = Dir()
Loop
FileName = Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem _
Or vbReadOnly)
While Len(FileName) <> 0
FindFiles = FindFiles + FileLen(path & FileName)
FileCount = FileCount + 1
List1.AddItem path & FileName
FileName = Dir()
Wend
If nDir > 0 Then
For i = 0 To nDir - 1
FindFiles = FindFiles + FindFiles(path & dirNames(i) & "\", _
SearchStr, FileCount, DirCount)
Next i
End If
AbortFunction:
Exit Function
sysFileERR:
If Right(DirName, 4) = ".sys" Then
Resume sysFileERRCont
Else
MsgBox "Error: " & Err.Number & " - " & Err.Description, , _
"Unexpected Error"
Resume AbortFunction
End If
End Function

Private Sub Command1_Click()
Dim SearchPath As String, FindStr As String
Dim FileSize As Long
Dim NumFiles As Integer, NumDirs As Integer
Screen.MousePointer = vbHourglass
List1.Clear
SearchPath = Text1.Text
FindStr = Text2.Text
FileSize = FindFiles(SearchPath, FindStr, NumFiles, NumDirs)
Text3.Text = NumFiles & " Files found in " & NumDirs + 1 & _
" Directories"
Text4.Text = "Size of files found under " & SearchPath & " = " & _
Format(FileSize, "#,###,###,##0") & " Bytes"
Screen.MousePointer = vbDefault
End Sub

================================
وهذا الكود للبحث السريع في لست بوكس

Const LB_FINDSTRING = &H18F
Private Declare Function SendMessage Lib "User32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Integer, _
ByVal wParam As Integer, _
lParam As Any) As Long

'Just found it in MS KB, a small modification added.
Private Sub Text1_Change()
List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, _
ByVal Text1.Text)
End Sub
'
'If you like that the found item list stays next to top of the ListBox control,
'you can try this:
Private Sub Text1_Change()
'
On Error Resume Next
'
List1.ListIndex = SendMessage(List1.hwnd, LB_FINDSTRING, -1, _
ByVal Text1.Text)
'
List1.TopIndex = List1.ListIndex - 1
'
End Sub

==========================

وهذا الكود للبحث السريع في كومبو بكس
'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Combo Box to your form. Set the Combo Box Style property to 2 - DropDown List.
'Add few items to the Combo Box list, some of them should begin with the same character.
'When you will press a key, the first item that begins with the key you pressed will be selected.
'If you will press the same key again, the second item that begins with the key you pressed
'will be selected.

Dim strCombo As String
Const WM_SETREDRAW = &HB
Const KEY_A = 65
Const KEY_Z = 90
Private Declare Function SendMessage Lib "User32" (ByVal hWnd As Integer, ByVal wMsg As _
Integer, ByVal wParam As Integer, lParam As Any) As Long

Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
Dim x%
Dim strTemp$
Dim nRet&
If KeyCode >= KEY_A And KeyCode <= KEY_Z Then
'only look at letters A-Z
strTemp = Combo1.Text
If Len(strTemp) = 1 Then strCombo = strTemp
nRet& = SendMessage(Combo1.hWnd, WM_SETREDRAW, False, 0&)
For x = 0 To (Combo1.ListCount - 1)
If UCase((strTemp & Mid$(Combo1.List(x), Len(strTemp) + 1))) = UCase(Combo1.List(x)) Then
Combo1.ListIndex = x
Combo1.Text = Combo1.List(x)
Combo1.SelStart = Len(strTemp)
Combo1.SelLength = Len(Combo1.Text) - (Len(strTemp))
strCombo = strCombo & Mid$(strTemp, Len(strCombo) + 1)
Exit For
Else
If InStr(UCase(strTemp), UCase(strCombo)) Then
strCombo = strCombo & Mid$(strTemp, Len(strCombo) + 1)
Combo1.Text = strCombo
Combo1.SelStart = Len(Combo1.Text)
Else
strCombo = strTemp
End If
End If
Next
nRet& = SendMessage(Combo1.hWnd, WM_SETREDRAW, True, 0&)
End If
End Sub

=============================
وهذا الكود للبحث داخل نص

Dim X As Integer
X = FindMatch(Text1.Text, Text2.Text)
If X = 0 Then
MsgBox "Word not found"
Else
MsgBox "Word found"
End If
End Sub

1. Create a new function called FindMatch. Add the following code to
this function:

Function FindMatch(Str1 As String, Str2 As String) As Integer
Dim Match As Integer
Dim Char1 As String
Dim Char2 As String

Match = InStr(Str1, Str2)

If Match <> 0 Then
Char1 = Mid$(Str1, Match - 1, 1)
If Codes(Char1) Then
Char2 = Mid$(Str1, Match + Len(Str2), 1)
If Codes(Char2) Then
FindMatch = True: Exit Function
End If
End If
End If

FindMatch = False
End Function

2. Create a new function called Codes. Add the following code to this
function:

Function Codes(PuncStr As String) As Integer
If PuncStr = "," Or PuncStr = "." Or PuncStr = " " Or _
PuncStr = Chr(10) Or PuncStr = Chr(13) Or PuncStr = Chr(9) Then
Codes = True
Else
Codes = False
End If
End Function


------------------------------
إذا أعجبك موضوع من مواضيعي فلا تقل شكـراً ...
بل قل الآتـي ::
اللهم اغفر له ولوالديه ولزوجته وابنائه ولأخوانه واخواته ولسائر المسلمين ماتقدم من ذنبهم وما تأخر..
وقِهم عذاب القبر وعذاب النار..
و أدخلهم الفردوس الأعلى مع الأنبياء والشهداء والصالحين ..
واجعل دعاءهم مستجاب في الدنيا والآخرة ..
اللـهم آميـن..اللـهم آميـن..اللـهم آميـن..

اخوكم جاد القرعان
الأردن- الطفيلة
jadquraan@yahoo.com
jad_quraansoft@hotmail.com
00962777765709
avatar
Admin
jadquraan
jadquraan

عدد الرسائل : 125
العمر : 34
تاريخ التسجيل : 19/10/2006

معاينة صفحة البيانات الشخصي للعضو http://jad4vb.lightbb.com

الرجوع الى أعلى الصفحة اذهب الى الأسفل

استعرض الموضوع السابق استعرض الموضوع التالي الرجوع الى أعلى الصفحة


 
صلاحيات هذا المنتدى:
لاتستطيع الرد على المواضيع في هذا المنتدى