Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all articles
Browse latest Browse all 1449

Transparent Control By Multiple transparent windows form

$
0
0
Multiple transparent windows form a transparent program

How do you switch between multiple windows without changing the focus of the form?If you have five windows with similar layers and click and input textbox on the third window, the first two windows will continue to remain in the top position.
load a picture on form1.frm

load a alpha png file to pictureBox1
but pictureBox1 is not transparent
only form with WS_EX_LAYERED can real transparent.

Name:  Transparent Forms.jpg
Views: 39
Size:  26.5 KB
It seems too difficult to implement multiple transparent PNG displays at different levels on one form, with buttons and table controls interspersed in the middle.
My idea is to use multiple windows instead of multiple controls, and a main window to achieve unified follow dragging, and to limit the automatic adjustment of the size of each window.
For example, if the web control webbrowser adopts the color transparency method, a certain color on the web page may not be displayed.
Now the new method is to use a brand new form to load the web page controls separately.
A button can also be loaded separately with a new form.
Too many forms will cause the Z order to change after clicking. So all are set to the top mode (HWND_TOPMOST), and the top and bottom order of each window is set by the code.
Code:

Dim CTf As New PngForm
Dim CTf2 As New PngForm

Sub Main()
CTf.LoadPng App.Path & "\01.png"
mainf.show
CTf2.LoadPng App.Path & "\02.png"

End Sub

Code:

Private Const WIN32_NULL As Long = 0
Private Const WIN32_FALSE As Long = 0
Private Const WIN32_TRUE As Long = Not WIN32_FALSE

Private Declare Function CreateBitmap Lib "gdi32" ( _
    ByVal Width As Long, _
    ByVal Height As Long, _
    ByVal Planes As Long, _
    ByVal BitsPerPixel As Long, _
    ByRef Bits As Any) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Const LR_DEFAULTCOLOR As Long = 0

Private Declare Function CreateIconFromResourceEx Lib "user32" ( _
    ByRef IconBits As Byte, _
    ByVal cbIconBits As Long, _
    ByVal fIcon As Long, _
    ByVal dwVersion As Long, _
    ByVal cxDesired As Long, _
    ByVal cyDesired As Long, _
    ByVal uFlags 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 DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long

Private Enum DI_FLAGS
    DI_MASK = &H1&
    DI_IMAGE = &H2&
    DI_NORMAL = &H3&
    DI_COMPAT = &H4&
    DI_DEFAULTSIZE = &H8&
    DI_NOMIRROR = &H10&
End Enum

Private Declare Function DrawIconEx Lib "user32" ( _
    ByVal hDC As Long, _
    ByVal xLeft As Long, _
    ByVal yTop As Long, _
    ByVal hIcon As Long, _
    ByVal cxWidth As Long, _
    ByVal cyWidth As Long, _
    ByVal istepIfAniCur As Long, _
    ByVal hbrFlickerFreeDraw As Long, _
    ByVal diFlags As DI_FLAGS) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Type ICONINFO
    fIcon As Long    'API TRUE for icon, API FALSE for cursor.
    xHotspot As Long  'The hotspot X-coordinate for cursor.
    yHotspot As Long  'The hotspot Y-coordinate for cursor.
    hbmMask As Long  'HBITMAP handle to monochrome AND mask bitmap.
    hbmColor As Long  'HBITMAP handle to device dependent XOR mask bitmap.
End Type

Private Declare Function GetIconInfo Lib "user32" ( _
    ByVal hIcon As Long, _
    ByRef ICONINFO As ICONINFO) As Long

Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectW" ( _
    ByVal hObject As Long, _
    ByVal nCount As Long, _
    ByRef Obj As Any) As Long

Private Const GWL_EXSTYLE = -20
Private Const WS_EX_LAYERED = &H80000

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

Private Declare Function ReleaseDC Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal hDC As Long) As Long

