أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
أحمد يوسف ali mohamed ali-- لا تميز خلال هذه الفترة YasserKhalil كود بسيط لمعرفة معلومات مهمه عن جهازك - حسام خطاب اكسيل اسئله واجابات


اعلان هنا
ألعاب فلاش أون لاين
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا



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





تغيير لون و حجم عنوان اليوزرفورم

السلام عليكم من فضلكم ارغب في تغيير لون و حجم عنوان اليوزرفورم وجدة تقريبا ملف لكن لا يعمل معي شكرا لكم لمشاهدة الرو ..



28-10-2019 08:31 مساء
ANASS1
menu_open
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-04-2018
رقم العضوية : 5696
المشاركات : 21
الجنس : ذكر
تاريخ الميلاد : 22-1-1990
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 28
الاعجاب : 6
 offline 

السلام عليكم 
من فضلكم ارغب في تغيير لون و حجم عنوان اليوزرفورم
  MbwL3_Sans titre
وجدة تقريبا ملف لكن لا يعمل معي
شكرا لكم
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
 
  V1 (2).xlsm   تحميل xlsm مرات التحميل :(6)
الحجم :(32.743) KB







29-10-2019 02:11 صباحا
مشاهدة مشاركة منفردة [1]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8156
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 428
قوة السمعة : 23779
الاعجاب : 2459
 offline 
look/images/icons/i1.gif تغيير لون و حجم عنوان اليوزرفورم
يمكنك متابعة الموضوع ومحاولة الرد في الرابط التالي حيث أن الكود يرجع للأخ جعفر طرباق من المغرب
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب

أثارت هذه المشاركة إعجاب: ali mohamed ali، ANASS1،




29-10-2019 09:21 مساء
مشاهدة مشاركة منفردة [2]
ANASS1
menu_open
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-04-2018
رقم العضوية : 5696
المشاركات : 21
الجنس : ذكر
تاريخ الميلاد : 22-1-1990
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 28
الاعجاب : 6
 offline 
look/images/icons/i1.gif تغيير لون و حجم عنوان اليوزرفورم
شكرا الاستاد ياسر خليل 
الكود لا يعمل في showmodal= true
سأحاول طرح هدا السِؤال
 





29-10-2019 10:13 مساء
مشاهدة مشاركة منفردة [3]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8156
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 428
قوة السمعة : 23779
الاعجاب : 2459
 offline 
look/images/icons/i1.gif تغيير لون و حجم عنوان اليوزرفورم
ولكن في الفورم المرفق جربت تغيير الخاصية لـ False ولم يعمل أيضاً .. أعتقد أن الكود يحتاج لتعديلات في قسم الإعلانات الخاصة باختلاف نسخ الأوفيس والويندوز ليتوافق مع الأنظمة المختلفة





29-10-2019 10:29 مساء
مشاهدة مشاركة منفردة [4]
ANASS1
menu_open
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-04-2018
رقم العضوية : 5696
المشاركات : 21
الجنس : ذكر
تاريخ الميلاد : 22-1-1990
يتابعهم : 1
يتابعونه : 0
قوة السمعة : 28
الاعجاب : 6
 offline 
look/images/icons/i1.gif تغيير لون و حجم عنوان اليوزرفورم
أسف قصدت كود الاخ جعفر
Option Explicit
 
'API Structures.
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
     #If VBA7 Then
        lbHatch As LongPtr
    #Else
        lbHatch As Long
    #End If
End Type

Private Type PAINTSTRUCT
    #If VBA7 Then
        hdc As LongPtr
    #Else
        hdc As Long
    #End If
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(0 To 31) 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 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

'API Function Declarations.
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
        Private Declare PtrSafe Function GetClassLong Lib "user32" Alias "GetClassLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetClassLong Lib "user32" Alias "SetClassLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
        Private Declare PtrSafe Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #End If
    Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
    Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe 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 PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
    Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nMapMode As Long) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GradientFillRect Lib "msimg32" Alias "GradientFill" (ByVal hdc As LongPtr, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
    Private Declare PtrSafe Function DrawFrameControl Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long
    Private Declare PtrSafe Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT, ByVal bErase As Long) As Long
    
    Private lPrevWinProc As LongPtr, lHook As LongPtr
#Else
    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 Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
    Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
    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 hhk 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 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" (ByVal hdc As Long, 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" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
    Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex 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 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 Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long


    Private lPrevWinProc As Long, lHook As Long
#End If

