مجموعة اكواد رائعة ومهمة جدا فى التعامل مع الادوات

السلام عليكم,,

اليكم هذه المجموعة من الاكواد التى رأيت انها مهمة جدا فى التعامل مع الادوات :

1 -إغلاق وإتاحة جميع الأدوات داخل إطار

'Form Code

Public Sub EnableFrame(InFrame As Frame, ByVal Flag As Boolean)
    Dim Contrl As Control
'some controls don't have the Container.Name property, so instead of
'stopping the application with an error message, we ignore them.
    On Error Resume Next
'enable or disable the frame that passed as parameter.
    InFrame.Enabled = Flag
'passing over all controls
    For Each Contrl In InFrame.Parent.Controls
'if the control is found in the frame
       If (Contrl.Container.Name = InFrame.Name) Then
'if the control is a frame, and it's not the frame that passed as parameter, i.e.
'other frame that found inside our frame, recursively run this sub with this frame,
'to enable or disable all the controls in it.
          If (TypeOf Contrl Is Frame) And Not (Contrl.Name = InFrame.Name) Then
             EnableFrame Contrl, Flag
          Else
'enable or disable the control
             If Not (TypeOf Contrl Is Menu) Then Contrl.Enabled = Flag
          End If
       End If
    Next
End Sub

Private Sub Command1_Click()
    EnableFrame Frame1, False
End Sub

Private Sub Command2_Click()
    EnableFrame Frame1, True
End Sub

2-الإكمال التلقائي في أداة ComboBox

Private Declare Function SendMessage _
      Lib "user32" Alias "SendMessageA" _
      (ByVal hwnd As Long, ByVal wMsg As Long, _
      ByVal wParam As Long, lParam As Any) As Long
'____________________________________________________

Public Sub ComboBoxSpeedFill(cmboBox As ComboBox)
   Dim rtn As Long, lngPos As Long
   With cmboBox
      lngPos = Len(.Text)
      If lngPos <> 0 Then
         rtn = SendMessage(.hwnd, &H14C, -1&, ByVal .Text)
         .ListIndex = rtn
         .SelStart = lngPos
         .SelLength = Len(.Text) - lngPos
      End If
   End With
End Sub

