كود توقف عن العمل بعد استخدام نسخة 64 بت

[عبد الله قدور]

السلام عليكم

اخواني الكرام

عندي هذا الكود استخدمه لاستعراض مربع الألوان لاختار منه لون ويتم حفظ اللون في الجدول لكن بعد تعديل نسخة الاوفيس الى 64 بت لم يعد يظهر مربع اختيار اللون ويصبح اللون اسود مباشرة

فهل هناك من حل لهذه المشكلة

Public Function aDialogColor(ByVal hwnd As Long) As Long
  Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long

  CS.lStructSize = Len(CS)
  If hwnd <> 0 Then
  CS.hwnd = hwnd
  Else
  CS.hwnd = Application.hWndAccessApp
  End If
  CS.Flags = CC_SOLIDCOLOR
  CS.lpCustColors = String$(16 * 4, 1)
  x = ChooseColor(CS)
  If x = 0 Then
    ' ERROR - use Default White
    'prop = RGB(255, 255, 255) ' White
    aDialogColor = "112112125" 'False
    Exit Function
  Else
    ' Normal processing
     aDialogColor = CS.rgbResult
  End If
  
End Function

 

[ابو ياسين المشولي]

جرب هذا

#If VBA7 Then

Public Function aDialogColor(ByVal hwnd As Long) As Long
  Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long
#ElseIf Win64 Then
Public Function aDialogColor(ByVal hwnd As Long) As LongPtr
  Dim x As Long, CS As COLORSTRUC, CustColor(16) As LongPtr

  CS.lStructSize = Len(CS)
  If hwnd <> 0 Then
  CS.hwnd = hwnd
  Else
  CS.hwnd = Application.hWndAccessApp
  End If
  CS.flags = CC_SOLIDCOLOR
  CS.lpCustColors = String$(16 * 4, 1)
  x = ChooseColor(CS)
  If x = 0 Then
    ' ERROR - use Default White
    'prop = RGB(255, 255, 255) ' White
    aDialogColor = "112112125" 'False
    Exit Function
  Else
    ' Normal processing
     aDialogColor = CS.rgbResult
  End If
  #End If

End Function

 

[عبد الله قدور]

السلام عليكم

لم يفلح الامر اخي الكريم

[ابوخليل]

مساعد ة : هنا موضوع يتحدث عن هذه المشكلة واتوقع انك اطلعت عليه

[عبد الله قدور]

السلام عليكم

اخي العزيز @ابو خليل تشرفت بمرورك على مشاركتي

طبعا اكيد اطلعت على الرابط لكن المشكلة ليست ان ملف الاكسس لا يعمل بل نافذة اختيار الالوان لا تظهر  التي في الصورة

كانت في 32 تظهر لاختيار اللون ولكن لما نقلت الى 64 وحليت مشكلة التي اشرت لها في الرابط اصبحت هذه النافذة لا تظهر

[ابوخليل]

الافادة التامة  تجدها لمن يملك في حاسوبه اصدار النظام نفسه من اجل اجراء التجربة

لدي اقدم  نظام من اكسس

ولكني قد ادلك على حل ؛ انظر هنا

 

[عبد الله قدور]

السلام عليكم ورحمة الله وبركاته

 

اخواني الكرام الى الان لم يعمل هذا الكود بعد

 

[kaser906]

6 ساعات مضت, عبد الله قدور said:

اخواني الكرام الى الان لم يعمل هذا الكود بعد

افتح وحدة نمطية جديدة واللصق بها هذا الكود 

Option Explicit

Private Declare PtrSafe Sub ChooseColor Lib "msaccess.exe" Alias _
   "#53" (ByVal Hwnd As Long, rgb As Long)
 
Function DialogColor(rgb As Long) As Long
  Call ChooseColor(Application.hWndAccessApp, rgb)
  DialogColor = rgb
End Function

وقم باستدعائه عند النقر او اي حدث يناسبك بهذا الكود

  On Error Resume Next
  
  Me.txtForeColor = Application.Run("DialogColor", ActiveControl)

::بالتوفيق::

[Lamyaa]

استخدم هذا الكود وسيعمل معك على الإصدارتين

