اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

هدية للمنتدى ... جعل الفورم شفاف مع التحكم فيه - كود لأول مرة على الانترنيت !

جعفر الطريبق

بواسطه جعفر الطريبق
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

جعفر الطريبق

جعفر الطريبق

قام بنشر
قام بنشر (معدل)

السلام عليكم

كما تعلمون أثير موضوع جعل الفورم شفافا في المنتدى مؤخرا ... الموضوع على الرابطان:

http://www.officena.net/ib/topic/63786-كود-لجعل-الفورم-شفاف/

http://www.officena.net/ib/topic/63770-transparent-userform-فورم-شفاف/

الكود في الرابط الأول يمكننا من التحكم في درجة شفافية الفورم لكن المشكلة هي أن الشفافية تطال اطار الفورم و ال TitleBar و جميع الكونترولات و كل شيئ داخل الفورم و في النهاية مع زيادة درجات الشفافية كل شيئ يختفي من على الشاشة !

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

 

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

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

الحمد لله و بعد يومين من التجريب و الاصرار يبدو أنني توصلت الى حل (أو هكدا أتمنى)

طبعا الكود لا يعمل على الأوفيس 64Bit ... لكي يعمل ينبغي تعديل الكود لكن ليس لدي Office 64Bit  لكي أجرب و أقوم بالاختبارات الازمة

الكود يعمل جيدا على ال Modal و ال Modeless  فورم

 

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

 

الكود:

أضف فورم و أضف الى الفورم CommandButton1  و Label1  و ScrollBar1 ثم ضع الكود التالي في اليوزرفورم موديول:

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 GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ClientToScreen Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc 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 AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
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 SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Private Const PICTYPE_BITMAP = &H1
Private Const SRCCOPY = &HCC0020
Private Const AC_SRC_OVER = &H0
Private Const OPAQUE = &H2
Private Const GWL_EXSTYLE = (-20)          '
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private tRect As RECT
Private hInitialDCMemory As Long
Private frmHwnd As Long
Private frmDc As Long
Private hBrush As Long
Private hBmp As Long
Private bytScrollBarVal As Byte
  
Private Sub UserForm_Initialize()
    Dim LB As LOGBRUSH
    Dim Realcolor As Long
    Dim tRed As OLE_COLOR, tGreen As OLE_COLOR, tBlue As OLE_COLOR
    
    'setup form controls
        ScrollBar1.Min = 0
        ScrollBar1.Max = 255
        ScrollBar1.SmallChange = 3
        ScrollBar1.BackColor = vbCyan
        Label1.Font.Bold = True
        Label1.BackStyle = fmBackStyleTransparent
        CommandButton1.Caption = "Close"
        CommandButton1.Font.Bold = True
        Me.Caption = "Adjustable Transparent UserForm -- (Client Area)"
    'retrieve the form hwnd and DC
        frmHwnd = FindWindow(vbNullString, Me.Caption)
        frmDc = GetDC(frmHwnd)
    'convert system color to RGB
        TranslateColor Me.BackColor, 0, Realcolor
        tRed = Val(CStr(Realcolor And &HFF&))
        tGreen = Val(CStr((Realcolor And &HFF00&) / 2 ^ 8))
        tBlue = Val(CStr((Realcolor And &HFF0000) / 2 ^ 16))
        LB.lbColor = RGB(tRed, tGreen, tBlue)
    'create a memory DC and store the initial form backColor in it for later blending
        hBrush = CreateBrushIndirect(LB)
        GetWindowRect frmHwnd, tRect
        hInitialDCMemory = CreateCompatibleDC(frmDc)
        With tRect
            hBmp = CreateCompatibleBitmap(frmDc, .Right - .Left, .Bottom - .Top)
        End With
        Call SelectObject(hInitialDCMemory, hBmp)
        SetBkMode hInitialDCMemory, OPAQUE
        FillRect hInitialDCMemory, tRect, hBrush
End Sub

Private Sub UserForm_Layout()
    Call UpdateFormPicture
End Sub
  
 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    'cleanUp
    DeleteObject hBrush
    DeleteObject hBmp
End Sub

