- كود الإكمال التلقائي منقول + تحويل لوحة المفاتيح للغة العربية
كود :
Option Explicit
Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
Private Sub Form_Load()
Call language(True) ' تحويل لوحة المفاتيح للغة العربية
On Error Resume Next
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=db1.mdb;Persist Security Info=False"
Adodc1.RecordSource = "Select Distinct * From allayl"
Adodc1.Refresh
Combo1.Clear
Do While Not Adodc1.Recordset.EOF
Combo1.AddItem Adodc1.Recordset.Fields("name").Value
Adodc1.Recordset.MoveNext
Loop
Me.Left = (Screen.Width / 2) - (Me.Width / 2)
Me.Top = (Screen.Height / 2) - (Me.Height / 2)
End Sub
' الربط مع دالة الإكمال التلقائي
Private Sub Combo1_KeyUp(KeyCode As Integer, Shift As Integer)
AutoSel Combo1, KeyCode
End Sub
' دالة الإكمال التلقائي
Function AutoSel(cmb As ComboBox, KeyCode As Integer)
On Error Resume Next
Select Case KeyCode
' 8 = Backspace, 37=LeftArraw, 38=UpArraw, 39=RightArraw, 40=DownArraw
' 46 = Delete, 33=PageUp, 34=PageDown, 35=End, 36=Home
Case vbEnter, 8, 37, 38, 39, 40, 46, 33, 34, 35, 36
Exit Function
End Select
Dim Text As String
Text = cmb.Text
Dim i As Long
Dim Temp As String
For i = 0 To cmb.ListCount
Temp = Left(cmb.List(i), Len(Text))
If LCase(Temp) = LCase(Text) Then
cmb.Text = cmb.List(i)
cmb.ListIndex = i
cmb.SelStart = Len(Text)
cmb.SelLength = Len(cmb.List(i))
End If
Next
End Function
Public Sub language(arabic As Boolean)
If arabic Then
Call LoadKeyboardLayout("00000401", 1)
Else
Call LoadKeyboardLayout("00000409", 1)
End If
End Sub
'VB ComboBox doesn't have SelectString(), so SendMessage to the Window Handle
'#define CB_SELECTSTRING 0x014D
'#define CB_SHOWDROPDOWN 0x014F
'#define CBN_SELENDOK 9
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
Private Const CB_ERR = -1, CB_SELECTSTRING = &H14D, CB_SHOWDROPDOWN = &H14F, CBN_SELENDOK = 9
'call this function in KeyPress event method
Public Function AutoMatchCBBox(ByRef cbBox As ComboBox, ByVal KeyAscii As Integer) As Integer
Dim strFindThis As String, bContinueSearch As Boolean
Dim lResult As Long, lStart As Long, lLength As Long
AutoMatchCBBox = 0 ' block cbBox since we handle everything
bContinueSearch = True
lStart = cbBox.SelStart
lLength = cbBox.SelLength
On Error GoTo ErrHandle
If KeyAscii < 32 Then 'control char
bContinueSearch = False
cbBox.SelLength = 0 'select nothing since we will delete/enter
If KeyAscii = Asc(vbBack) Then 'take care BackSpace and Delete first
If lLength = 0 Then 'delete last char
If Len(cbBox) > 0 Then ' in case user delete empty cbBox
cbBox.Text = Left(cbBox.Text, Len(cbBox) - 1)
End If
Else 'leave unselected char(s) and delete rest of text
cbBox.Text = Left(cbBox.Text, lStart)
End If
cbBox.SelStart = Len(cbBox) 'set insertion position @ the end of string
ElseIf KeyAscii = vbKeyReturn Then 'user select this string
cbBox.SelStart = Len(cbBox)
lResult = SendMessage(cbBox.HWnd, CBN_SELENDOK, 0, 0)
AutoMatchCBBox = KeyAscii 'let caller a chance to handle "Enter"
End If
Else 'generate searching string
If lLength = 0 Then
strFindThis = cbBox.Text & Chr(KeyAscii) 'No selection, append it
Else
strFindThis = Left(cbBox.Text, lStart) & Chr(KeyAscii)
End If
End If
If bContinueSearch Then 'need to search
Call VBComBoBoxDroppedDown(cbBox) 'open dropdown list
lResult = SendMessage(cbBox.HWnd, CB_SELECTSTRING, -1, ByVal strFindThis)
If lResult = CB_ERR Then 'not found
cbBox.Text = strFindThis 'set cbBox as whatever it is
cbBox.SelLength = 0 'no selected char(s) since not found
cbBox.SelStart = Len(cbBox) 'set insertion position @ the end of string
Else
'found string, highlight rest of string for user
cbBox.SelStart = Len(strFindThis)
cbBox.SelLength = Len(cbBox) - cbBox.SelStart
End If
End If
On Error GoTo 0
Exit Function
ErrHandle:
'got problem, simply return whatever pass in
Debug.Print "Failed: AutoCompleteComboBox due to : " & Err.Description
Debug.Assert False
AutoMatchCBBox = KeyAscii
On Error GoTo 0
End Function
'open dorpdown list
Private Sub VBComBoBoxDroppedDown(ByRef cbBox As ComboBox)
Call SendMessage(cbBox.HWnd, CB_SHOWDROPDOWN, Abs(True), 0)
End Sub
وثاني حاجة وضع الكود في الفورم الذي يوجد به الكمبو بوكس وسميه باسم comboitem:
كود :
Private Sub ComboItem_Click()
On Error Resume Next
'''''''''''''''' äÓÊÏÚí åÐÇ ÇáßæÏ ãä ÇÏáÉ ÇáãæÏíá ÍÊí íÊã ÇáÈÍË ÈÓÑÚÉ ÏÇÎá ÇáßãÈæ ÈæßÓ
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
KeyAscii = AutoMatchCBBox(ComboItem, KeyAscii)
Adodc2.RecordSource = "select * from emp_data where m_name like '" & Trim(ComboItem.Text) & "%'"
Adodc2.Refresh
If Adodc2.Recordset.BOF Or Adodc2.Recordset.EOF Then
CmdDel.Enabled = False
Else
CmdDel.Enabled = True
End If
End Sub
Private Sub ComboItem_DropDown()
On Error Resume Next ' ÑÈØ ãÚ ÌÏæá ÈíÇäÇÊ ÇáãæÙÝíä
ComboItem.Clear
Adodc1.Recordset.MoveFirst
Adodc1.Refresh
Do While Not Adodc1.Recordset.EOF
If Trim(("itemname")) <> "" Then
ComboItem.AddItem Adodc1.Recordset.Fields(1)
End If
Adodc1.Recordset.MoveNext
Loop
End Sub
Private Sub ComboItem_KeyPress(KeyAscii As Integer)
On Error Resume Next
'''''''''''''''' äÓÊÏÚí åÐÇ ÇáßæÏ ãä ÇÏáÉ ÇáãæÏíá ÍÊí íÊã ÇáÈÍË ÈÓÑÚÉ ÏÇÎá ÇáßãÈæ ÈæßÓ
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
KeyAscii = AutoMatchCBBox(ComboItem, KeyAscii)
Adodc2.RecordSource = "select * from emp_data where m_name like '" & Trim(ComboItem.Text) & "%'"
Adodc2.Refresh
If Adodc2.Recordset.BOF Or Adodc2.Recordset.EOF Then
CmdDel.Enabled = False
Else
CmdDel.Enabled = True
End If