Transparent user control (copy the control in the background of the parent window to achieve a transparent effect)
Two background pictures (001.jpg, 002.jpg), one larger and the other smaller. Please download it yourself and put it in the project directory
The biggest difficulty is that it supports DPI scaling. You can also specify only the background image of the copy window (parent object) without copying the control elements abo
In recent months, I have been researching various transparency technologies, turning existing text boxes into transparency, or adding background images. Self-developed transparent button control, PNG image control, etc. Some computers have DPI zoomed by 150%-200%. By intercepting the picture of the control's parent object (including other controls), it turns out that the size is wrong, so I wrote a DPI perception program, and the screenshot needs to be copied in equal proportions. This problem troubled me for 3 months and finally solved it. You can write it in the module, and you can use it in any form. PICTUREBOX becomes transparent, and usercontrol can also be transparent.
Code:
'code in form1.frm
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function ReleaseCapture Lib "User32" () As Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
'1, Add 001.jpg to Project Path
'2, Add Picturebox1 Control
'3, Copy This Code ,Run
Private Sub Form_Load()
Me.Picture = LoadPicture("001.jpg")
Picture1.AutoRedraw = True
Me.Caption = "drag the picture frame-transparent effect"
End Sub
Private Sub Form_Activate()
If Me.Tag = "" Then
Me.Tag = "a"
TransparentControl Picture1
End If
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Call ReleaseCapture
Call SendMessage(Picture1.Hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
TransparentControl Picture1
End If
End Sub
Code:
Option Explicit
'This Code Save To TransparentBas.bas
'100 Lines vb6 Code For TransparentControl(Picture1) 'Picturebox1
'============================
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 Declare Function GetDesktopWindow Lib "User32" () As Long
Private Declare Function CreateDC& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) 'DEVMODE
Private Declare Function GetWindowDC Lib "User32" (ByVal Hwnd As Long) As Long
Private Declare Function BringWindowToTop Lib "User32" (ByVal Hwnd As Long) As Long
Private Declare Function GetParent Lib "User32" (ByVal Hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "User32" (ByVal Hwnd As Long, lpRect As RECT) 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 Function ReleaseDC Lib "User32" (ByVal Hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function ShowWindow Lib "User32" (ByVal Hwnd As Long, ByVal nCmdShow 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 StretchBlt 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 nSrcWidth As Long, _
ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const SW_HIDE = 0
Declare Function GetDC Lib "User32" (ByVal Hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Const DESKTOPHORZRES As Long = 118
Private Const HORZRES As Long = 8
Private Const LOGPIXELSX = 88
Public DpiRate As Single '本程序显示缩放倍数
Function GetDpiRate() As Single
Dim Hdc0 As Long, Pixelx As Long, PixelY As Long, MonitorW As Long, MonitorH As Long
If DpiRate = 0 Then
Hdc0 = GetDC(0)
MonitorW = GetDeviceCaps(Hdc0, DESKTOPHORZRES)
Pixelx = GetDeviceCaps(Hdc0, HORZRES) '//水平像素总数
DpiRate = MonitorW / Pixelx
If DpiRate = 0 Then DpiRate = 1
GetDpiRate = DpiRate
End If
End Function
Sub TransparentControl(Control1 As Control)
TransparentHwndHdc Control1.Hwnd, Control1.hDC
End Sub
Sub TransparentHwndHdc(MyHwnd As Long, MyHdc As Long, Optional ByVal ParentHwnd As Long)
Dim ParentDc As Long, CopyFromScreen As Boolean
If DpiRate = 0 Then GetDpiRate
ShowWindow MyHwnd, SW_HIDE
DoEvents
If ParentHwnd = -1 Then 'cut img from Screen
CopyFromScreen = True
ParentHwnd = GetDesktopWindow
ParentDc = CreateDC("DISPLAY", 0, 0, 0)
Else
If ParentHwnd = 0 Then ParentHwnd = GetParent(MyHwnd)
ParentDc = GetWindowDC(ParentHwnd)
End If
Dim AreaWidth As Long, AreaHeight As Long, WinRect1 As RECT, ClientWh2 As RECT, ClientXY2 As POINTAPI
GetWindowRect ParentHwnd, WinRect1
GetClientRect MyHwnd, ClientWh2
ClientToScreen MyHwnd, ClientXY2
AreaWidth = ClientWh2.Right
AreaHeight = ClientWh2.Bottom
BringWindowToTop ParentHwnd
If CopyFromScreen Then
StretchBlt MyHdc, 0, 0, AreaWidth, AreaHeight, ParentDc, _
DpiRate * (ClientXY2.X - WinRect1.Left), _
DpiRate * (ClientXY2.Y - WinRect1.Top) _
, AreaWidth * DpiRate, AreaHeight * DpiRate, vbSrcCopy
Else
BitBlt MyHdc, 0, 0, AreaWidth, AreaHeight, ParentDc, ClientXY2.X - WinRect1.Left, ClientXY2.Y - WinRect1.Top, vbSrcCopy '原来
End If
ReleaseDC ParentHwnd, ParentDc
ShowWindow MyHwnd, 5
End Sub
Last edited by xiaoyao; May 4th, 2021 at 08:38 AM.
Private Sub CopyBKImage(ByVal BackImgModeA As CopyBKModeType, BackImgOnlyPictureA As Boolean)
If BackImgModeA = FromScreen Then
CopyImg UserControl.hwnd, UserControl.hDC, -1
Else
If BackImgOnlyPictureA Then
CopyParentBackground UserControl.hwnd, UserControl.hDC, 0
Else
CopyImg UserControl.hwnd, UserControl.hDC, UserControl.Parent.hwnd
End If
End If
UserControl.Refresh
End Sub
Code:
Sub DoTransparentControl(Control1 As Control)
DoTransparent Control1.hwnd, Control1.hDC
End Sub
sub DoTransparent(MyHwnd As Long, ByVal MyHdc As Long, optional ByVal ParentHwnd As Long)
'Private Sub CopyImg(MyHwnd As Long, MyHdc As Long, Optional ByVal ParentHwnd As Long)
'update 2021-5-4 20:00
Dim ParentDc As Long, CopyFromScreen As Boolean
If DpiRate = 0 Then GetDpiRate
ShowWindow MyHwnd, SW_HIDE
DoEvents
If ParentHwnd = -1 Then 'cut img from Screen
CopyFromScreen = True
ParentHwnd = GetDesktopWindow
ParentDc = CreateDC("DISPLAY", 0, 0, 0)
ElseIf ParentHwnd = 0 Then
ParentHwnd = GetParent(MyHwnd)
End If
ParentDc = GetWindowDC(ParentHwnd)
Dim AreaWidth As Long, AreaHeight As Long, WinRect1 As RECT, ClientWh2 As RECT, ClientXY2 As POINTAPI
GetWindowRect ParentHwnd, WinRect1
'获取【Form】的客户区坐标系(Right=宽度,Bottom=高度),重要,ABCD
GetClientRect MyHwnd, ClientWh2
'将客户区坐标系中的点p(0,0)转换为屏幕坐标(左上角位置),重要,ABCD
ClientToScreen MyHwnd, ClientXY2
AreaWidth = ClientWh2.Right
AreaHeight = ClientWh2.Bottom
BringWindowToTop ParentHwnd
If CopyFromScreen Then
StretchBlt MyHdc, 0, 0, AreaWidth, AreaHeight, ParentDc, _
DpiRate * (ClientXY2.x - WinRect1.Left), _
DpiRate * (ClientXY2.y - WinRect1.Top) _
, AreaWidth * DpiRate, AreaHeight * DpiRate, vbSrcCopy
Else
BitBlt MyHdc, 0, 0, AreaWidth, AreaHeight, ParentDc, ClientXY2.x - WinRect1.Left, ClientXY2.y - WinRect1.Top, vbSrcCopy '原来
End If
ReleaseDC ParentHwnd, ParentDc
ShowWindow MyHwnd, 5
End Sub
Private Sub CopyParentBackground(ByVal MyHwnd As Long, ByVal MyHdc As Long, ByVal ParentHwnd As Long)
'Debug.Print "ParentHwnd=" & ParentHwnd
If ParentHwnd = 0 Then ParentHwnd = GetParent(MyHwnd)
Dim AreaWidth As Long, AreaHeight As Long, WinRect1 As RECT, ClientWh2 As RECT
Dim ClientXY2 As POINTAPI, ClientXY1 As POINTAPI, ClientWh1 As RECT
GetWindowRect ParentHwnd, WinRect1
'获取【Form】的客户区坐标系(Right=宽度,Bottom=高度),重要,ABCD
GetClientRect ParentHwnd, ClientWh1
GetClientRect MyHwnd, ClientWh2
'将客户区坐标系中的点p(0,0)转换为屏幕坐标(左上角位置),重要,ABCD
ClientToScreen ParentHwnd, ClientXY1
ClientToScreen MyHwnd, ClientXY2
AreaWidth = ClientWh2.Right
AreaHeight = ClientWh2.Bottom
Dim BitMap As Long, oldBitMap As Long, hDC As Long, memDC As Long
hDC = GetDC(0)
BitMap = CreateCompatibleBitmap(hDC, WinRect1.Right - WinRect1.Left, WinRect1.Bottom - WinRect1.Top)
Call ReleaseDC(0, hDC)
memDC = CreateCompatibleDC(0)
oldBitMap = SelectObject(memDC, BitMap)
Call SendMessage(ParentHwnd, WM_ERASEBKGND, memDC, 0)
Call SendMessage(ParentHwnd, WM_PAINT, memDC, 0)
Call BitBlt(MyHdc, 0, 0, AreaWidth, AreaHeight, memDC, ClientXY2.x - ClientXY1.x, ClientXY2.y - ClientXY1.y, SRCCOPY)
UserControl.CurrentY = 10
UserControl.Print "Drag control Usercontrol With Backimg"
'透明用户控件"
'UserControl.Refresh
'
Call SelectObject(memDC, oldBitMap)
Call DeleteDC(memDC)
Call DeleteObject(BitMap)
End Sub
Last edited by xiaoyao; May 4th, 2021 at 07:51 AM.
If this were only true.
He posted links to this thread in other codebank submissions too.
Like the CommonControls and vbFlexGrid thread, no respect to others at all
I think that you can tell that xiaoyiao is an intelligent, extremely dedicated, highly focussed person who perseveres despite all obstacles - whose mind operates ONLY in this fashion, indicating perhaps a type of person and mindset.
It explains the way he works here on this forum and so perhaps we need to give him some leeway for being annoying. He is also contributing. It might take some extra work from the moderators to contain his exertions but perhaps we should cut him some slack, me included.
In the past, I used toolbar, listview, and textbox to make them transparent. It took 3 full weeks. The result was a layered method (WS_EX_LAYERED), which was invalid for systems below WIN8. Moreover, it is truly transparent, and the mouse has penetrated, which is not a good thing. So the next best thing is to use pseudo-transparency.
In fact, these two kinds of transparency effects are indispensable, each has its own purpose. This is much more useful than SPLIT, a small function that reads files quickly.
The running speed of the EXE developed by VB6 is basically the same as that of VC++, but the main disadvantage is that the UI is too old. RC6.DLL UIWidget, cairo, etc., are too difficult to use.
So you still have to look for buttons made with PHOTOSHOP or download transparent PNG button images directly from the Internet, in one step.
The imagelist supporting toolbar implements the color transparency method, with low definition and rough edges.
Because there are not many people who can develop VB6 controls, some people have developed most of the controls in VB6 and the mainstream VB6 Enterprise Edition controls. This is very powerful. To be honest, if I want to add the code for the transparency effect myself, I can't do it at all. Because it's like a car, it's not easy to add autonomous driving functions.
When you develop controls in the future, it is recommended to take the initiative to add transparent functions, or provide an interface, let me set usercontrol.backpicture=? I can set the background image to go up.
I mainly use BitBlt to draw pictures now, you will definitely not open the HDC interface for me to draw casually. There is also an estimation method, which is to add a PICTUREBOX control at the bottom of your custom control, and then expose the HDC interface. The PICTUREBOX size and control automatically match the width and height.
================
I previously published a universal Wantong transparent function, which only has a few lines of code and only requires 2 parameters: Hwnd, HDC
What is released today is a transparent template for common controls.
I suggest that the controls you develop in the future actively support transparent PNG images, the control itself can also be transparent, or expose an hdc interface to allow us to draw.
Everyone is welcome to propose a transparent module with less code and more convenient, and everyone can participate in technical competitions.
Last edited by xiaoyao; May 4th, 2021 at 07:31 AM.
WS_EX_LAYERED style form or control, you can place PNG images with transparent channels.
If you place a WS_EX_LAYERED style png image on the form, this is truly transparent. If our custom control is stacked on top of it, it will not be possible to capture the WS_EX_LAYERED style image, so the full-screen capture technology is adopted. Since the program developed by VB6 is DPI magnified by default, it is necessary to use StretchBlt magnification mode to draw, but I can’t try it with BitBlt.
Here you can also enable or disable the transparent background image effect, and then set the background color
ctl1.EnableBackImg = True
ctl1.EnableBackImg =False 'So Can used backColor
Dim EnableBackImgval As Boolean
Public Property Get EnableBackImg() As Boolean
EnableBackImg = EnableBackImgval
End Property
Public Property Let EnableBackImg(ByVal vNewValue As Boolean)
EnableBackImgval = vNewValue
RefreshBackImg
End Property
Sub RefreshBackImg()
If EnableBackImgval Then
CopyBKImage BgimgMode, BackImgOnlyPicture
Else
UserControl.Cls
UserControl.Refresh
End If
End Sub
Last edited by xiaoyao; May 4th, 2021 at 07:08 AM.
I have a script plugin for photoshop that allows you to make GUI designs using layers then export the result to XML and creating separate images. It could be modified to create a VB form format file if you wanted to do so.
I have a script plugin for photoshop that allows you to make GUI designs using layers then export the result to XML and creating separate images. It could be modified to create a VB form format file if you wanted to do so.
If multiple layers (each with different transparency) are made on top of PHOTOSHOP, it is like developing a game, with many monsters, flames and other effects. It can be moved left and right, zoomed out and zoomed out, and the definition remains the same. This is a good solution. 2D plane games or some common interface UI innovations can use this method.
For example, realize the interface style of MAC computer, the interface style of Apple IOS system, QT style
The flat button has such a good three-dimensional effect.
Just like RC6.DLL, it is a pity that it is not open source, nor is it developed with VB6.
If there are many commonly used functions that can be a source code database, that would be great.
For example, how can I detect whether my program is running in DPI zoom mode, and how many times it is zoomed in? Or is it banned from zooming? About this function, I searched the code online for 1 hour. Online search requires the correct keywords, and it takes a lot of time to find it.
If there is a code function library, I search DPI and there are more than 10, just select one and it will be done. It only takes 10 seconds. Is there such a fully functional code website?
One of the biggest works I have done before is that the customers themselves first designed the software interface with Photoshop, and then I added the controls in the same position, and at the same time, I had to make sure that the styles of the controls were the same, so the built-in button controls in VB6 were too ugly. I can’t use it at all.
You can only take out the button in the UI diagram and make it into a transparent PNG. The color is gray when pressed to simulate the effect of the button. This is the PNG control.
xiaoyiao, I like what you are doing here. It could be useful.
As far as I am concerned, my idea is that in the future, everyone will release controls, all with transparent functions and attributes. If it's not too difficult, you can do it directly with my module or add some functions to the control.
If the control has many functions and is more complicated, this must be the original developer who has the ability to extend the transparent property.
I hope that transparent controls, multi-threaded windows, flat styles, source code libraries and other things can become the ability and wealth that everyone has (code bank, is this counted as money?)
how can I detect whether my program is running in DPI zoom mode, and how many times it is zoomed in?
Code:
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) 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 Function GetTrueTwipsPerPixel() As Single
Dim h As Long
Const LOGPIXELSX As Long = 88
h = GetDC(0)
If h <> 0 Then
GetTrueTwipsPerPixel = 1440 / GetDeviceCaps(h, LOGPIXELSX)
ReleaseDC 0, h
Else
GetTrueTwipsPerPixel = Screen.TwipsPerPixelX
End If
End Function
Private Sub Form_Load()
MsgBox "Running at " & 100 / GetTrueTwipsPerPixel * 15 & "%"
End Sub
You will need the program manifested for DPI aware.
Every time you change the screen DPI setting, you need to close and restart the IDE.
Last edited by Eduardo-; May 4th, 2021 at 08:32 AM.
Private Declare Function GetDpiForWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Sub Form_Load()
MsgBox 100 * GetDpiForWindow(Me.hWnd) / 96 & "%"
End Sub
This one requires Windows 10, and will work without restarting the IDE (or the program), as long as you have them manifested for DPI aware per monitor V2.