كيفية تغيير لون شريط العنوان لليوزرفورم و تغيير شكل و لون و حجم الخط ال Caption

[جعفر الطريبق]

قبل شهور كنت قد كتبت هدا الكود الدي يعطي للمستخدم امكانية التحكم في لون ال UserForm Title Bar و التحكم في حجم و لون و شكل ال Font أي الخط المكتوب به ال  UserForm Caption  كل حرف على حدى

الكود لا يشتغل في اجهزة ال 64Bit Windows

ملف للتحميل : https://app.box.com/s/l96isv4jal2rns144zy5

 

1- كود في Standard Module :

Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
 
Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type
 
Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * 32
End Type

Private Type FontAttributes
    FONT_NAME As String
    FONT_SIZE As Long
    FONT_BOLD As Boolean
    FONT_ITALIC As Boolean
    FONT_UNDERLINE As Boolean
End Type

Private Type TRIVERTEX
    x As Long
    y As Long
    Red As Integer
    Green As Integer
    Blue As Integer
    Alpha As Integer
End Type

Private Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type
 
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
 
Private Declare Function GetWindowDC Lib "user32" _
 (ByVal hwnd As Long) As Long
 
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
 
Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
 
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
 
Private Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" _
() 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 Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
 
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
 
Private Declare Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, _
ByVal crColor As Long) As Long
 
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
 
Private Declare Function FillRect Lib "User32.dll" _
(ByVal hdc As Long, _
ByRef lpRect As RECT, _
ByVal hBrush As Long) As Long
 