Private Sub UpdateFormPicture()
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim tPt As POINTAPI
    Dim BF As BLENDFUNCTION
    Dim lBF As Long
    Dim scrDc As Long
    Dim frmClientWid As Long
    Dim frmClientHgt As Long
    Dim hDCMemory As Long
    
    'Update Label with current Transparency rate
        Me.Label1.Caption = "Transparency : " & 100 - (100 * Me.ScrollBar1.Value \ 255) & "%"
    'brievely make the form fully transparent in order to capture the screen area underneath the form
        SetWindowLong frmHwnd, GWL_EXSTYLE, GetWindowLong(frmHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
        SetLayeredWindowAttributes frmHwnd, 0, 0, LWA_ALPHA
        scrDc = GetDC(0)
        SetLayeredWindowAttributes frmHwnd, 0, 255, LWA_ALPHA
    'retrieve the form's client dimensions
        GetClientRect frmHwnd, tRect
        With tRect
            frmClientWid = .Right - .Left
            frmClientHgt = .Bottom - .Top
        End With
    'create a memory DC to hold the screen area underneath the form
        hDCMemory = CreateCompatibleDC(scrDc)
        hBmp = CreateCompatibleBitmap(scrDc, frmClientWid, frmClientHgt)
        Call SelectObject(hDCMemory, hBmp)
        tPt.X = tRect.Left: tPt.Y = tRect.Top
        ClientToScreen frmHwnd, tPt
        Call BitBlt(hDCMemory, 0, 0, frmClientWid, frmClientHgt, scrDc, tPt.X, tPt.Y, SRCCOPY)
    'blend the form's initial backcolor with the screen image underneath the form
        With BF
            .BlendOp = AC_SRC_OVER
            .BlendFlags = 0
            .SourceConstantAlpha = bytScrollBarVal
            .AlphaFormat = 0
        End With
        RtlMoveMemory lBF, BF, 4
        AlphaBlend hDCMemory, 0, 0, frmClientWid, frmClientHgt, hInitialDCMemory, 0, 0, frmClientWid, frmClientHgt, lBF
    'Set the Form's Picture property to the resulting blended memory Bitmap
        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, True, IPic
        Set Me.Picture = IPic
    'cleanUp
        ReleaseDC frmHwnd, frmDc
        DeleteDC hDCMemory
        ReleaseDC 0, scrDc
End Sub

Private Sub ScrollBar1_Change()
    bytScrollBarVal = ScrollBar1.Value
    Call UpdateFormPicture
End Sub
Private Sub ScrollBar1_Scroll()
    bytScrollBarVal = ScrollBar1.Value
    Call UpdateFormPicture
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub

 

 

 

تم تعديل بواسطه جعفر الطريبق
  • Like 4
رابط هذا التعليق
شارك
عبد العزيز البسكري

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

قام بنشر
قام بنشر

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

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

                                   فائق احتراماتي

11.thumb.jpg.76eacb5c397f0f1547cfa27516a

رابط هذا التعليق
شارك
إبراهيم ابوليله

إبراهيم ابوليله

قام بنشر
قام بنشر

اخى واستاذى جعفر

بالراحه علينا شويه ياعم الحاج

الدماغ هتسيح

مشكورا على الاكواد الجميله دى

والشكر موصول لاخونا ياسر

لانه دعاء للمنتدى

بصراحه الرائع لاياتى الا برائع مثله

وانتم الاثنين من الافاضل

تقبل تحياتى

  • Like 1
رابط هذا التعليق
شارك
مختار حسين محمود

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

قام بنشر
قام بنشر

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

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

                                 تحياتى

  • Like 1
رابط هذا التعليق
شارك
جعفر الطريبق

جعفر الطريبق

قام بنشر
  • الكاتب
قام بنشر

شكرا جزيلا على الردود و التشجيعات

في ما يلي بعض الاضافات و التعديلات على الكود لاستيعاب سيناريو  تحديث خلفية الفورم تلقائيا عند تغيير الصفحات و الملفات في حالة اظهار الفورم Modeless  كما أنني غيرت ال ScrollBar  من اليمين الى اليسار

TranspEx.png

 

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

الكود المعدل :

Option Explicit
Private WithEvents oAppEvents As Application
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 GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ClientToScreen Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc 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 AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
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 SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Private Const PICTYPE_BITMAP = &H1
Private Const SRCCOPY = &HCC0020
Private Const AC_SRC_OVER = &H0
Private Const OPAQUE = &H2
Private Const GWL_EXSTYLE = (-20)          '
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private tRect As RECT
Private hInitialDCMemory As Long
Private frmHwnd As Long
Private frmDc As Long
Private hBrush As Long
Private hBmp As Long
Private bytScrollBarVal As Byte
  

Private Sub UserForm_Initialize()
    Dim LB As LOGBRUSH
    Dim Realcolor As Long
    Dim tRed As OLE_COLOR, tGreen As OLE_COLOR, tBlue As OLE_COLOR
    
    'hook the wb events
        Set oAppEvents = Application
    'setup form controls
        ScrollBar1.Min = 0
        ScrollBar1.Max = 255
        ScrollBar1.SmallChange = 3
        ScrollBar1.Value = ScrollBar1.Max
        ScrollBar1.BackColor = vbCyan
        Label1.Font.Bold = True
        Label1.BackStyle = fmBackStyleTransparent
        CommandButton1.Caption = "Close"
        CommandButton1.Font.Bold = True
        Me.Caption = "Adjustable Transparent UserForm -- (Client Area)"
    'retrieve the form hwnd and DC
        frmHwnd = FindWindow(vbNullString, Me.Caption)
        frmDc = GetDC(frmHwnd)
    'convert system color to RGB
        TranslateColor Me.BackColor, 0, Realcolor
        tRed = Val(CStr(Realcolor And &HFF&))
        tGreen = Val(CStr((Realcolor And &HFF00&) / 2 ^ 8))
        tBlue = Val(CStr((Realcolor And &HFF0000) / 2 ^ 16))
        LB.lbColor = RGB(tRed, tGreen, tBlue)
    'create a memory DC and store the initial form backColor in it for later blending
        hBrush = CreateBrushIndirect(LB)
        GetWindowRect frmHwnd, tRect
        hInitialDCMemory = CreateCompatibleDC(frmDc)
        With tRect
            hBmp = CreateCompatibleBitmap(frmDc, .Right - .Left, .Bottom - .Top)
        End With
        Call SelectObject(hInitialDCMemory, hBmp)
        SetBkMode hInitialDCMemory, OPAQUE
        FillRect hInitialDCMemory, tRect, hBrush
End Sub

Private Sub UserForm_Layout()
    Call UpdateFormPicture
End Sub
  
 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    'cleanUp
    DeleteObject hBrush
    DeleteObject hBmp
    Set oAppEvents = Nothing
End Sub

Private Sub UpdateFormPicture()
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim tPt As POINTAPI
    Dim BF As BLENDFUNCTION
    Dim lBF As Long
    Dim scrDc As Long
    Dim frmClientWid As Long
    Dim frmClientHgt As Long
    Dim hDCMemory As Long
    
    'Update Label with current Transparency rate
        Me.Label1.Caption = "Transparency : " & (100 * Me.ScrollBar1.Value \ 255) & "%"
    'brievely make the form fully transparent in order to capture the screen area underneath the form
        SetWindowLong frmHwnd, GWL_EXSTYLE, GetWindowLong(frmHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
        SetLayeredWindowAttributes frmHwnd, 0, 0, LWA_ALPHA
        scrDc = GetDC(0)
        SetLayeredWindowAttributes frmHwnd, 0, 255, LWA_ALPHA
    'retrieve the form's client dimensions
        GetClientRect frmHwnd, tRect
        With tRect
            frmClientWid = .Right - .Left
            frmClientHgt = .Bottom - .Top
        End With
    'create a memory DC to hold the screen area underneath the form
        hDCMemory = CreateCompatibleDC(scrDc)
        hBmp = CreateCompatibleBitmap(scrDc, frmClientWid, frmClientHgt)
        Call SelectObject(hDCMemory, hBmp)
        tPt.X = tRect.Left: tPt.Y = tRect.Top
        ClientToScreen frmHwnd, tPt
        Call BitBlt(hDCMemory, 0, 0, frmClientWid, frmClientHgt, scrDc, tPt.X, tPt.Y, SRCCOPY)
    'blend the form's initial backcolor with the screen image underneath the form
        With BF
            .BlendOp = AC_SRC_OVER
            .BlendFlags = 0
            .SourceConstantAlpha = bytScrollBarVal
            .AlphaFormat = 0
        End With
        RtlMoveMemory lBF, BF, 4
        AlphaBlend hDCMemory, 0, 0, frmClientWid, frmClientHgt, hInitialDCMemory, 0, 0, frmClientWid, frmClientHgt, lBF
    'Set the Form's Picture property to the resulting blended memory Bitmap
        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, True, IPic
        Set Me.Picture = IPic
    'cleanUp
        ReleaseDC frmHwnd, frmDc
        DeleteDC hDCMemory
        ReleaseDC 0, scrDc
End Sub

Private Sub ScrollBar1_Change()
    bytScrollBarVal = 255 - ScrollBar1.Value
    Call UpdateFormPicture
End Sub
Private Sub ScrollBar1_Scroll()
    bytScrollBarVal = 255 - ScrollBar1.Value
    Call UpdateFormPicture
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub

'Application events
Private Sub oAppEvents_SheetActivate(ByVal Sh As Object)
    Call UpdateFormPicture
End Sub
Private Sub oAppEvents_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call UpdateFormPicture
End Sub
Private Sub oAppEvents_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
    Call UpdateFormPicture
    DoEvents
End Sub
Private Sub oAppEvents_WorkbookActivate(ByVal Wb As Workbook)
    Call UpdateFormPicture
    DoEvents
End Sub

 

 

رابط هذا التعليق
شارك
عماراللهيبي

عماراللهيبي

قام بنشر
قام بنشر

بسم الله الرحمن الرحيم 

مشكور استاذ جعفر الطريبق

ولكن على كيفك ( مهلك ) معانا لاني مافهت من الكود إلا الشئ اليسير 

الرجاء مراعات مشاعر المبتدئين امثالي 

مع خالص شكري وتقديري 

رابط هذا التعليق
شارك
أنس دروبي

أنس دروبي

قام بنشر
قام بنشر

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

أخي وحبيبي جعفر الطريبق بارك الله فيك وجزاك كل خير على هذا الكود الخيالي والاكثر من رائع

نظراً لاحترافية الاداء وقوة العمل لدي فكرة نرجو منكم عرضها اذا أمكن

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

بيحث عند ظهور الفورم تظهر الصورة فقط من غير اطار الفورم وتظهر شفافة بشكل بسيط وتوجد فيها الكنترول من تكست بوكس وليبيل 

بحثت صراحة في المواقع الاجنبية ولكن كان الحل ليس في الفورم وانما الحل على ورقة العمل 

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

تقبل مروري وتحياتي 

 

رابط هذا التعليق
شارك
جعفر الطريبق

جعفر الطريبق

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

 

أستادي الفاضل أنس

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

 

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

 

صورة من الشاشة:

Sans%20titre.png

 

الكود:

 

1- كود في اليوزرفورم موديول:

Option Explicit
Private WithEvents oAppEvents As Application

Private Sub UserForm_Initialize()
        'this bool flag is there to prevent the UserForm_Layout event from running when first activating the form
        bFlag = False
        ' hook the application events
        Set oAppEvents = Application
        Caption = "Adjustable Transparent UserForm -- (Client Area)"
        ScrollBar1.Min = 0
        ScrollBar1.Max = 255
        ScrollBar1.SmallChange = 3
        ScrollBar1.Value = ScrollBar1.Min
         bytScrollBarVal = ScrollBar1.Min
        Label1.Caption = "Transparency : " & (100 * ScrollBar1.Value \ 255) & "%"
        Application.OnTime Now, "StoreTheInitialFormBackGround"
End Sub

Private Sub UserForm_Layout()
    'Do not run the UpdateFormPicture sub when first activating the form
    If bFlag = True Then
        Call UpdateFormPicture
    End If
End Sub
  
 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call CleanUp
    Set oAppEvents = Nothing
End Sub

Private Sub ScrollBar1_Change()
    bytScrollBarVal = ScrollBar1.Value
    Call UpdateFormPicture
End Sub
Private Sub ScrollBar1_Scroll()
    bytScrollBarVal = ScrollBar1.Value
    Call UpdateFormPicture
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub

'Application events
Private Sub oAppEvents_SheetActivate(ByVal Sh As Object)
    Call UpdateFormPicture
End Sub
Private Sub oAppEvents_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call UpdateFormPicture
End Sub
Private Sub oAppEvents_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
    Call UpdateFormPicture
    DoEvents
End Sub
Private Sub oAppEvents_WorkbookActivate(ByVal Wb As Workbook)
    Call UpdateFormPicture
    DoEvents
End Sub

 

2 - كود في ستاندار موديول:

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 GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As Long
    hPal As Long
End Type
Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ClientToScreen Lib "user32.dll" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc 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 AlphaBlend Lib "msimg32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
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 SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function TranslateColor Lib "olepro32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Private Const PICTYPE_BITMAP = &H1
Private Const SRCCOPY = &HCC0020
Private Const AC_SRC_OVER = &H0
Private Const OPAQUE = &H2
Private Const GWL_EXSTYLE = (-20)          '
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private tRect As RECT
Private hInitialDCMemory As Long
Private frmHwnd As Long
Private frmDc As Long
Private hBrush As Long
Private hBmp As Long
Public bytScrollBarVal As Byte
Public bFlag As Boolean

Public Sub StoreTheInitialFormBackGround()
    Dim LB As LOGBRUSH
    Dim Realcolor As Long
    Dim tRed As OLE_COLOR, tGreen As OLE_COLOR, tBlue As OLE_COLOR
    
    'retrieve the form hwnd and DC
    frmHwnd = FindWindow(vbNullString, UserForm1.Caption)
    frmDc = GetDC(frmHwnd)
    'get the form's client dimensions
    GetClientRect frmHwnd, tRect
    'create a memory DC and store the initial form backColor or Background picture in it for later blending
    hInitialDCMemory = CreateCompatibleDC(frmDc)
    With tRect
        hBmp = CreateCompatibleBitmap(frmDc, .Right - .Left, .Bottom - .Top)
    End With
    Call SelectObject(hInitialDCMemory, hBmp)
    DoEvents
    'if the form has no picture set then store the form's backcolor in the memory DC
    If UserForm1.Picture Is Nothing Then
        'convert system color to RGB
        TranslateColor UserForm1.BackColor, 0, Realcolor
        tRed = Val(CStr(Realcolor And &HFF&))
        tGreen = Val(CStr((Realcolor And &HFF00&) / 2 ^ 8))
        tBlue = Val(CStr((Realcolor And &HFF0000) / 2 ^ 16))
        LB.lbColor = RGB(tRed, tGreen, tBlue)
        hBrush = CreateBrushIndirect(LB)
        SetBkMode hInitialDCMemory, OPAQUE
        FillRect hInitialDCMemory, tRect, hBrush
    Else 'if the form has a background picture then store the picture in the memory DC
        With tRect
            Call BitBlt(hInitialDCMemory, 0, 0, .Right - .Left, .Bottom - .Top, frmDc, .Left, .Top, SRCCOPY)
        End With
    End If
    'set the bool Flag to indicate that the form has already been activated
    bFlag = True
End Sub


Public Sub UpdateFormPicture()
    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim tPt As POINTAPI
    Dim BF As BLENDFUNCTION
    Dim lBF As Long
    Dim scrDc As Long
    Dim frmClientWid As Long
    Dim frmClientHgt As Long
    Dim hDCMemory As Long
    
    'Update Label with current Transparency rate
        UserForm1.Label1.Caption = "Transparency : " & (100 * UserForm1.ScrollBar1.Value \ 255) & "%"
    'brievely make the form fully transparent in order to capture the screen area underneath the form
        SetWindowLong frmHwnd, GWL_EXSTYLE, GetWindowLong(frmHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
        SetLayeredWindowAttributes frmHwnd, 0, 0, LWA_ALPHA
        scrDc = GetDC(0)
        SetLayeredWindowAttributes frmHwnd, 0, 255, LWA_ALPHA
    'retrieve the form's client dimensions
        GetClientRect frmHwnd, tRect
        With tRect
            frmClientWid = .Right - .Left
            frmClientHgt = .Bottom - .Top
        End With
    'create a memory DC to hold the screen area underneath the form
        hDCMemory = CreateCompatibleDC(scrDc)
        hBmp = CreateCompatibleBitmap(scrDc, frmClientWid, frmClientHgt)
        Call SelectObject(hDCMemory, hBmp)
        tPt.x = tRect.Left: tPt.Y = tRect.Top
        ClientToScreen frmHwnd, tPt
        Call BitBlt(hDCMemory, 0, 0, frmClientWid, frmClientHgt, scrDc, tPt.x, tPt.Y, SRCCOPY)
    'blend the form's initial backcolor with the screen image underneath the form
        With BF
            .BlendOp = AC_SRC_OVER
            .BlendFlags = 0
            .SourceConstantAlpha = 255 - bytScrollBarVal
            .AlphaFormat = 0
        End With
        RtlMoveMemory lBF, BF, 4
        AlphaBlend hDCMemory, 0, 0, frmClientWid, frmClientHgt, hInitialDCMemory, 0, 0, frmClientWid, frmClientHgt, lBF
    'Set the Form's Picture property to the resulting blended memory Bitmap
        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, True, IPic
        Set UserForm1.Picture = IPic
    'cleanUp
        ReleaseDC frmHwnd, frmDc
        DeleteDC hDCMemory
        ReleaseDC 0, scrDc
End Sub

Public Sub CleanUp()
    DeleteObject hBrush
    DeleteObject hBmp
    bFlag = False
End Sub

 

  • Like 2
رابط هذا التعليق
شارك
أنس دروبي

أنس دروبي

قام بنشر
قام بنشر (معدل)

السلام عليكم

اخي واستاذي جعفر الطربيق قد قدمتي لي وللمنتدئ الكريم فكرة اكثر من رائعة بطريقة الفورم الشفاف وخاصة عندما اضيف صورة في الخلفية 

جاري استثمار هذه الفكرة المبهرة في اكسل لكي يكون قادر التواكب في المستقبل مع البرمجة وخضوعه لاكبر واضخم الاعمال المحاسبية 

اخي جعفر اريد ان الغي شريط التحكم في شفافية الفورم وجعله علئ مستوئ محدد من الشفافية

حاولت التعديل في الكود ولكن لم تنجح الطريقة

مثلا اريد الشفافية مربوطة علئ المستوئ 50% ولكن لانريد وجودالشريط 

بارك الله فيك وجزاك كل خير علئ تطبيق الافكار وتقديمها لنا علئ طبق من الماس 

اخوكم انس دروبي 

تم تعديل بواسطه أنس دروبي
تعديل
رابط هذا التعليق
شارك
أنس دروبي

أنس دروبي

قام بنشر
قام بنشر (معدل)

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

أخي جعفر الطريبق ......!

الملف تمت تجربته على أوفيس 2010/32 بت 

لم يعمل بشكل صحيح كانت النتيجة عند الزيادة والنقصان لم تتغير الشفافية أبداً ظلت على حالها بدون زيادة أونقصان

كما حصل في المشاركة رقم 2 مع أخي وحبيبي عبد العزيز البسكري

فهل هذا الشيئ صحيح أم يوجد خطأ عندنا في نسخة الأوفيس علماً النسخة أصلية مرفقة مع الويندوز

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

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

بارك الله فيك نريد عرض الأراء والفكرة من قبلكم 

تقبل تحياتي ومروري 

 TransparentUserForm.rar

تم تعديل بواسطه أنس دروبي
مرفقات
رابط هذا التعليق
شارك
جعفر الطريبق

جعفر الطريبق

قام بنشر
  • الكاتب
قام بنشر

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

أخي جعفر الطريبق ......!

الملف تمت تجربته على أوفيس 2010/32 بت 

لم يعمل بشكل صحيح كانت النتيجة عند الزيادة والنقصان لم تتغير الشفافية أبداً ظلت على حالها بدون زيادة أونقصان

كما حصل في المشاركة رقم 2 مع أخي وحبيبي عبد العزيز البسكري TransparentUserForm.rar

أستادي الفاضل أنس

جربت على عجالة الملف على أوفيس 32/2010 ويندوز 64 بت في احدى السيبيرات و بالفعل الملف لم يعمل كما تفضلت ولم تتغير الشفافية

للأسف بدون توفري على جهاز فيه الويندوز 64 لن أتمكن بسهولة من معرفة سبب المشكلة ..

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

  • Like 1
رابط هذا التعليق
شارك
أنس دروبي

أنس دروبي

قام بنشر
قام بنشر

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

أخي جعفر أعتذر عن التأخر في الرد ولكن لظروف الانترنت.....

أخي جعفر كان قصدي أنا في المشاركة السابقة

الملف المرفق الذي أرفقته أنا يعمل بشكل صحيح على أوفيس 2010 32 بت ويعطي النتيجة المطلوبة 

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

نرجو التوضيح حول هذا الأمر لوسمحت وتكرمت عليي

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

تقبل مروري وتحياتي

 

رابط هذا التعليق
شارك
جعفر الطريبق

جعفر الطريبق

قام بنشر
  • الكاتب
قام بنشر (معدل)

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

أخي جعفر أعتذر عن التأخر في الرد ولكن لظروف الانترنت.....

أخي جعفر كان قصدي أنا في المشاركة السابقة

الملف المرفق الذي أرفقته أنا يعمل بشكل صحيح على أوفيس 2010 32 بت ويعطي النتيجة المطلوبة 

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

نرجو التوضيح حول هذا الأمر لوسمحت وتكرمت عليي

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

تقبل مروري وتحياتي

أستادي الفاضل أنس

كما سبق لي و ان قلت انه يصعب علي كتابة الكود المناسب على أنظمة الويندوز 64 بت لأنني أشتغل على الويندوز 32 أوفيس 2007

برمجة ال API تحديدا تتطلب التجريب و اعادة التجريب  .. لقد أنشأت العديد من الأكواد في مجالات مختلفة و التي تحتاج الى تعديل لكي تشتغل على الويندوز 32 و 64 بت في نفس الوقت ... ان شاء الله خير عنما أقتني جهازا جديدا

 

تم تعديل بواسطه جعفر الطريبق
  • Like 1
رابط هذا التعليق
شارك
  • 4 weeks later...
جعفر الطريبق

جعفر الطريبق

قام بنشر
  • الكاتب
قام بنشر

السلام عليكم

تفضلوا الكود للتحكم قي درجة شفافية القورم  - نسخة 64Bit

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

1- كود في موديول الفورم :

Option Explicit
Private WithEvents oAppEvents As Application
Public bytScrollBarVal As Byte

'Userform events
Private Sub UserForm_Activate()
    Call UpdateFormPicture(Me)
End Sub

Private Sub UserForm_Initialize()
    Set oAppEvents = Application
    Call init(Me)
End Sub

Private Sub UserForm_Layout()
    Call UpdateFormPicture(Me)
End Sub
  
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Set oAppEvents = Nothing
    Call CleanUp
End Sub

Private Sub ScrollBar1_Change()
    Me.bytScrollBarVal = 255 - ScrollBar1.Value
    Call UpdateFormPicture(Me)
End Sub
Private Sub ScrollBar1_Scroll()
     Me.bytScrollBarVal = 255 - ScrollBar1.Value
    Call UpdateFormPicture(Me)
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub

'Application events
Private Sub oAppEvents_SheetActivate(ByVal Sh As Object)
    Call UpdateFormPicture(Me)
End Sub
Private Sub oAppEvents_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Call UpdateFormPicture(Me)
End Sub
Private Sub oAppEvents_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
    Call UpdateFormPicture(Me)
    DoEvents
End Sub
Private Sub oAppEvents_WorkbookActivate(ByVal Wb As Workbook)
    Call UpdateFormPicture(Me)
    DoEvents
End Sub

 

2- كود في موديول عادي :

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 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
    hPic As LongPtr
    hPal As Long
End Type
Private Type BLENDFUNCTION
    BlendOp As Byte
    BlendFlags As Byte
    SourceConstantAlpha As Byte
    AlphaFormat As Byte
End Type
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
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 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 AlphaBlend Lib "msimg32.dll" (ByVal hDC As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hDC As LongPtr, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT 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 CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
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 DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) 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 FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function TranslateColor Lib "oleAut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As LongPtr, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Private Const PICTYPE_BITMAP = &H1
Private Const SRCCOPY = &HCC0020
Private Const AC_SRC_OVER = &H0
Private Const OPAQUE = &H2
Private Const GWL_EXSTYLE = (-20)          '
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2

Private hInitialDCMemory As LongPtr
Private frmHwnd As LongPtr
Private frmDc As LongPtr

Public Sub init(ByVal oFrm As Object)
    Dim LB As LOGBRUSH
    Dim Realcolor As Long
    Dim tRed As OLE_COLOR, tGreen As OLE_COLOR, tBlue As OLE_COLOR
    Dim hBmp As LongPtr
    Dim tRect As RECT
    Dim hBrush As LongPtr
    
    'setup form controls
    With oFrm
        .ScrollBar1.Min = 0
        .ScrollBar1.Max = 255
        .ScrollBar1.SmallChange = 3
        .ScrollBar1.Value = .ScrollBar1.Max
        .ScrollBar1.BackColor = vbCyan
        .Label1.Font.Bold = True
        .Label1.BackStyle = fmBackStyleTransparent
        .CommandButton1.Caption = "Close"
        .CommandButton1.Font.Bold = True
        .Caption = "Adjustable Transparent UserForm -- (Client Area)"
    End With
    'retrieve the form hwnd and DC
    frmHwnd = FindWindow("ThunderDFrame", oFrm.Caption)
    frmDc = GetDC(frmHwnd)
    'convert system color to RGB
    TranslateColor oFrm.BackColor, 0, Realcolor
    tRed = Val(CStr(Realcolor And &HFF&))
    tGreen = Val(CStr((Realcolor And &HFF00&) / 2 ^ 8))
    tBlue = Val(CStr((Realcolor And &HFF0000) / 2 ^ 16))
    LB.lbColor = RGB(tRed, tGreen, tBlue)
    'create a memory DC and store the initial form backColor in it for later blending
    hBrush = CreateBrushIndirect(LB)
    GetWindowRect frmHwnd, tRect
    hInitialDCMemory = CreateCompatibleDC(frmDc)
    With tRect
        hBmp = CreateCompatibleBitmap(frmDc, .Right - .Left, .Bottom - .Top)
    End With
    Call SelectObject(hInitialDCMemory, hBmp)
    SetBkMode hInitialDCMemory, OPAQUE
    FillRect hInitialDCMemory, tRect, hBrush
    DeleteObject hBrush
    DeleteObject hBmp
    ReleaseDC frmHwnd, frmDc
End Sub

Public Sub UpdateFormPicture(ByVal oFrm As Object)
    Dim BF As BLENDFUNCTION
    Dim lBF As Long
    Dim IID_IDispatch As GUID
    Dim uPicinfo As PICTDESC
    Dim IPic As IPicture
    Dim tPt As POINTAPI
    Dim hBmp As LongPtr
    Dim scrDc As LongPtr
    Dim tRect As RECT
    Dim hDCMemory As LongPtr
    Static frmClientWid As Long
    Static frmClientHgt As Long
    Static l As Long
    
    oFrm.Label1.Caption = "Transparency : " & (100 * oFrm.ScrollBar1.Value \ 255) & "%"
    'brievely make the form fully transparent in order to capture the screen area underneath the form
    SetWindowLong frmHwnd, GWL_EXSTYLE, GetWindowLong(frmHwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    If l Mod 4 = 0 Then
        SetLayeredWindowAttributes frmHwnd, 0, 0, LWA_ALPHA
    End If
    l = l + 1
    scrDc = GetDC(0)
    hDCMemory = CreateCompatibleDC(scrDc)
    hBmp = CreateCompatibleBitmap(scrDc, frmClientWid, frmClientHgt)
    'retrieve the form's client dimensions
    GetClientRect frmHwnd, tRect
    With tRect
        frmClientWid = .Right - .Left
        frmClientHgt = .Bottom - .Top
    End With
    'create a memory DC to hold the screen area underneath the form
    Call SelectObject(hDCMemory, hBmp)
    tPt.x = tRect.Left: tPt.y = tRect.Top
    ClientToScreen frmHwnd, tPt
    Call BitBlt(hDCMemory, 0, 0, frmClientWid, frmClientHgt, scrDc, tPt.x, tPt.y, SRCCOPY)
    'make the form opaque again
    SetLayeredWindowAttributes frmHwnd, 0, 255, LWA_ALPHA
    'blend the form's initial backcolor with the screen image underneath the form
    With BF
        .BlendOp = AC_SRC_OVER
        .BlendFlags = 0
        .SourceConstantAlpha = oFrm.bytScrollBarVal
        .AlphaFormat = 0
    End With
    CopyMemory lBF, BF, 4
    AlphaBlend hDCMemory, 0, 0, frmClientWid, frmClientHgt, hInitialDCMemory, 0, 0, frmClientWid, frmClientHgt, lBF
    'Set the Form's Picture property to the resulting blended memory Bitmap
    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, True, IPic
    Set oFrm.Picture = IPic
    DeleteDC hDCMemory
    ReleaseDC 0, scrDc
    oFrm.Repaint
End Sub

Public Sub CleanUp()
  DeleteDC hInitialDCMemory
End Sub

 

  • Like 2
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept