كود البحث

[jamal2080]

السلام عليكم وجد فى احد المواقع كود بحث ارجوا منكم افادة فى هذا الكود 

الكود الاول فى حدث البحث فى النمودج 

Private Sub cmdfindrec_Click()
On Error GoTo Err_cmdfindrec_Click
    
    Set GENERAL.PRVCTRL = Screen.PreviousControl
    
    Screen.PreviousControl.SetFocus
    
    Set GENERAL.GLFRM = Me

   If GENERAL.PRVCTRL.name = "frmsolaf" Then
       '-------------------------------------------------
       Msg = "غير مسموح بالبحث فى سجل "
       Style = vbOKOnly
       Title = " "
       Dim s As Integer
       s = 10 ' عدد الثواني
       mResult = MsgBoxPause(hwnd, Msg, Title, Style, s)
       '-------------------------------------------------
    Resume Exit_cmdfindrec_Click
   End If
   
    DoCmd.OpenForm "frm_find", acNormal, , , , acDialog


Exit_cmdfindrec_Click:
   user_licence
   no_add_mod_del
     Me.cmdsaverec.Enabled = False
     Me.cmd_undo.Enabled = False
     Me.cmd_Undo_sub.Enabled = False
   
    
    Exit Sub

Err_cmdfindrec_Click:
    
    If Err.Number = 2455 Then
    
    GLFRM.Filter = ""
    GLFRM.FilterOn = False
    DoCmd.DoMenuItem acFormBar, acRecordsMenu, 5, , acMenuVer70

    Resume Exit_cmdfindrec_Click
    End If
    
    
    Handle_Errors_ADO "", Err.Number, Err.Description
    Resume Exit_cmdfindrec_Click
    
End Sub

الكود الثانى موجود داخل نمودج البحث .... لان نمودج البحث مثل نمودج البحث افترضى الاكسس

Option Compare Database
Dim Anim As clsFormAnimate
Private Sub cmd_exit_Click()
On Error GoTo Err_EXIT_Click

    DoCmd.Close

Exit_EXIT_Click:
    Exit Sub

Err_EXIT_Click:
   Handle_Errors_ADO "", Err.Number, Err.Description
    
    Resume Exit_EXIT_Click
End Sub


Private Sub cmd_search_Click()
Dim str As String
Dim str_2 As String
Dim mth As Integer
Dim X
 
  If GENERAL.PRVCTRL.ControlType <> acComboBox Then
   
    
             If Me.FLDSRH <> "" Then
     
                                Select Case Me.srhtyp.Value
        
                                  Case "1"
                                            str = Me.FLDSRH & " = " & """" & Me.str & """"
                                            str_2 = Me.FLDSRH & " = " & Me.str
               
                                  Case "2"
                                            str = Me.FLDSRH & " LIKE " & """" & Me.str & "*"""
                                  Case "3"
                                            str = Me.FLDSRH & " LIKE " & """*" & Me.str & "*"""
                                  Case "4"
                                            str = Me.FLDSRH & " LIKE " & """*" & Me.str & """"
                                End Select
    
                 Else
                           str = "1=1"
             End If
    
    
  Else
    
                 X = GENERAL.PRVCTRL.RowSource

                 X = GENERAL.PRVCTRL.Column(1)

                If Me.FLDSRH <> "" Then
     
                           Select Case Me.srhtyp.Value
        
                                  Case "1"
                                         str = Me.FLDSRH & " = " & """" & Me.str & """"
                                         str_2 = Me.FLDSRH & " = " & Me.str
                                  Case "2"
                                         str = Me.FLDSRH & " LIKE " & """" & Me.str & "*"""
                                  Case "3"
                                         str = Me.FLDSRH & " LIKE " & """*" & Me.str & "*"""
                                  Case "4"
                                         str = Me.FLDSRH & " LIKE " & """*" & Me.str & """"
                           End Select
    
                  Else
                         str = "1=1"
                 End If


   End If

If IsNull(Me.srhtyp.Value) Then
  mth = 0
Else
  mth = Me.srhtyp.Value
End If
DO_FIND str, str_2, mth
Rem DoCmd.Close acForm, "frm_find", acSaveYes
End Sub
Private Sub Form_Load()
Dim a As Integer
 a = Int((28 * Rnd) + 1)
 
Select Case a
       Case 1
       Me.Detail.BackColor = 14403521
      
      Case 2
       Me.Detail.BackColor = 16421253
      Case 3
       Me.Detail.BackColor = 16492959
      Case 4
       Me.Detail.BackColor = 16561323
      Case 5
       Me.Detail.BackColor = 16630973
      Case 6
       Me.Detail.BackColor = 16700367
      Case 7
       Me.Detail.BackColor = 16704224
      Case 8
       Me.Detail.BackColor = 16774130
      Case 9
       Me.Detail.BackColor = 10681796
      Case 10
       Me.Detail.BackColor = 15728569
      Case 11
       Me.Detail.BackColor = 15597488
      Case 12
       Me.Detail.BackColor = 14745463
      Case 13
       Me.Detail.BackColor = 12451474
      Case 14
       Me.Detail.BackColor = 10223575
      Case 15
       Me.Detail.BackColor = 16772014
      Case 16
       Me.Detail.BackColor = 16699135
      Case 17
       Me.Detail.BackColor = 9105153
      Case 18
       Me.Detail.BackColor = 14672127
      Case 19
       Me.Detail.BackColor = 11061759
      Case 20
       Me.Detail.BackColor = 10414590
      Case 21
       Me.Detail.BackColor = 7994838
      Case 22
       Me.Detail.BackColor = 8781491
      Case 23
       Me.Detail.BackColor = 14089782
      Case 24
       Me.Detail.BackColor = 16705136
      Case 25
       Me.Detail.BackColor = 16500091
      Case 26
       Me.Detail.BackColor = 16686226
      Case 27
       Me.Detail.BackColor = 14655727
      Case 28
       Me.Detail.BackColor = 10390517
  
  End Select
   
    FLDSRH = GENERAL.PRVCTRL.name
End Sub
Private Sub Form_Open(Cancel As Integer)
Set Anim = New clsFormAnimate
   Set Anim.AnimationForm = Me
   Anim.FormHeight = 2500
   Anim.FormWidth = 4900
   Anim.FormTop = 1000
   Anim.FormLeft = 100
   ' Comment out line below if you
   ' want Animation when closing the Form.
   Anim.NoCloseAnimation = True
   ' Uncomment if you do NOT want
   ' Animation when the Form opens
   'Anim.NoOpenAnimation = True
 
End Sub

وشكرا لكم

[kkhalifa1960]

أستاذ @jamal2080 أحب مشاركاتك لأن بها الجديد ... فقط بعد اذنك طبق الكود وأرسل المرفق كي يستفيد الجميع . في انتظارك ..

تم تعديل مايو 5, 2023 بواسطه kkhalifa1960

[jamal2080]

الكود مربوط بوحدات نمطية الكود لم انتهى من اكمله بعد 

[kkhalifa1960]

نحن بإنتظارك .