Private Declare Function SetRect Lib "user32" _
(lpRect As RECT, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
 
Private Declare Function GetWindowRect Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
 
Private Declare Function BeginPaint Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
 
Private Declare Function EndPaint Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
 
Private Declare Function InvalidateRect Lib "User32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
 
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare Function SetMapMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nMapMode As Long) As Long

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" _
(ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As RECT, ByVal wFormat As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" _
(dst As Any, ByVal iLen As Long)

Private Declare Function GetTextColor Lib "gdi32" ( _
ByVal hdc As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

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

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As _
  Long, ByVal y As Long) As Long
  
Private Declare Function IsBadWritePtr Lib "kernel32" _
(ByVal lp As Long, ByVal ucb As Long) As Long

Private Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" _
(ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, _
pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long

 Private Declare Function PtInRect Lib "user32" _
 (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
 
Private Declare Function ScreenToClient Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpPoint As POINTAPI) As Long

Private Declare Function DrawFrameControl Lib "user32" _
(ByVal hdc As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long

Private Declare Function OffsetRect Lib "user32" _
(lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long

Private Const DFC_CAPTION = 1
Private Const DFCS_CAPTIONCLOSE = &H0
Private Const DT_CALCRECT = &H400
Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const GWL_WNDPROC As Long = -4
Private Const WM_ACTIVATE As Long = &H6
Private Const WM_PAINT As Long = &HF&
Private Const WM_SHOWWINDOW As Long = &H18
Private Const WM_EXITSIZEMOVE As Long = &H232
Private Const WM_DESTROY As Long = &H2
Private Const SM_CYCAPTION As Long = 4
Private Const COLOR_ACTIVECAPTION = 2
Private Const GRADIENT_FILL_RECT_H As Long = &H0
Private Const WM_SYSCOMMAND = &H112
Private Const SM_CXSIZE = 30
Private Const SM_CYSIZE = 31
Private Const WS_SYSMENU = &H80000
Private Const GWL_STYLE As Long = (-16)

Private tFontAttr  As FontAttributes
Private tr2 As RECT
Private tRect As RECT
Private lPrevWnd As Long
Private lhHook As Long
Private bHookEnabled As Boolean
Private oForm As Object
Private bGradientFill As Boolean
Private lCharColorsPtr As Long
Private bCreateFont As Boolean
Private lDefaultFontColor As Long
Private sFontName As String
Private lFontSize As Long
Private bFontBold As Boolean
Private bFontItalic     As Boolean
Public bFontUnderline As Boolean
Private sCaptionText As String
Private lTitleBarColor As Long
Private lFontColour As Long
Private aCharColors() As Variant


Public Sub ShowFormatedUserForm( _
    ByVal Form As Object, _
    Optional ByVal TitleBarColor As Long, _
    Optional ByVal GradientFill As Boolean, _
    Optional ByVal FontAttributesPtr As Long, _
    Optional CharColorsPtr As Long _
)
    Call HookUserForm(ByVal Form, _
        ByVal TitleBarColor, _
        ByVal GradientFill, _
        ByVal FontAttributesPtr, _
        CharColorsPtr _
    )
End Sub


Private Sub HookUserForm _
 (ByVal Form As Object, ByVal TitleBarColour As Long, _
 ByVal GradientFill As Boolean, ByVal FontAttributesPtr As Long, _
  CharColorsPtr As Long)
    If Not bHookEnabled Then
        Set oForm = Form
        sCaptionText = Form.Caption
        Form.Caption = vbNullString
        lCharColorsPtr = CharColorsPtr
        bGradientFill = GradientFill
        lTitleBarColor = IIf(TitleBarColour = 0, _
        GetSysColor(COLOR_ACTIVECAPTION), TitleBarColour)
        lDefaultFontColor = IIf(CharColorsPtr = 0, GetSysColor(9), 0)
        If IsBadWritePtr(FontAttributesPtr, 4) = 0 Then
            If FontAttributesPtr <> 0 Then
                CopyMemory ByVal tFontAttr, ByVal FontAttributesPtr, LenB(tFontAttr)
                With tFontAttr
                    sFontName = .FONT_NAME
                    lFontSize = .FONT_SIZE
                    bFontBold = .FONT_BOLD
                    bFontItalic = .FONT_ITALIC
                    bFontUnderline = .FONT_UNDERLINE
                End With
                bCreateFont = True
            Else
                bCreateFont = False
            End If
        End If
        If IsBadWritePtr(CharColorsPtr, 4) = 0 Then
            If CharColorsPtr <> 0 Then
                ReDim aCharColors(Len(sCaptionText))
                CopyMemory aCharColors(0), ByVal CharColorsPtr, 16 * (UBound(aCharColors) + 1)
                ZeroMemory ByVal CharColorsPtr, 16 * (UBound(aCharColors) + 1)
            Else
                Erase aCharColors()
            End If
        End If
        lhHook = SetWindowsHookEx _
        (WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
        bHookEnabled = True
        Form.Show
    Else
        MsgBox "The hook is already set.", vbInformation
    End If
    
End Sub
 
Private Function HookProc _
(ByVal idHook As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
    Dim sBuffer As String
    Dim lRetVal As Long
    Dim lDc As Long
    
    If idHook = HCBT_ACTIVATE Then
        sBuffer = Space(256)
        lRetVal = GetClassName(wParam, sBuffer, 256)
        If Left(sBuffer, lRetVal) = "ThunderDFrame" Or _
        Left(sBuffer, lRetVal) = "ThunderXFrame" Then
            lDc = GetWindowDC(wParam)
             ReleaseDC wParam, lDc
            lPrevWnd = SetWindowLong _
            (wParam, GWL_WNDPROC, AddressOf CallBackProc)
            UnhookWindowsHookEx lhHook
            bHookEnabled = False
        End If
    End If
    HookProc = CallNextHookEx _
    (lhHook, idHook, ByVal wParam, ByVal lParam)
End Function
 
Private Function CallBackProc _
(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
      Static i As Long
      Dim lDc As Long

    Dim lStyle As Long
    Dim loword As Long
    Dim hiword As Long
    Dim tPt As POINTAPI
    Dim x As Long
    Dim pt As POINTAPI
    Dim tr As RECT
    
    On Error Resume Next
    GetWindowRect hwnd, tRect
    Select Case Msg
        Case WM_PAINT, WM_ACTIVATE
            If Msg = WM_ACTIVATE Then
                lStyle = GetWindowLong(hwnd, GWL_STYLE)
                SetWindowLong hwnd, GWL_STYLE, (lStyle And Not WS_SYSMENU)
            End If
            lDc = GetWindowDC(hwnd)
            Call DrawTitleBar(hwnd, lTitleBarColor)
            SetBkMode lDc, 1
            If bCreateFont Then
                CreateFont lDc
            End If
            For i = 1 To Len(sCaptionText)
                If lCharColorsPtr = 0 Then
                    SetTextColor lDc, lDefaultFontColor
                Else
                    SetTextColor lDc, aCharColors(i - 1)
                End If
                SetRect tr, 0, 0, 0, 0
                DrawText lDc, Mid(sCaptionText, i, 1), _
                Len(Mid(sCaptionText, i, 1)), tr, DT_CALCRECT
                If x = 0 Then x = 4
                TextOut lDc, x, GetSystemMetrics(SM_CYCAPTION) / 3, _
                Mid(sCaptionText, i, 1), Len(Mid(sCaptionText, i, 1))
                x = x + Abs(tr.Right - tr.Left)
            Next
            lFontColour = GetTextColor(lDc)
            ReleaseDC hwnd, lDc
            InvalidateRect hwnd, 0, 0
        Case WM_EXITSIZEMOVE, WM_SHOWWINDOW
            Call DrawTitleBar(hwnd, lTitleBarColor)
            InvalidateRect hwnd, 0, 0
        Case WM_SYSCOMMAND
            GetHiLoword lParam, loword, hiword
            tPt.x = loword
            tPt.y = hiword
            ScreenToClient hwnd, tPt
            If PtInRect(tr2, tPt.x, -tPt.y) Then
                Unload oForm
            End If
        Case WM_DESTROY
            SetWindowLong hwnd, GWL_WNDPROC, lPrevWnd
            bGradientFill = False
            lCharColorsPtr = 0
            bCreateFont = False
            lDefaultFontColor = 0
            sFontName = vbNullString
            lFontSize = 0
            bFontBold = False
            bFontItalic = False
            bFontUnderline = False
            sCaptionText = vbNullString
            lTitleBarColor = 0
            lFontColour = 0
            Erase aCharColors()
            Set oForm = Nothing
    End Select
    CallBackProc = CallWindowProc _
    (lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function
 
Private Sub CreateFont(DC As Long)
    Dim uFont As LOGFONT
    Dim lNewFont As Long
    
    With uFont
        .lfFaceName = sFontName & Chr$(0)
        .lfWidth = lFontSize
        .lfWeight = IIf(bFontBold, 900, 100)
        .lfItalic = bFontItalic
        .lfUnderline = bFontUnderline
    End With
    lNewFont = CreateFontIndirect(uFont)
    DeleteObject (SelectObject(DC, lNewFont))
End Sub

Private Sub ConvertLongToRGB(ByVal Value As Long, r As Byte, g As Byte, b As Byte)
    r = Value Mod 256
    g = Int(Value / 256) Mod 256
    b = Int(Value / 256 / 256) Mod 256
End Sub

Private Function LongToUShort(Unsigned As Long) As Double
    LongToUShort = CInt(Unsigned - &H10000)
End Function

Private Function TransfCol(ByVal Col As Long) As Double
    Dim a As Double
    
    If Col = 0 Then
        TransfCol = 0
    ElseIf Col > 127 Then
        a = 256 - Col
        TransfCol = -(256 * a)
    Else
        a = Col
        TransfCol = 256 * a
    End If
End Function
 
Private Sub DrawTitleBar _
(lhwnd As Long, ByVal MyColor As Long)
    Dim tPS As PAINTSTRUCT
    Dim tLB As LOGBRUSH
    Dim tr As RECT
    Dim lDc As Long
    Dim l As Long
    Dim hBrush As Long
    Dim vert(2) As TRIVERTEX
    Dim tPt As GRADIENT_RECT
    Dim r As Byte, g As Byte, b As Byte
    
    Call BeginPaint(lhwnd, tPS)
        lDc = GetWindowDC(lhwnd)
        tLB.lbColor = MyColor
        hBrush = CreateBrushIndirect(tLB)
        Call GetWindowRect(lhwnd, tr)
        SetRect tr, 0, 0, tr.Right, tr.Bottom
        SetRect tr2, 0, 5, _
        GetSystemMetrics(SM_CXSIZE), GetSystemMetrics(SM_CYSIZE) + tr.Bottom
        OffsetRect tr2, tRect.Right - tRect.Left - GetSystemMetrics(SM_CXSIZE), 0
        FillRect lDc, tr, hBrush
        If bGradientFill Then
            ConvertLongToRGB MyColor, r, g, b
            With vert(0)
                .x = 0
                .y = 0
                .Red = TransfCol(r)
                .Green = TransfCol(g)
                .Blue = TransfCol(b)
                .Alpha = TransfCol(0)
            End With
            With vert(1)
                .x = tr2.Right
                .y = tr2.Bottom
                .Red = TransfCol(0)
                .Green = TransfCol(0)
                .Blue = TransfCol(0)
                .Alpha = TransfCol(0)
            End With
            tPt.UpperLeft = 0
            tPt.LowerRight = 1
            GradientFillRect lDc, vert(0), 2, tPt, 1, GRADIENT_FILL_RECT_H
        End If
        Call DeleteObject(hBrush)
        SetRect tr2, tr2.Right - GetSystemMetrics(SM_CXSIZE), 0, _
        tr2.Right, GetSystemMetrics(SM_CYSIZE)
        OffsetRect tr2, -4, 2
        DrawFrameControl lDc, tr2, DFC_CAPTION, DFCS_CAPTIONCLOSE
        ReleaseDC lhwnd, lDc
    Call EndPaint(lhwnd, tPS)
End Sub

Private Sub GetHiLoword _
(lParam As Long, ByRef loword As Long, ByRef hiword As Long)
    loword = lParam And &HFFFF&
    hiword = lParam \ &H10000 And &HFFFF&
End Sub

 

 

 

2- كود في Standard Module اخر :

Option Explicit

Private Type FontAttributes
    FONT_NAME As String
    FONT_SIZE As Long
    FONT_BOLD As Boolean
    FONT_ITALIC As Boolean
    FONT_UNDERLINE As Boolean
End Type

Sub test()

    Dim tFontAttr As FontAttributes
    Dim aCharColors() As Variant
    Dim lTitleBarColor As Long
    
    'define a random title bar color
    lTitleBarColor = RGB(0, 255, 0)
    
    'build the caption font structure
    With tFontAttr
        .FONT_NAME = "Arial" '"Trebuchet MS"
        .FONT_SIZE = 8
        .FONT_BOLD = True
        .FONT_ITALIC = False
        .FONT_UNDERLINE = False
    End With
    
    'build the caption individual character colors
        ReDim aCharColors(Len(UserForm1.Caption)) '===> (=16 chars in this case)
        aCharColors(0) = vbRed                   'U
        aCharColors(1) = vbRed                   's
        aCharColors(2) = vbRed                   'e
        aCharColors(3) = vbRed                   'r
        aCharColors(4) = vbBlue                  'F
        aCharColors(5) = vbBlue                  'o
        aCharColors(6) = vbBlue                  'r
        aCharColors(7) = vbBlue                  'm
        aCharColors(8) = vbYellow                '1
        aCharColors(9) = 0
        aCharColors(10) = vbRed                   '-
        aCharColors(11) = 0
        aCharColors(10) = vbWhite                'D
        aCharColors(12) = vbWhite                'e
        aCharColors(13) = vbWhite                'm
        aCharColors(14) = vbWhite                '0
        aCharColors(15) = vbWhite                '0
        
    
    'display the userform
    Call ShowFormatedUserForm( _
            Form:=UserForm1, _
            TitleBarColor:=lTitleBarColor, _
            GradientFill:=True, _
            FontAttributesPtr:=VarPtr(tFontAttr), _
            CharColorsPtr:=VarPtr(aCharColors(0)) _
    )

End Sub

 

تم تعديل سبتمبر 19, 2015 بواسطه جعفر الطريبق

[محمد حسن المحمد]

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

مبدع بحق أستاذ جعفر الطريبق المحترم

جزاك الله خيراً..ليتنا نمتلك أجهزة أعلى من 64 لكنا تمتعنا بهذا الإبداع

تقبل تحياتي.

[جعفر الطريبق]

شكرا يا أستاد محمد حسن

الكود يشتغل جيدا على أجهزة 32Bit  .. و لكي يشتغل على 64Bit  يتطلب تعديلا على ال  API declarations

تعديل ال Windows API declarations ليس أمرا صعبا لكنه يتطلب امتلاك جهاز من 64Bit  لتجريب الكود ... للأسف ليس لدي جهاز 64Bit  لكي أعدل و أجرب الكود .. ان شاء الله قريبا سأبدل الجهاز

[عبد العزيز البسكري]

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

بارك الله فيك أستاذنا القدير جعفر الطريبق .. بسم الله ماشاء الله .. فعلا عمل مميّز .. إبداع رائع .. قمت بتجربته .. بارك الله فيك  وزادك من علمه و فضله

                                                                                               خالص احتراماتي

 

[Yasser Fathi Albanna]

ونعم الأعمل والكنوز الرائعة أخى الحبيب أ / جعفر الطريبق

بالفعل عمل أكثر من رائع

جزاك الله خير الجزاء

[saad abed]

اخى جعفر

رووووووووووووووووووووووووووووووووووووووووووووووووعه

[مختار حسين محمود]

 

شكرا يا أستاد محمد حسن

الكود يشتغل جيدا على أجهزة 32Bit  .. و لكي يشتغل على 64Bit  يتطلب تعديلا على ال  API declarations

تعديل ال Windows API declarations ليس أمرا صعبا لكنه يتطلب امتلاك جهاز من 64Bit  لتجريب الكود ... للأسف ليس لدي جهاز 64Bit  لكي أعدل و أجرب الكود .. ان شاء الله قريبا سأبدل الجهاز

بارك الله فيك أستاذنا  جعفر الطريبق  لكن لى ملحوظتان وطلب

الملحوظة الاولى : أنا أعمل على  win 7 32 bit    ومنشط كل المكتبات  والمراجع  ولم يعمل الملف 

                  الفورم لم يظهر  كما فى الصورة   الواردة فى مشاركتك الاولى  ولما ضغطت على Done  حصله وميض اخضر واختفى

الملحوظة الثانية : قد يكون  تعديل ال Windows API declarations ليس أمرا صعبا بالنسبة لك .

                      ولكنه لا يتطلب امتلاك جهاز جديد  بل نسخة ويندوز 64 بت  فقط       ليه التكاليف  !!!!

الطلب : تشرح لنا بالتفصيل فى موضوع مستقل     " تعديل ال Windows API declarations  من 32 الى 64  "                                                    

لأنى تواصلت مع أساتذة أجانب ولم أفهم عنهم جيدا  بسبب فرق مستوى اللغة  فالحمد لله أنك معانا فى المنتدى لتشرح لنا ما نجهله   . 

                                                                                                                                  تقبل تحياتى وتقديرى لشخصكم الكريم

 

[جعفر الطريبق]

ردا على الأستاد مختار حسين محمود

الملحوظة الاولى :  صعب أن أعرف لمادا لم يظهر عندك الفورم كما في الصورة .. الكود جربه العديد من المستخدمين على 32 Bit  و اشتغل تمام .

الملحوظة الثانية : نعم تعديل ال Windows API declarations لا يتطلب جهازا جديدا بل نسخة ويندوز 64 بت  فقط .. و هدا ما كنت أقصده و ان خانني التعبير .. أفكر في اقتناء جهاز جديد و عليه الويندوز 64 بت كي أتمكن من تجريب و تعديل الكثير من الكودات التي تستخدم ال API Functions

الطلب : يصعب علي شرح هدا الموضوع أو غيره من المواضيع التقنية باللغة العربية ... فأنا لم يسبق لي أن اشتغلت باالاكسيل أو بالبرنجة عموما الا بالانجليزية و قاموسي اللغوي العربي ضعيف جدا  ... أقترح عليك الرابط التالي : http://www.jkp-ads.com/articles/apideclarations.asp

نعم الرابط بالانجليزي و لكن الاسلوب المستخدم بسيط و يشرح الموضوع بطريقة سهلة و مفصلة .. أتمنى أن يعجبك

[مختار حسين محمود]

أشكرك أستاذى الكريم  على الرابط 

على فكرة صاحب الموقع هو Mr. Jan Karel Pieterse

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

كان حول لى  Windows API declarations  من 32 الى 64  فى كود

خاص بالموضوع التالى  http://www.officena.net/ib/index.php?showtopic=59963

وأعطانى رابط موقعه ده لكى أفهم  تحويل  Windows API declarations  من 32 الى 64

وبرضه ما فهمتش كنت عايز زيادة وتفصيل وتطبيقات على الموضوع

كل سنه وحضرتك والمسلمين بخير بمناسبة عيد الاضحى     تقبل تحياتى

 

[جعفر الطريبق]

ان شاء الله لو اشتريت قريبا جهاز عليه الويندوز 64 بيت سأعدل كل أكواد الAPI  و عندئد سيكون أسهل علي أن أشرح كيف يعمل الكود و كيف تتعامل ال API Functionsمع الميموري Memory

[مختار حسين محمود]

ان شاء الله تعالى  .  سعدت وشرفت بك   تحياتى

[ياسر خليل أبو البراء]

أخي الغالي جعفر

جربت الملف وأعطاني رسالة خطأ في هذا الجزء الخاص بإظهار الفورم

    'display the userform
    Call ShowFormatedUserForm(Form:=UserForm1, TitleBarColor:=lTitleBarColor, GradientFill:=True, FontAttributesPtr:=VarPtr(tFontAttr), CharColorsPtr:=VarPtr(aCharColors(0)))

وتحديداً مع الكلمة

VarPtr

[جعفر الطريبق]

أخي الغالي جعفر

جربت الملف وأعطاني رسالة خطأ في هذا الجزء الخاص بإظهار الفورم

    'display the userform
    Call ShowFormatedUserForm(Form:=UserForm1, TitleBarColor:=lTitleBarColor, GradientFill:=True, FontAttributesPtr:=VarPtr(tFontAttr), CharColorsPtr:=VarPtr(aCharColors(0)))

وتحديداً مع الكلمة

VarPtr

الاستاد الفاضل ياسر ... أولا على سلامتك و أدعو الله أن تكون قد شفيت من المرض

جرب : VBA.VarPtr

[ياسر خليل أبو البراء]

أخي الغالي جعفر

نفس الخطأ في نفس المكان يظهر معي ..

 

[جعفر الطريبق]

الاستاد ياسر

ما هو نوع الخطأ .. هل  هو Compilation Error او  Runtime error  ...  و ما هي رسالة و رقم الخطأ اللدي يظهر

[ياسر خليل أبو البراء]

أخي الكريم جعفر ..بارك الله فيك

نوع الخطأ .. Compile error

Type mismatch

أنا بستخدم الآن ويندوز 10  64 بت ..

غيرت في الكود بما يتلائم مع نظام الـ 64 ولكن يظهر الخطأ في المكان الذي أشرت إليه