Private Sub Combo1_KeyUp(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
    Case 32, &H30 To &H6F, Is > &H7F
        ComboBoxSpeedFill Combo1
End Select
End Sub

Private Sub Form_Load()
Combo1.AddItem "الأقصي", 0
Combo1.AddItem "القدس", 1
Combo1.AddItem "فلسطين", 2
Combo1.AddItem "الجهاد", 3
Combo1.AddItem "الاسلام", 4
Combo1.AddItem "الحق", 5
Combo1.AddItem "العدل", 6
End Sub

3-البحث في أداة ComboBox

'
' Declaraions
'
Public Const CB_FINDSTRING = &H14C                  ' Used to search a Combo

Public Declare Function SendMessageAny Lib "user32" _
    Alias "SendMessageA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long

Public Function ComboBoxIndex(ByVal lHwnd As Long, ByVal sSearchText As String) As Long
    ComboBoxIndex = SendMessageAny(lHwnd, CB_FINDSTRING, -1, ByVal sSearchText)
End Function

4-استخدام الأرقام والعلامة العشرية فقط في صندوق النص

'Copy and paste this code in the Module:

Public Sub NUMBERS_ONLY(KeyAscii As Integer, TXT As TextBox)
    Select Case KeyAscii
        'negotive numbers
        'KeyAscii; 45 is "-"
        Case 45
            If Len(TXT.Text) >= 1 Then
                KeyAscii = 0
            End If
        'KeyAscii; 8 is "Backspace", 46 is "." decimal,
        ' 48-57 is "0-9"
        Case 8, 46, 48 To 57
            KeyAscii = KeyAscii
        Case Else
            KeyAscii = 0
    End Select
End Sub

'open form, put TextBox Text1 on the form
'on KeyPress event:

Private Sub Text1_KeyPress(KeyAscii As Integer)
    NUMBERS_ONLY KeyAscii, Text1
End Sub

5- للسماح بإدخال تاريخ فقط في مربع النص

Dim i As Integer
Dim t1 As String
Dim t2 As String
Public Sub AutoDate(TextBoxName As TextBox, ByVal keyasci As Integer)
    If Val(keyasci) = 8 Then
        If TextBoxName.Text = Empty Then
            i = 0
        Else
            i = i - 1
        End If
        Exit Sub
    End If
    i = i + 1
    If i = 3 Then
        t1 = Mid(TextBoxName.Text, 1, 2)
        t2 = Mid(TextBoxName.Text, 3, 1)
        TextBoxName.Text = Trim$(t1) & "/" & t2
        TextBoxName.SelStart = 4
        t2 = Empty
    ElseIf i = 6 Then
        t1 = Mid(TextBoxName.Text, 1, 5)
        t2 = Mid(TextBoxName.Text, 6, 1)
        TextBoxName.Text = Trim$(t1) & "/" & t2
        TextBoxName.SelStart = 7
    End If
    If i = 11 Then Exit Sub
End Sub
Public Function DateValidation(TextBoxName As TextBox) As Boolean
    If IsDate(Trim$(TextBoxName.Text)) = False Then
        MsgBox "Enter valid date in dd/mm/yyyy format.", vbInformation, "System Info.."
        TextBoxName.SetFocus
        DateValidation = False
    ElseIf Not Len(Trim$(TextBoxName.Text)) = 10 Then
        MsgBox "Enter valid date in dd/mm/yyyy format.", vbInformation, "System Info.."
        TextBoxName.SetFocus
        DateValidation = False
    Else
        DateValidation = True
    End If
End Function
Private Sub Text1_KeyPress(KeyAscii As Integer)
    Call AutoDate(Text1, 0)
End Sub
Private Sub Text1_LostFocus()
    Call DateValidation(Text1)
End Sub

6-منع المستخدم من استخدام المسافة او اى مفتاح من الكيبورد في صندوق النص

Private Sub Text1_KeyPress(KeyAscii As Integer) 
If KeyAscii = 32 Then
'حيث 32 هو الاسكى كود للمفتاح المراد منع استخدامه 
KeyAscii = 0 
End If 
End Sub

7-التحقق من قيمة خانة النص

Private Sub Text1_Validate(Cancel As Boolean)
   If Not IsNumeric(Text1.Text) Then
      ' المفتاح المدخل ليس رقم
      Cancel = True
   End If
End Sub

8-التحقق من ملأ في جميع صناديق النص علي النموذج

'WRITE A CODING ON CLICK EVENT OF COMMAND1
Private Sub Command1_Click()
Dim CTL As Control
For Each CTL In Controls
If TypeOf CTL Is TextBox Then
    If Trim(CTL.Text) = "" Then
    MsgBox "EACH AND EVERY TEXTBOX SHOULD HAVE SOME VALUE"
    End If
    Exit Sub
   End If
 Next
End Sub

9- تحويل النصوص إلي أحرف كبيرة في جميع الأدوات علي النموذج

'
' This code allows you to pass your Forms Controls collection in
' and it will set all textboxes to be upper case.
'

'
' WinAPI Declarations
'
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const ES_UPPERCASE& = &H8&

Public Sub ConvertToUpperCase(ctlCollection As Object)
    On Error GoTo vbErrorHandler

    Dim lStyle As Long
    Dim lRet As Long
    Dim cCtl As Control
    
    For Each cCtl In ctlCollection
        If TypeOf cCtl Is TextBox Then
            lStyle = GetWindowLong(cCtl.hwnd, GWL_STYLE)
            lStyle = lStyle Or ES_UPPERCASE
            lRet = SetWindowLong(cCtl.hwnd, GWL_STYLE, lStyle)
        End If
    Next
    

    Exit Sub

vbErrorHandler:
    ShowError Err.Number, Err.Description, Err.Source & "::ConvertToUpperCase"

End Sub

10- تنظيف جميع الأدوات علي نافذة

Sub ClearControls(frmName As Form)
Dim objObject As Object
Dim I As Long

For I = 0 To frmName.Count - 1
    
    Set objObject = frmName.Controls(I)
    
    If TypeOf objObject Is TextBox Then
        objObject.Text = ""
    ElseIf TypeOf objObject Is CheckBox Then
        objObject.Value = False
    End If
    
Next I

11- تنظيف جميع صناديق النص علي النافذة

Public Sub ClearTextBoxes(frm As Form)
    Dim c As Control
    For Each c In frm
        If TypeOf c Is TextBox Then c.Text = ""
    Next c
End Sub
Private Sub Command1_Click()
Call ClearTextBoxes(Form1)
End Sub

12- يقوم هذا الاجراء بتحويل معظم الأدوات المستخدمة في الفيجوال بيسك من اليسار الى اليمين

Option Explicit 
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long 

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 

Private Const WS_EX_LAYOUTRTL = &H400000 
Private Const GWL_EXSTYLE = (-20) 

Public Sub SetRtoL(Ctl As Control) 
Ctl.Visible = False 
SetWindowLong Ctl.hwnd, GWL_EXSTYLE, GetWindowLong(Ctl.hwnd, GWL_EXSTYLE) Or WS_EX_LAYOUTRTL 
Ctl.Visible = True 
End Sub

13- تغيير ارتفاع صندوق النص بتغير عدد أسطر النص

Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Const EM_GETLINECOUNT = &HBA
    
Private Sub Text1_Change()
    LineCount = SendMessage(Text1.hwnd, EM_GETLINECOUNT, 0, 0)
    Text1.Height = LineCount * 200
End Sub

شكرا جزيلا , وارجو ان تنال هذه الاكواد رضاكم وان يستفيد منها الجميع ,,,