'API Constants.
Private Const WH_CBT As Long = 5
Private Const GWL_WNDPROC As Long = -4
Private Const GCL_STYLE = -26
Private Const GWL_STYLE As Long = (-16)
Private Const HCBT_ACTIVATE As Long = 5
Private Const WM_ACTIVATE As Long = &H6
Private Const WM_EXITSIZEMOVE As Long = &H232
Private Const WM_DESTROY As Long = &H2
Private Const WM_SYSCOMMAND = &H112
Private Const WM_NCPAINT = &H85
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WS_SYSMENU = &H80000
Private Const SM_CXSIZE = 30
Private Const SM_CYSIZE = 31
Private Const DFCS_PUSHED = &H200
Private Const CS_DROPSHADOW = &H20000
Private Const DFC_CAPTION = 1
Private Const DFCS_CAPTIONCLOSE = &H0
Private Const SM_CYCAPTION As Long = 4
Private Const COLOR_ACTIVECAPTION = 2
Private Const GRADIENT_FILL_RECT_H As Long = &H0
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2

'Module level variables.
Private oForm As Object
Private tWinRect As RECT
Private tCloseRect As RECT
Private tUpdatedCloseButtonRect As RECT
Private sFontName As String
Private sCaptionText As String
Private bDrawn As Boolean
Private bDropShadow As Boolean
Private bHookEnabled As Boolean
Private bGradientFill As Boolean
Private bFontBold As Boolean
Private bFontItalic As Boolean
Private bFontUnderline As Boolean
Private bCloseButtonPressed As Boolean
Private lTitleBarColor As Long
Private lFontColor  As Long
Private lFontSize As Long


Public Sub FormatFormCaption( _
    ByVal Form As Object, _
    Optional ByVal TitleBarColor As Variant, _
    Optional ByVal GradientFill As Boolean, _
    Optional ByVal DropShadow As Boolean, _
    Optional ByVal FontName As String, _
    Optional ByVal FontColor As Long, _
    Optional ByVal FontSize As Long, _
    Optional ByVal FontBold As Boolean, _
    Optional ByVal FontItalic As Boolean, _
    Optional ByVal FontUnderline As Boolean _
)

    Call HookUserForm(ByVal Form, _
        ByVal TitleBarColor, _
        ByVal GradientFill, _
        ByVal DropShadow, _
        ByVal FontName, _
        ByVal FontColor, _
        ByVal FontSize, _
        ByVal FontBold, _
        ByVal FontItalic, _
        ByVal FontUnderline _
    )
End Sub

Private Sub HookUserForm( _
    ByVal Form As Object, _
    Optional ByVal TitleBarColor As Variant, _
    Optional ByVal GradientFill As Boolean, _
    Optional ByVal DropShadow As Boolean, _
    Optional ByVal FontName As String, _
    Optional ByVal FontColor As Long, _
    Optional ByVal FontSize As Long, _
    Optional ByVal FontBold As Boolean, _
    Optional ByVal FontItalic As Boolean, _
    Optional ByVal FontUnderline As Boolean _
)

    If Not bHookEnabled Then
        Set oForm = Form
        sCaptionText = Form.Caption
        bGradientFill = GradientFill
        If IsMissing(TitleBarColor) Then
            lTitleBarColor = GetSysColor(COLOR_ACTIVECAPTION)
        Else
            lTitleBarColor = TitleBarColor
        End If
        bDropShadow = DropShadow
        sFontName = FontName
        lFontColor = FontColor
        lFontSize = FontSize
        bFontBold = FontBold
        bFontItalic = FontItalic
        bFontUnderline = FontUnderline
        lHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
        bHookEnabled = True
    Else
        UnhookWindowsHookEx lHook
        MsgBox "The hook is already set.", vbInformation
    End If
End Sub

