البحث في الموقع

السلام عليكم ورحمة الله وبركاته ،، في طور تحسين الأداة الجديدة ( لم يعلن عنها بعد ) ، للتعامل مع الأكواد التي تعمل على 32 ولا تعمل على 64 ، ما زال العمل جاري على تحسين أداء الأداة ، بحيث من خلال النقاش المفتوح نأتي للوصول الى أفضل أداء ونتيجة . مرفق صورة توضيحية للوضع الحالي للأداة ، مع طرح مثال لكود قبل وبعد التحويل الناتج من الأداة . الكود الذي تمت التجربة عليه كمثال ( لا الحصر ) :- Option Compare Database Option Explicit Public 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 Const WM_SETREDRAW = &HB Public Sub FillChildren(twTree As MSComctllib.TreeView, rst As dao.Recordset, _ ByVal nChild As MSComctllib.nodX, _ strParentField As String, strIDField As String, _ strTextField As String, Optional strTextField2 As Variant, Optional strTextField3 As Variant, Optional strTextField4 As Variant, Optional strTextField5 As Variant, _ Optional strKeyPrefix As String, _ Optional varImage As Variant, _ Optional varImageRst As Variant, _ Optional fBold As Boolean) On Local Error GoTo FillChildren_Err Dim strCriteria As String, IMAGE As Variant, strPrefix As String, strText As String, newnodx As MSComctllib.nodX If strKeyPrefix = "" Then strPrefix = "a" Else strPrefix = strKeyPrefix End If If Mid(nChild.key, 2) = "0" Then strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2) & " or is null") Else strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2)) End If rst.FindFirst strCriteria Do Until rst.NoMatch strText = Nz(rst(strTextField), " ") If Not IsMissing(strTextField2) Then strText = strText & (" " + rst(strTextField2)) If Not IsMissing(strTextField3) Then strText = strText & (" " + rst(strTextField3)) If Not IsMissing(strTextField4) Then strText = strText & (" " + rst(strTextField4)) If Not IsMissing(strTextField5) Then strText = strText & (" " + rst(strTextField5)) If Not IsMissing(varImageRst) Then IMAGE = rst(varImageRst) End If If (Not IsMissing(varImage)) And (Len(Nz(IMAGE)) = 0) Then IMAGE = varImage End If IMAGE = Nz(IMAGE, "Default") Set newnodx = twTree.Nodes.Add(nChild, tvwChild, strPrefix & rst(strIDField), strText, IMAGE) rst.FindNext strCriteria Loop FillChildren_End: On Error Resume Next Exit Sub FillChildren_Err: Select Case Err.Number Case 35601, 35603 'Image not found!!! IMAGE = "FlagDefault" Resume Case 35602 'key not unique!!! Set newnodx = twTree.Nodes(strPrefix & rst(strIDField)) Resume Next Case Else MsgBox "Error in FillChildren!!! " & Err.Number & Err.Description Stop Resume End Select End Sub النتيجة من الأداة بعد التحسينات والتعديلات :- 'Code converted to 64-bit compatibility By Foksh ( Officena.Net ) 'Generated on: 2025-05-23 15:22:26 'Tool version: Ver : 1.0 Option Compare Database Option Explicit #If VBA7 Then Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As Long, lParam As Any) As Long #Else Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long #End If Public Const WM_SETREDRAW = &HB Public Sub FillChildren(twTree As MSComctllib.TreeView, rst As dao.Recordset, _ ByVal nChild As MSComctllib.nodX, _ strParentField As String, strIDField As String, _ strTextField As String, Optional strTextField2 As Variant, Optional strTextField3 As Variant, Optional strTextField4 As Variant, Optional strTextField5 As Variant, _ Optional strKeyPrefix As String, _ Optional varImage As Variant, _ Optional varImageRst As Variant, _ Optional fBold As Boolean) On Local Error GoTo FillChildren_Err Dim strCriteria As String, IMAGE As Variant, strPrefix As String, strText As String, newnodx As MSComctllib.nodX If strKeyPrefix = "" Then strPrefix = "a" Else strPrefix = strKeyPrefix End If If Mid(nChild.key, 2) = "0" Then strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2) & " or is null") Else strCriteria = BuildCriteria(strParentField, rst.Fields(strParentField).Type, "=" & Mid(nChild.key, 2)) End If rst.FindFirst strCriteria Do Until rst.NoMatch strText = Nz(rst(strTextField), " ") If Not IsMissing(strTextField2) Then strText = strText & (" " + rst(strTextField2)) If Not IsMissing(strTextField3) Then strText = strText & (" " + rst(strTextField3)) If Not IsMissing(strTextField4) Then strText = strText & (" " + rst(strTextField4)) If Not IsMissing(strTextField5) Then strText = strText & (" " + rst(strTextField5)) If Not IsMissing(varImageRst) Then IMAGE = rst(varImageRst) End If If (Not IsMissing(varImage)) And (Len(Nz(IMAGE)) = 0) Then IMAGE = varImage End If IMAGE = Nz(IMAGE, "Default") Set newnodx = twTree.Nodes.Add(nChild, tvwChild, strPrefix & rst(strIDField), strText, IMAGE) rst.FindNext strCriteria Loop FillChildren_End: On Error Resume Next Exit Sub FillChildren_Err: Select Case Err.Number Case 35601, 35603 'Image not found!!! IMAGE = "FlagDefault" Resume Case 35602 'key not unique!!! Set newnodx = twTree.Nodes(strPrefix & rst(strIDField)) Resume Next Case Else MsgBox "Error in FillChildren!!! " & Err.Number & Err.Description Stop Resume End Select End Sub باب النقاش مفتوح لأي تعليقات وتوضيحات وتحديثات للجميع .. الأداة حصرية وليس لها أي أساس في أي موقع أجنبي أو عربي ( فقط في أوفيسنا ) *ملاحظة :- الدعوة للنقاش لا تقتصر على من لديه خبرة في آكسيس فقط . أيضاً أخوتنا الأساتذة برتبة ( خبير ) الذين أشعر أنهم غير معنيين بالمشاركة بمواضيع أخوتهم الأساتذة في هذا المنتدى هم معنيين خصوصاً بالمشاركة وإبداء الرأي ، وأرجو ان لا تكون هذه العبارة في غير محلها 😎 . نحن نتكاتف هنا لنتشارك معرفتنا وعلمنا الذي علمنا إياه الله - ولا علم إلا علمه . لذا متأملاً منهم خصوصاً مشاركتنا أفكارهم .