كيف تجعل ال Frame أو Userform شفافاً

[Emad Sabry]

كان (الأستاذ أبو عبد الملك السوفي) طلب كود لجعل ال Frame شفافاً 
ففكرت بشرح الموضوع والأكواد كلها وكيفية وضعها  من خلال ثلاث حالات 

 

الحالة الأولى :-

لجعل frame شفافاً ليعطى شكل صفحة الإكسل التى خلفه 

تقوم بعمل Class Modules 

ومن الخصائص تقوم بتغيير اسمه إلى CTransparentFrameMaker

ونقوم بوضع هذا الكود به 

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Private Type PICTDESC
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
    #Else
        hPic As Long
    #End If
    hPal As Long
End Type


#If VBA7 Then
    Private Declare PtrSafe Function GetDC 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private hMemDc As LongPtr
#Else
    Private Declare Function GetDC 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private hMemDc As Long
#End If

Private Const SRCCOPY = &HCC0020
Private Const PICTYPE_BITMAP = &H1
Private Const SM_CYFRAME = 33
Private Const HORZ = 8
Private Const VERT = 10

Private arFramesArray() As Control
Private i As Long

Private WithEvents oForm As UserForm


Private Sub Class_Initialize()
    i = -1
    VBA.AppActivate Application.Caption
    Call TakeFirstScreenSnapShot
End Sub

Private Sub Class_Terminate()
    DeleteDC hMemDc
End Sub
Public Sub AddFrame(ByVal Frame As Control)
    i = i + 1
    ReDim Preserve arFramesArray(i)
    Set arFramesArray(i) = Frame
    Set oForm = Frame.Parent
End Sub


Private Sub UpdateFrameBackGround(ByVal frm As Control)
    #If VBA7 Then
        Dim hMemDc2 As LongPtr, hMemBmp2 As LongPtr
    #Else
        Dim hMemDc2 As Long, hMemBmp2 As Long
    #End If

    Dim tFrameRect As RECT
    Dim oPic As IPicture

    On Error Resume Next
    GetWindowRect frm.[_GethWnd], tFrameRect
    With tFrameRect
        hMemDc2 = CreateCompatibleDC(hMemDc)
        hMemBmp2 = CreateCompatibleBitmap(hMemDc, .Right - .Left, .Bottom - .Top)
        SelectObject hMemDc2, hMemBmp2
        BitBlt hMemDc2, 0, 0, .Right - .Left, .Bottom - .Top, hMemDc, .Left, .Top + GetSystemMetrics(SM_CYFRAME), SRCCOPY
    End With
    Set oPic = CreatePic(hMemBmp2)
    SavePicture oPic, Environ("Temp") & "\" & frm.Name & ".bmp"
    Set frm.Picture = LoadPicture(Environ("Temp") & "\" & frm.Name & ".bmp")
    Kill Environ("Temp") & "\" & frm.Name & ".bmp"
    DeleteObject hMemBmp2
    DeleteDC hMemDc2
End Sub


#If VBA7 Then
    Private Function CreatePic(ByVal hbmp As LongPtr) As IPicture
#Else
    Private Function CreatePic(ByVal hbmp As Long) As IPicture
#End If

    Dim IID_IDispatch As GUID
    Dim uPicinfo As PICTDESC
    Dim IPic As IPicture

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo) '
        .Type = PICTYPE_BITMAP
        .hPic = hbmp
        .hPal = 0
    End With
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, 1, IPic
    Set CreatePic = IPic
End Function

Private Sub TakeFirstScreenSnapShot()

    #If VBA7 Then
        Dim scrDc As LongPtr, hMemBmp As LongPtr, hwnd As LongPtr
    #Else
        Dim scrDc As Long, hMemBmp As Long, hwnd As Long
    #End If

    Dim w As Long
    Dim h As Long
    
    scrDc = GetDC(0)
    w = GetDeviceCaps(scrDc, HORZ)
    h = GetDeviceCaps(scrDc, VERT)
    hMemDc = CreateCompatibleDC(scrDc)
    hMemBmp = CreateCompatibleBitmap(scrDc, w, h)
    SelectObject hMemDc, hMemBmp
    BitBlt hMemDc, 0, 0, w, h, scrDc, 0, 0, SRCCOPY
    ReleaseDC 0, scrDc
    DeleteObject hMemBmp
End Sub

Private Sub oForm_Layout()
    Dim k As Long
    
    For k = LBound(arFramesArray) To UBound(arFramesArray)
        UpdateFrameBackGround arFramesArray(k)
    Next
End Sub

 

 

ثم تقوم بوضع هذا الكود داخل اليوزرفورم عن طريق الضغط عليه دوبل كليك 

Option Explicit

Private oCTransparent As CTransparentFrameMaker


Private Sub UserForm_Initialize()
    Dim oCtl As Control

    Set oCTransparent = New CTransparentFrameMaker
    For Each oCtl In Me.Controls
        If TypeName(oCtl) = "Frame" Then
            oCTransparent.AddFrame oCtl
        End If
    Next
End Sub

 

وهذا الملف به تطبيقاً على الفكرة 

Frame.xlsm

 

------------------------------------------------------------------------------------------------------------------------------

الحالة الثانية :-

لجعل Frame شفافاً بلون Userform الذى اسفله 

نقوم  بوضع هذا الكود بداخل ال userform بالضغط دوبل كليك عليه 

Private Sub UserForm_activate()

    With Frame1
.BackColor = BackColor
End With

End Sub

وهذا ملف للتوضيح 

Frame1.xlsm

 

-----------------------------------------------------------------------------------------------------

الحالة الثالثة :-

لجعل userform وال frame شفافاً  (وهذا الكود والملف من مشاركات الأستاذ ali mohamed ali )

نقوم بوضع هذا الكود داخل اليوزرفورم عن طريق الضغط على اليوزرفورم دوبل كليك 

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Dim hWnd As Long


Private Sub UserForm_activate()
    Dim ufcap As String
    hWnd = FindWindow("ThunderDFrame", ufcap)
    hosami Me, 150
End Sub
Private Function hosami(frm As UserForm, Level As Byte) As Boolean
    SetWindowLong hWnd, GWL_EXSTYLE, WS_EX_LAYERED
    SetLayeredWindowAttributes hWnd, 0, Level, LWA_ALPHA
End Function

وهذا الملف به تطبيقا للفكرة 

شفافية اليوزرفورم .xlsm

[Ali Mohamed Ali]

احسنت استاذ عماد بارك الله فيك وجعله فى ميزان حسناتك