#If VBA7 Then
    Private Function HookProc(ByVal idHook As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim hwnd As LongPtr
#Else
    Private Function HookProc(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hwnd As Long
#End If

    If idHook = HCBT_ACTIVATE Then
        If IsWindowEnabled(GetParent(wParam)) Then
            UnhookWindowsHookEx lHook
            Call ResetVariables
            MsgBox "You can't format a Modeless Userform.", vbCritical
            Exit Function
        End If
        WindowFromAccessibleObject oForm, hwnd
        If hwnd = wParam Then
            lPrevWinProc = SetWindowLong(wParam, GWL_WNDPROC, AddressOf CallBackProc)
            bHookEnabled = False
            UnhookWindowsHookEx lHook
        End If
    End If
    HookProc = CallNextHookEx(lHook, idHook, ByVal wParam, ByVal lParam)
End Function
 
#If VBA7 Then
    Private Function CallBackProc(ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Private Function CallBackProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If
 
    Dim tPt As POINTAPI, tClientRect As RECT
    Dim loword As Long, hiword As Long
                    
    GetClientRect hwnd, tClientRect
    
    Select Case Msg
     
        Case WM_NCLBUTTONDOWN
            SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE + SWP_NOMOVE
        
        Case WM_ACTIVATE
            If wParam = 0 Then SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE + SWP_NOMOVE
            SetWindowLong hwnd, GWL_STYLE, (GetWindowLong(hwnd, GWL_STYLE) And Not WS_SYSMENU)
            Call DrawTitleBar(hwnd, lTitleBarColor)
            InvalidateRect hwnd, tClientRect, 0
            
        Case WM_EXITSIZEMOVE
            Call DrawTitleBar(hwnd, lTitleBarColor)
            InvalidateRect hwnd, tClientRect, 0
            
        Case WM_NCPAINT
            If bDrawn = False Then bDrawn = True: Call DrawTitleBar(hwnd, lTitleBarColor)
            Exit Function
            
        Case WM_SYSCOMMAND
            GetHiLoword CLng(lParam), loword, hiword
            tPt.x = loword
            tPt.y = hiword
            #If VBA7 Then
                Dim lngPtr As LongPtr
                #If Win64 Then
                    CopyMemory lngPtr, tPt, LenB(tPt)
                    If PtInRect(tUpdatedCloseButtonRect, lngPtr) Then
                #Else
                    If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
                #End If
            #Else
                If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
            #End If
            
                Call DrawTitleBar(hwnd, lTitleBarColor, True)
                Do
                    DoEvents
                Loop Until GetAsyncKeyState(vbKeyLButton) = 0
    
                GetCursorPos tPt
                #If VBA7 Then
                    #If Win64 Then
                        CopyMemory lngPtr, tPt, LenB(tPt)
                        If PtInRect(tUpdatedCloseButtonRect, lngPtr) Then
                    #Else
                        If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
                    #End If
                #Else
                    If PtInRect(tUpdatedCloseButtonRect, tPt.x, tPt.y) Then
                #End If
                        If bCloseButtonPressed Then Sleep 200
                        Unload oForm
                    End If
                End If
                
                If bCloseButtonPressed Then
                    Call DrawTitleBar(hwnd, lTitleBarColor)
                    InvalidateRect hwnd, tClientRect, 0
                End If
                
        Case WM_DESTROY
            SetWindowLong hwnd, GWL_WNDPROC, lPrevWinProc
            SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) And Not CS_DROPSHADOW
            Call ResetVariables
    End Select
    
    CallBackProc = CallWindowProc(lPrevWinProc, hwnd, Msg, wParam, ByVal lParam)
End Function
 
#If VBA7 Then
    Private Sub DrawTitleBar(hwnd As LongPtr, ByVal CaptionColor As Long, Optional ByVal PressedCloseButton As Boolean)
    Dim hdc As LongPtr, hBrush As LongPtr
#Else
    Private Sub DrawTitleBar(hwnd As Long, ByVal CaptionColor As Long, Optional ByVal PressedCloseButton As Boolean)
    Dim hdc As Long, hBrush As Long
#End If
 
    Dim p1 As POINTAPI, p2 As POINTAPI
    Dim tFormRect As RECT, tFillRect As RECT
    Dim tPs As PAINTSTRUCT, tLb As LOGBRUSH
    Dim vert(2) As TRIVERTEX, tPt As GRADIENT_RECT
    Dim r As Byte, G As Byte, B As Byte
    
    Call BeginPaint(hwnd, tPs)
        hdc = GetWindowDC(hwnd)
        tLb.lbColor = CaptionColor
        hBrush = CreateBrushIndirect(tLb)
        Call GetWindowRect(hwnd, tFormRect)
        
        bCloseButtonPressed = PressedCloseButton
            
        If Not PressedCloseButton Then
            If bGradientFill Then
                ConvertLongToRGB CaptionColor, 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 = tFormRect.Right - tFormRect.Left
                    .y = GetSystemMetrics(SM_CYSIZE) + (tFormRect.Bottom - tFormRect.Top)
                    .Red = TransfCol(0)
                    .Green = TransfCol(0)
                    .Blue = TransfCol(0)
                    .Alpha = TransfCol(0)
                End With
                tPt.UpperLeft = 0
                tPt.LowerRight = 1
                GradientFillRect hdc, vert(0), 2, tPt, 1, GRADIENT_FILL_RECT_H
            Else
                SetRect tFormRect, 0, 0, tFormRect.Right, tFormRect.Bottom
                SetRect tFillRect, 0, 5, GetSystemMetrics(SM_CXSIZE), GetSystemMetrics(SM_CYSIZE) + tFormRect.Bottom
                OffsetRect tFillRect, tWinRect.Right - tWinRect.Left - GetSystemMetrics(SM_CXSIZE), 0
                FillRect hdc, tFormRect, hBrush
                Call DeleteObject(hBrush)
            End If
            DrawFrameControl hdc, tCloseRect, DFC_CAPTION, DFCS_CAPTIONCLOSE
        Else
            DrawFrameControl hdc, tCloseRect, DFC_CAPTION, DFCS_CAPTIONCLOSE + DFCS_PUSHED
        End If
        
        If bDropShadow Then
            SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW
        End If
        
        SetBkMode hdc, 1
        SetTextColor hdc, lFontColor
        Call CreateFont(hdc)
        TextOut hdc, 4, 4, sCaptionText, Len(sCaptionText)
            
        GetClientRect hwnd, tCloseRect
        With tCloseRect
            .Bottom = GetSystemMetrics(SM_CYCAPTION)
            .Left = .Right - 20
            .Right = .Right + 3
            .Top = .Top + 4
        End With
        With tCloseRect
            p1.x = .Left - 2: p1.y = .Top - 2
            p2.x = .Right:  p2.y = .Bottom - GetSystemMetrics(SM_CYCAPTION) - 2
        End With
        ClientToScreen hwnd, p1
        ClientToScreen hwnd, p2
        With tUpdatedCloseButtonRect
            .Left = p1.x: .Top = p1.y - GetSystemMetrics(SM_CYCAPTION)
            .Right = p2.x:  .Bottom = p2.y
        End With
        ReleaseDC hwnd, hdc
    Call EndPaint(hwnd, tPs)
End Sub

#If VBA7 Then
    Private Sub CreateFont(DC As LongPtr)
    Dim hNewFont As LongPtr
#Else
    Private Sub CreateFont(DC As Long)
    Dim hNewFont As Long
#End If
    Dim tFont As LOGFONT
    
    With tFont
        .lfFaceName = sFontName & Chr$(0)
        .lfWidth = lFontSize
        .lfWeight = IIf(bFontBold, 900, 100)
        .lfItalic = bFontItalic
        .lfUnderline = bFontUnderline
    End With
    hNewFont = CreateFontIndirect(tFont)
    DeleteObject (SelectObject(DC, hNewFont))
End Sub

Private Sub ResetVariables()
    bHookEnabled = False
    bCloseButtonPressed = False
    bDrawn = False
    bGradientFill = False
    bDropShadow = False
    sFontName = vbNullString
    lFontSize = 0
    bFontBold = False
    bFontItalic = False
    bFontUnderline = False
    sCaptionText = vbNullString
    lTitleBarColor = 0
    lFontColor = 0
    Set oForm = Nothing
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

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 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


Option Explicit

Private Sub UserForm_Initialize()

    Call FormatFormCaption( _
        Form:=Me, _
        TitleBarColor:=vbCyan, _
        GradientFill:=True, _
        DropShadow:=True, _
        FontName:="MV Boli", _
        FontColor:=vbRed, _
        FontSize:=12, _
        FontBold:=True, _
        FontItalic:=True, _
        FontUnderline:=False _
    )


End Sub



لدي ويندووز 32bit اكسيل 2013 
المشكل انه لا يعمل في showmodal true
n17ZJ_Sans
​ 
 
 






29-10-2019 10:42 مساء
مشاهدة مشاركة منفردة [5]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 8156
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 19
يتابعهم : 0
يتابعونه : 428
قوة السمعة : 23779
الاعجاب : 2459
 offline 
look/images/icons/i1.gif تغيير لون و حجم عنوان اليوزرفورم
يمكنك وضع هذه الملحوظة في الرابط المشار إليه ربما تجد إجابة على تسؤالك إن شاء الله

أثارت هذه المشاركة إعجاب: ANASS1، nyfmpha،






الكلمات الدلالية
اليوزرفورم ، عنوان ،


 







اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.



الساعة الآن 05:54 صباحا

أعلن هنا
أعلن هنا
أعلن هنا