#If VBA7 Then
Private Type ChooseColor
    lStructSize               As Long
    hwndOwner                 As LongPtr
    hInstance                 As LongPtr
    rgbResult                 As Long
    lpCustColors              As LongPtr
    flags                     As Long
    lCustData                 As LongPtr
    lpfnHook                  As LongPtr
    lpTemplateName            As String
End Type
#Else
Private Type ChooseColor
    lStructSize               As Long
    hwndOwner                 As Long
    hInstance                 As Long
    rgbResult                 As Long
    lpCustColors              As Long
    flags                     As Long
    lCustData                 As Long
    lpfnHook                  As Long
    lpTemplateName            As String
End Type
#End If
 
Private Const CC_ANYCOLOR = &H100
'Private Const CC_ENABLEHOOK = &H10
'Private Const CC_ENABLETEMPLATE = &H20
'Private Const CC_ENABLETEMPLATEHANDLE = &H40
Private Const CC_FULLOPEN = &H2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_RGBINIT = &H1
'Private Const CC_SHOWHELP = &H8
'Private Const CC_SOLIDCOLOR = &H80
 
#If VBA7 Then
    Private Declare PtrSafe Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long
#Else
    Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long
#End If
 
Public Function DialogColor(Optional lDefaultColor As Variant) As Long
    Dim CC                    As ChooseColor
    Dim lRetVal               As Long
    Static CustomColors(16)   As Long
 
    'Some predefined color, there are 16 slots available for predefined colors
    'You don't have to defined any, if you don't want to!
    CustomColors(0) = RGB(255, 255, 255)    'White
    CustomColors(1) = RGB(0, 0, 0)       'Black
    CustomColors(2) = RGB(255, 0, 0)     'Red
    CustomColors(3) = RGB(0, 255, 0)     'Green
    CustomColors(4) = RGB(0, 0, 255)     'Blue
 
    With CC
        .lStructSize = LenB(CC)
        .hwndOwner = Application.hWndAccessApp
        .flags = CC_ANYCOLOR Or CC_FULLOPEN Or CC_PREVENTFULLOPEN Or CC_RGBINIT
        If IsNull(lDefaultColor) = False _
           And IsMissing(lDefaultColor) = False Then .rgbResult = lDefaultColor    'Set the initial color of the dialog
        .lpCustColors = VarPtr(CustomColors(0))
    End With
    lRetVal = ChooseColor(CC)
    If lRetVal = 0 Then
        'Cancelled by the user
        DialogColor = RGB(255, 255, 255)    ' White -> 16777215
    Else
        DialogColor = CC.rgbResult
    End If
End Function

 

[Lamyaa]

وللتعامل مع الكود استخدم:

    Me.Text0 = DialogColor(Me.Text0)    'لوضع كود اللون في مربع النص
    Me.Text0.BackColor = Me.Text0	' لجعل خلفية مربع النص باللون الذي تم تحديده

 

[SEMO.Pa3x]

تم حل الموضوع للأخ عبدالله قدور.

الكود لمن يريده:

Option Compare Database

Private Type CHOOSECOLOR
    lStructSize As LongPtr
    hwndOwner As LongPtr
    hInstance As LongPtr
    rgbResult As LongPtr
    lpCustColors As String
    flags As LongPtr
    lCustData As LongPtr
    lpfnHook As LongPtr
    lpTemplateName As String
End Type

Private Declare PtrSafe Function ChooseColorAPI Lib "comdlg32.dll" Alias _
    "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As LongPtr

 Dim CustomColors() As Byte

Private Sub cmdS_Click()

    Dim cc As CHOOSECOLOR
    Dim Custcolor(16) As LongPtr
    Dim lReturn As LongPtr

    cc.lStructSize = LenB(cc)
    cc.hwndOwner = Application.hWndAccessApp
    cc.hInstance = 0
    cc.lpCustColors = StrConv(CustomColors, vbUnicode)
    cc.flags = 0
    lReturn = ChooseColorAPI(cc)

    If lReturn <> 0 Then
    
       CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
       MsgBox cc.rgbResult
       
    Else
       MsgBox "User chose the Cancel Button"

    End If
    
End Sub

Private Sub Form_Load()

    ReDim CustomColors(0 To 16 * 4 - 1) As Byte
    Dim i As Integer

    For i = LBound(CustomColors) To UBound(CustomColors)
       CustomColors(i) = 0
    Next i
    
End Sub