Private Declare Function SelectObject Lib "gdi32" ( _
    ByVal hDC As Long, _
    ByVal hObject As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" ( _
    ByVal hwnd As Long, _
    ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long

Private Type POINT
    x As Long
    y As Long
End Type

Private Type SIZE
    cx As Long
    cy As Long
End Type

Private Const AC_SRC_OVER As Byte = 0
Private Const AC_SRC_ALPHA As Byte = 1

Private Type BLENDFUNCTION
    BlendOp As Byte 'Always AC_SRC_OVER.
    BlendFlags As Byte 'Always 0.
    SourceConstantAlpha As Byte 'We'll set this value upon use.
    AlphaFormat As Byte 'Always AC_SRC_ALPHA.
End Type

Private Enum ULW_FLAGS
    ULW_COLORKEY = &H1&
    ULW_ALPHA = &H2&
    ULW_OPAQUE = &H4&
    ULW_EX_NORESIZE = &H8&
End Enum

Private Declare Function UpdateLayeredWindow Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal hdcDst As Long, _
    ByRef ptDst As Any, _
    ByRef sizeNew As Any, _
    ByVal hdcSrc As Long, _
    ByRef ptSrc As Any, _
    ByVal crKey As Long, _
    ByRef blend As BLENDFUNCTION, _
    ByVal dwFlags As ULW_FLAGS) As Long

'For dragging:
Private GrabX As Single
Private GrabY As Single

Private Sub Form_DblClick()
    Unload Me
End Sub
Sub LoadPng(Png1 As String)

 
    Dim Bytes() As Byte
    Dim hIcon As Long
    Dim ICONINFO As ICONINFO
    Dim BITMAP As BITMAP
    Dim sizeNew As SIZE
    Dim ptDst As POINT
    Dim ptSrc As POINT '0, 0
    Dim BLENDFUNCTION As BLENDFUNCTION
    Dim hdcScreen As Long
    Dim hdcMem As Long
    Dim hbm As Long

    'Bytes = LoadResData("CIRCLE", "PNG")
    Bytes = OpenBinFile(Png1)
    'App.Path & "\01透明PNG_ICQ.png")
    hIcon = CreateIconFromResourceEx(Bytes(0), _
                                    UBound(Bytes) + 1, _
                                    WIN32_TRUE, _
                                    &H30000, _
                                    0, _
                                    0, _
                                    LR_DEFAULTCOLOR)
    Erase Bytes
    GetIconInfo hIcon, ICONINFO
    GetObject ICONINFO.hbmColor, LenB(BITMAP), BITMAP
    With BITMAP
        sizeNew.cx = .bmWidth
        sizeNew.cy = .bmHeight
    End With
    hdcScreen = GetDC(WIN32_NULL)
    hdcMem = CreateCompatibleDC(hdcScreen)
    With sizeNew
        hbm = CreateBitmap(.cx, .cy, 1, 32, ByVal WIN32_NULL)
        SelectObject hdcMem, hbm
        DrawIconEx hdcMem, _
                  0, _
                  0, _
                  hIcon, _
                  .cx, _
                  .cy, _
                  0, _
                  WIN32_NULL, _
                  DI_NORMAL
    End With
    DestroyIcon hIcon
    SetWindowLong hwnd, _
                  GWL_EXSTYLE, _
                  GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    With ptDst
        .x = ScaleX(Left, vbTwips, vbPixels)
        .y = ScaleY(Top, vbTwips, vbPixels)
    End With
    With BLENDFUNCTION
        .BlendOp = AC_SRC_OVER
        .SourceConstantAlpha = 255
        .AlphaFormat = AC_SRC_ALPHA
    End With
    UpdateLayeredWindow hwnd, _
                        hdcScreen, _
                        ptDst, _
                        sizeNew, _
                        hdcMem, _
                        ptSrc, _
                        0, _
                        BLENDFUNCTION, _
                        ULW_ALPHA
    ReleaseDC WIN32_NULL, hdcScreen
    DeleteDC hdcMem 'Releases hbm.
    DeleteObject hbm
Me.Show
    'MsgBox "Left-click to end, right-click and drag"
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
    Call ReleaseCapture
    SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If
End Sub

Function OpenBinFile(filename As String, Optional ErrInfo As String) As Byte()
  '[mycode_id:1903],edittime:2011/7/11 13:27:34
On Error Resume Next
Dim hFile As Integer
hFile = FreeFile
Open filename For Binary As #hFile
ReDim OpenBinFile(LOF(hFile) - 1)
Get #hFile, , OpenBinFile
Close #hFile
End Function

Attached Images
 

Viewing all articles
Browse latest Browse all 1449

Trending Articles



<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>