6 small apps from my in progress program folder. In various stages of completion , but generally working.
↧
MySimpleProjects
↧
VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)
How to use API to set text to transparent and accept cursor in vb
'BAS FILE: APIs to install our subclassing routines
Code:
'在窗体Form代码中，把以下代码复制进去:
'IN FORM1
Private Sub Form_Load()
makeTransparentTextbox Text1 'Text1
'是需要透明的文本框
End Sub'BAS FILE: APIs to install our subclassing routines
Code:
Private Const GWL_WNDPROC = (-4)
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 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 DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' These APIs are used to create a pattern brush for each textbox...
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 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 CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSysColor Lib "user32" (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
' Messages which we will be processing in our subclassing routines
Private Const WM_COMMAND As Long = &H111
Private Const WM_CTLCOLOREDIT As Long = &H133
Private Const WM_DESTROY As Long = &H2
Private Const WM_ERASEBKGND As Long = &H14
Private Const WM_HSCROLL As Long = &H114
Private Const WM_VSCROLL As Long = &H115
' A rectangle.
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' APIs used to keep track of brush handles and process addresses
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
' APIs used in our subclassing routine to create the "transparent" effect.
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function WindowFromDC Lib "user32" (ByVal hdc As Long) As Long
Public Function makeTransparentTextbox(aTxt As TextBox)
' Make sure we don't have any typos in our subclassing procedures.
NewWindowProc 0, 0, 0, 0
NewTxtBoxProc 0, 0, 0, 0
' Create a background brush for this textbox, which we will used to give
' the textbox an APPEARANCE of transparency
CreateBGBrush aTxt
' Subclass the textbox's form, IF NOT ALREADY subclassed
If GetProp(GetParent(aTxt.hwnd), "OrigProcAddr") = 0 Then
SetProp GetParent(aTxt.hwnd), "OrigProcAddr", SetWindowLong(GetParent(aTxt.hwnd), GWL_WNDPROC, AddressOf NewWindowProc)
End If
' Subclass the textbox, IF NOT ALREADY subclassed
If GetProp(aTxt.hwnd, "OrigProcAddr") = 0 Then
SetProp aTxt.hwnd, "OrigProcAddr", SetWindowLong(aTxt.hwnd, GWL_WNDPROC, AddressOf NewTxtBoxProc)
End If
End Function
Private Sub CreateBGBrush(aTxtBox As TextBox)
Dim screenDC As Long ' The screen's device context.
Dim imgLeft As Long ' The X location inside the image which we are going to copy from.
Dim imgTop As Long ' The Y location inside the image which we are going to copy from.
Dim picDC As Long ' A temporary DC to pull the form's picture into
Dim picBmp As Long ' the 1x1 bitmap which is created with picDC
Dim aTempBmp As Long ' A temporary bitmap we'll use to create the pattern brush for our textbox
Dim aTempDC As Long ' the temporary device context used to hold aTempBmp
Dim txtWid As Long ' The form's width
Dim txtHgt As Long ' the form's height.
Dim solidBrush As Long ' Solid brush used to color in the bitmap... incase the textbox
' gets sized outside the dimensions of the picture
Dim aRect As RECT ' Rectangle to fill in with solid brush
If aTxtBox.Parent.Picture Is Nothing Then Exit Sub
' Get our form's dimensions, in pixels
txtWid = aTxtBox.Width / Screen.TwipsPerPixelX
txtHgt = aTxtBox.Height / Screen.TwipsPerPixelY
' Get the location within the bitmap picture we're copying from
imgLeft = aTxtBox.Left / Screen.TwipsPerPixelX
imgTop = aTxtBox.Top / Screen.TwipsPerPixelY
' Get the screen's device context
screenDC = GetDC(0)
' Create a device context to hold the form's picture.
picDC = CreateCompatibleDC(screenDC)
picBmp = SelectObject(picDC, aTxtBox.Parent.Picture.Handle)
' Create a temporary bitmap to blt the underlying image onto
aTempDC = CreateCompatibleDC(screenDC)
aTempBmp = CreateCompatibleBitmap(screenDC, txtWid, txtHgt)
DeleteObject SelectObject(aTempDC, aTempBmp)
' create a brush the color of BUTTON_FACE
solidBrush = CreateSolidBrush(GetSysColor(15))
aRect.Right = txtWid
aRect.Bottom = txtHgt
' Fill in the area
FillRect aTempDC, aRect, solidBrush
' clean up our resource
DeleteObject solidBrush
' Transfer the image
BitBlt aTempDC, 0, 0, txtWid, txtHgt, picDC, imgLeft, imgTop, vbSrcCopy
' Check to make sure that a brush hasn't already been made for this one
If GetProp(aTxtBox.hwnd, "CustomBGBrush") <> 0 Then
' If so, then delete it and free its memory before storing the new one's handle.
DeleteObject GetProp(aTxtBox.hwnd, "CustomBGBrush")
End If
' Create a pattern brush from our bitmap and store its handle against
' the textbox's handle
SetProp aTxtBox.hwnd, "CustomBGBrush", CreatePatternBrush(aTempBmp)
' Clean up our temporary DC and bitmap resources
DeleteDC aTempDC
DeleteObject aTempBmp
' Replace the original 1x1 bitmap, releasing the form's picture
SelectObject picDC, picBmp
' Clean up our picture DC and the 1x1 bitmap that was created with it
DeleteDC picDC
DeleteObject picBmp
' Release the screen's DC back to the system... forgetting to do this
' causes a nasty memory leak.
ReleaseDC 0, screenDC
End Sub
Private Function NewWindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' ******************************************************
' SUBCLASSING ROUTINE FOR THE TEXTBOX'S >>>>PARENT<<<<
' ******************************************************
Dim origProc As Long ' The original process address for the window.
Dim isSubclassed As Long ' Whether a certain textbox is subclassed or not.
' I've gotten in the habit of passing 0 values to the subclassing functions before
' actually installing them, just to make sure that I don't have any typos or other
' problems which can be easily detected. As such, if there is a hwnd of 0, its not
' a "valid" message, so we'll just exit right away.
If hwnd = 0 Then Exit Function
' Get the original process address which we stored earlier.
origProc = GetProp(hwnd, "OrigProcAddr")
If origProc <> 0 Then
If (uMsg = WM_CTLCOLOREDIT) Then
' Check to see if our window has a stored value for the original
' process address. If so, we're subclassing this one.
isSubclassed = (GetProp(WindowFromDC(wParam), "OrigProcAddr") <> 0)
If isSubclassed Then
' Invoke the default process... This will set the font, font color
' and other stuff we don't really want to fool with.
CallWindowProc origProc, hwnd, uMsg, wParam, lParam
' Make the words print transparently
SetBkMode wParam, 1
' Return the handle to our custom brush rather than that which
' the default process would have returned.
NewWindowProc = GetProp(WindowFromDC(wParam), "CustomBGBrush")
Else
' The textbox in question isn't subclassed, so we aren't going
' to do anything out of the ordinary. Just invoke the default proc.
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
ElseIf uMsg = WM_COMMAND Then
' Check to see if our window has a stored value for the original
' process address. If so, we're subclassing this one.
isSubclassed = (GetProp(lParam, "OrigProcAddr") <> 0)
If isSubclassed Then
' We are going lock the window from updating while we invalidate
' and redraw it. This prevents flickering.
LockWindowUpdate GetParent(lParam)
' Force windows to redraw the window.
InvalidateRect lParam, 0&, 1&
UpdateWindow lParam
End If
' Invoke the default process
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
If isSubclassed Then LockWindowUpdate 0&
ElseIf uMsg = WM_DESTROY Then
' The window is being destroyed... time to unhook our process so we
' don't cause a big fat error which crashes the application.
' Install the default process address again
SetWindowLong hwnd, GWL_WNDPROC, origProc
' Invoke the default process
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
' Remove our stored value since we don't need it anymore
RemoveProp hwnd, "OrigProcAddr"
Else
' We're not concerned about this particular message, so we'll just
' let it go on its merry way.
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
Else
' A catch-all in case something freaky happens with the process addresses.
NewWindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End If
End Function
Private Function NewTxtBoxProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' *********************************************
' SUBCLASSING ROUTINE FOR THE >>>>TEXTBOX<<<<
' *********************************************
Dim aRect As RECT
Dim origProc As Long
Dim aBrush As Long
If hwnd = 0 Then Exit Function
' Get the original process address which we stored earlier.
origProc = GetProp(hwnd, "OrigProcAddr")
If origProc <> 0 Then
' We're subclassing! Which is silly, 'cause otherwise we wouldn't be in
' this function, however we double check the process address just in case.
If uMsg = WM_ERASEBKGND Then
' We're going to get our custom brush for this textbox and fill the
' textbox's background area with it...
aBrush = GetProp(hwnd, "CustomBGBrush")
If aBrush <> 0 Then
' Get the area dimensions to fill
GetClientRect hwnd, aRect
' Fill it with our custom brush
FillRect wParam, aRect, aBrush
' Tell windows that we took care of the "erasing"
NewTxtBoxProc = 1
Else
' Something happened to our custom brush :-\ We'll just invoke
' the default process
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
ElseIf uMsg = WM_HSCROLL Or uMsg = WM_VSCROLL Then
' We are scrolling, either horizontally or vertically. This requires
' us to totally repaint the background area... so we'll lock the
' window updates so we don't see any of the freaky flickering
LockWindowUpdate GetParent(hwnd)
' Invoke the default process so the user actually get's the scroll
' they want
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
' Force window to repaint itself
InvalidateRect hwnd, 0&, 1&
UpdateWindow hwnd
' Release the update lock
LockWindowUpdate 0&
ElseIf uMsg = WM_DESTROY Then
' The textbox's parent is closing / destroying, so we need to
' unhook our subclassing routine ... or bad things happen
' Clean up our brush object... muy importante!!!
aBrush = GetProp(hwnd, "CustomBGBrush")
' Delete the brush object, freeing its resource.
DeleteObject aBrush
' Remove our values we stored against the textbox's handle
RemoveProp hwnd, "OrigProcAddr"
RemoveProp hwnd, "CustomBGBrush"
' Replace the original process address
SetWindowLong hwnd, GWL_WNDPROC, origProc
' Invoke the default "destroy" process
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
Else
' We're not interested in this message, so we'll just let it truck
' right on thru... invoke the default process
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
Else
' A catch-all in case something freaky happens with the process addresses.
NewTxtBoxProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End If
End Function↧
↧
Delete this post
sorry :/
↧
Access the VBIDE library without add-ins
I recently had to document the methods of a vast class module. Means I wanted the names of all public functions listed in the module itself in a special procedure to give the opportunity to call them by name (CallByName used; could also be DispCall).
I could use a VB6 documenter for this, but asked myself if there is any way to access the VB6 Extensibility Library from inside the IDE apart from using an add-in, which seems to be the only way to get the instance's VBE Application object - other than in VBA Office where you can access VBIDE at any time. Investigated all over the net but could not find any solution. So here is mine.
It's so small that I can post the only important code routine here:
Explanation:
Attached is a little project to demonstrate the usage. Hope it works in your environment.
If you want to implement this in your own project just copy the one routine and the API declarations into some module.
I could use a VB6 documenter for this, but asked myself if there is any way to access the VB6 Extensibility Library from inside the IDE apart from using an add-in, which seems to be the only way to get the instance's VBE Application object - other than in VBA Office where you can access VBIDE at any time. Investigated all over the net but could not find any solution. So here is mine.
It's so small that I can post the only important code routine here:
Code:
Private ThisVBE As VBIDE.VBE
Function GetVBIDE() As VBIDE.VBE
Dim hwndMain As Long
Dim sTitle As String
Dim ret As Long
Dim hProp As Long
Dim ObjW As Object
On Error GoTo ErrHandler
If ThisVBE Is Nothing Then
hwndMain = FindWindow("wndclass_desked_gsk", vbNullString)
If hwndMain <> 0 Then
sTitle = String(255, 0)
ret = GetWindowText(hwndMain, sTitle, 255)
If ret > 0 Then
sTitle = Left(sTitle, ret)
If InStr(1, sTitle, "Microsoft Visual Basic") > 0 Then
hProp = GetProp(hwndMain, "VBAutomation")
If hProp <> 0 Then
CopyMemory ObjW, hProp, 4& '= VBIDE.Window
Set ThisVBE = ObjW.VBE
CopyMemory ObjW, 0&, 4&
End If
End If
End If
End If
End If
Set GetVBIDE = ThisVBE
Exit Function
ErrHandler:
MsgBox Err.Description, vbCritical, "GetVBIDE()"
Resume Next
End Function- With the help of some API functions receive the window of VB's IDE (class wndclass_desked_gsk; top level window)
- Check if it's the right one ('Microsoft Visual Basic' in caption)
- All IDE windows expose a windows property (long value) called "VBAutomation". I found out this to be the object pointer of the related VBIDE.Window
- Get the pointer with GetProp
- Turn the pointer into an object (CopyMemory)
- Get the root VBE from property Window.VBE
Attached is a little project to demonstrate the usage. Hope it works in your environment.
If you want to implement this in your own project just copy the one routine and the API declarations into some module.
↧
webBrowser Control Transparent
HTML Code:
<style>
html, body {
margin: 0px;
height: 100%;
width: 100%;
overflow: hidden;
background: rgba(0, 0, 0, 0);
}
</style>↧
↧
Making Picturebox transparent,Set Alpha Channel Image
Making Picturebox transparent(support PNG alpha)
https://forums.codeguru.com/showthre...ox-transparent
My transparent approach now is to let UserControl Transparent and supports container functionality
Programming Challenge:How to make Picturebox1 control truly transparent.Remove the background color, set the transparency of the PNG channel as a background image function.
VB6 Transparent Textbox By API(WM_CTLCOLOREDIT)
https://www.vbforums.com/showthread.php?891144-VB6-Transparent-Textbox-By-API(WM_CTLCOLOREDIT)
https://www.vbforums.com/showthread....e-Transparency
https://forums.codeguru.com/showthre...ox-transparent
Quote:
Programming Challenge:How to make Picturebox1 control truly transparent.Remove the background color, set the transparency of the PNG channel as a background image function.
Code:
SetWindowLong Picturebox1.hwnd, GWL_EXSTYLE, GetWindowLong(Picturebox1.hwnd, GWL_EXSTYLE) Or WS_EX_TRANSPARENT
Set mSubclass = New clsTrickSubclass
mSubclass.Hook Me.hwndhttps://www.vbforums.com/showthread.php?891144-VB6-Transparent-Textbox-By-API(WM_CTLCOLOREDIT)
Quote:
Originally Posted by iPrank
![View Post]()
@Napoleon,
You can do so without regioning - by using a transparent usercontrol instead.
1. Create a UserControl.
2. Set it's ControlContainer = True and BackStyle = Transparent
3. FILL the usercontrol with a Rounded Rectangle shape. (For smoother effect,set the Shape's BorderStyle to Transparent.)
4. Set the shape's FillStyle to Solid.
5. Now use this user control as the container of your WebBrowser Cotrol.
PS. It is better idea to create a new thread (with link to the original one) rather than digging up an old one. :)
(Possibly CodeBank threads are only exceptions)
You can do so without regioning - by using a transparent usercontrol instead.
1. Create a UserControl.
2. Set it's ControlContainer = True and BackStyle = Transparent
3. FILL the usercontrol with a Rounded Rectangle shape. (For smoother effect,set the Shape's BorderStyle to Transparent.)
4. Set the shape's FillStyle to Solid.
5. Now use this user control as the container of your WebBrowser Cotrol.
PS. It is better idea to create a new thread (with link to the original one) rather than digging up an old one. :)
(Possibly CodeBank threads are only exceptions)
↧
vb6 Transparent Control by BitBlt,Transparent Picturebox
vb6 Transparent Control by BitBlt,Transparent Picturebox
in form1
in bas file:
in form1
Code:
TransparentWithHdc Picture1.hwnd, Picture1.HdcCode:
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'将客户区坐标系中的点转换为屏幕坐标
Public Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal Hdc As Long) As Long
Public 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
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type POINTAPI
x As Long
y As Long
End Type
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Const SW_HIDE = 0
Sub TransparentWithHdc(MyHwnd As Long, MyHdc As Long)
Dim Wnd As Long
Wnd = GetParent(MyHwnd)
ShowWindow MyHwnd, SW_HIDE
'目标图片框有边框，要计算这些数据
Dim ParentDc As Long
'MyHdc = GetWindowDC(MyHwnd) '得到dc
ParentDc = GetWindowDC(Wnd) '得到dc
Dim W As Long, H As Long, W2 As Long, H2 As Long
Dim WinRect1 As RECT, ClientWh1 As RECT, ClientXY1 As POINTAPI
Dim WinRect2 As RECT, ClientWh2 As RECT, ClientXY2 As POINTAPI
GetWindowRect Wnd, WinRect1
'获取【Form】的客户区坐标系(Right=宽度,Bottom=高度）,重要,ABCD
GetClientRect Wnd, ClientWh1
'将客户区坐标系中的点p(0,0)转换为屏幕坐标（左上角位置）,重要,ABCD
ClientToScreen Wnd, ClientXY1
GetWindowRect MyHwnd, WinRect2
'获取【Form】的客户区坐标系(Right=宽度,Bottom=高度）,重要,ABCD
GetClientRect MyHwnd, ClientWh2
'将客户区坐标系中的点p(0,0)转换为屏幕坐标（左上角位置）,重要,ABCD
ClientToScreen MyHwnd, ClientXY2
W = ClientWh1.Right
H = ClientWh1.Bottom
W2 = ClientWh2.Right
H2 = ClientWh2.Bottom
DoEvents
'重要
BringWindowToTop Wnd
BitBlt MyHdc, 0, 0, W2, H2, ParentDc, ClientXY1.x - WinRect1.Left + (ClientXY2.x - ClientXY1.x), ClientXY1.y - WinRect1.Top + (ClientXY2.y - ClientXY1.y), vbSrcCopy
ReleaseDC Wnd, ParentDc
ShowWindow MyHwnd, 5
End Sub↧
Transparent Png Control by vb6
PngBall2.AutoSize = False
Call PngBall2.LoadPng("", "GLOBE", "PNG")
PngBall1.LoadPng ("01Alpha_Png.png")
GetWindowRect disables the display zoom (right-click of the program) when the GetWindowRect is set to high DPI, the pixels are not correct, what is the reason?
How to get the check of "Disable display scaling when high DPI setting" is checked
'Check, the desktop size is 3840,2160
'Unchecked, desktop size 1920*1080
Call PngBall2.LoadPng("", "GLOBE", "PNG")
PngBall1.LoadPng ("01Alpha_Png.png")
GetWindowRect disables the display zoom (right-click of the program) when the GetWindowRect is set to high DPI, the pixels are not correct, what is the reason?
How to get the check of "Disable display scaling when high DPI setting" is checked
'Check, the desktop size is 3840,2160
'Unchecked, desktop size 1920*1080
Code:
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'将客户区坐标系中的点转换为屏幕坐标
Public Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function BringWindowToTop Lib "user32" (ByVal hwnd As Long) As Long
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type POINTAPI
x As Long
y As Long
End Type
Declare Function GetDesktopWindow Lib "user32" () As Long
Sub Main()
Dim Wnd As Long
Wnd = GetDesktopWindow
Dim WinRect1 As RECT, ClientWh1 As RECT, ClientXY1 As POINTAPI
Dim WinRect2 As RECT, ClientWh2 As RECT, ClientXY2 As POINTAPI
GetWindowRect Wnd, WinRect1
MsgBox "桌面坐标:" & WinRect1.Left & "," & WinRect1.Right & "," & WinRect1.Top & "," & WinRect1.Bottom
'获取【Form】的客户区坐标系(Right=宽度,Bottom=高度）,重要,ABCD
GetClientRect Wnd, ClientWh1
'将客户区坐标系中的点p(0,0)转换为屏幕坐标（左上角位置）,重要,ABCD
ClientToScreen Wnd, ClientXY1
End Sub↧
VB6 RC6 Cam-Streaming (with local QRCode-Decoding)
Just a little demo, which shows how to use the new cVidCap-Class of the RC6-lib (a version >= 6.0.7 is needed).
It is relatively simple to set-up (basically only a connect-MethodCall with a few init-params is needed) -
and it then throws a single event at the host-form, which transports the decoded VideoFrame as a cCairoSurface-type.
This incoming Image-Surface-Object is then already pre-processed internally,
according to the different "Flip" and "Rotate"-Property-Settings on cVidCap.
Upon request, this demo also includes a "live-decoding" of QR-Codes
(not doing any "online-calls", but using cQRDecode from RC6Widgets.dll - which in turn uses the statically linked "libQuirc" from cairo_sqlite.dll)
Here is a ScreenShot:
![]()
Some advice for using the QR-Decoding:
- the Label which shows the info, is "clickable" (then placing the decoded String on the ClipBoard)
- it has 3 "BackColor-Modes" to visualize the "live-capture-status"
- <grey> nothing was found so far
- <yellow> partial success (but ECC-checksum did not yet match)
- <green> a successful decoding took place (with a matching ECC-checksum)
Ok, here the Demo-Code:
VidCapRC6.zip
Have fun,
Olaf
It is relatively simple to set-up (basically only a connect-MethodCall with a few init-params is needed) -
and it then throws a single event at the host-form, which transports the decoded VideoFrame as a cCairoSurface-type.
This incoming Image-Surface-Object is then already pre-processed internally,
according to the different "Flip" and "Rotate"-Property-Settings on cVidCap.
Upon request, this demo also includes a "live-decoding" of QR-Codes
(not doing any "online-calls", but using cQRDecode from RC6Widgets.dll - which in turn uses the statically linked "libQuirc" from cairo_sqlite.dll)
Here is a ScreenShot:
Some advice for using the QR-Decoding:
- the Label which shows the info, is "clickable" (then placing the decoded String on the ClipBoard)
- it has 3 "BackColor-Modes" to visualize the "live-capture-status"
- <grey> nothing was found so far
- <yellow> partial success (but ECC-checksum did not yet match)
- <green> a successful decoding took place (with a matching ECC-checksum)
Ok, here the Demo-Code:
VidCapRC6.zip
Have fun,
Olaf
↧
↧
(VB6) Detect Design-time and uncompiled
Code can run at design time if you have UserControls or also you can type a procedure name in the immediate window and run that code.
This function takes advantage of an error that is raised only at run-time and uses code from this Codebank entry (thanks to the author).
It detects when the code is running at design time and uncompiled. It is intended to address issues that happen when the code runs in source code at design time, not at design time but compiled (in an OCX or DLL).
In the demonstration project that is attached it uses an UserControl for easy testing, but the code works without an UserControl and does not rely on the Ambient.UserMode property.
This function takes advantage of an error that is raised only at run-time and uses code from this Codebank entry (thanks to the author).
It detects when the code is running at design time and uncompiled. It is intended to address issues that happen when the code runs in source code at design time, not at design time but compiled (in an OCX or DLL).
In the demonstration project that is attached it uses an UserControl for easy testing, but the code works without an UserControl and does not rely on the Ambient.UserMode property.
Code:
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private mIsUncompiledAndDesignTime As Boolean
Private mIsUncompiledAndDesignTime_Set As Boolean
Public Function IsUncompiledAndDesignTime() As Boolean
If Not mIsUncompiledAndDesignTime_Set Then
Dim iInIDE As Boolean
Debug.Assert MakeTrue(iInIDE)
If iInIDE Then
SetIsUncompiledAndDesignTime
End If
mIsUncompiledAndDesignTime_Set = True
End If
IsUncompiledAndDesignTime = mIsUncompiledAndDesignTime
End Function
Private Sub SetIsUncompiledAndDesignTime()
Dim hwndMain As Long
Dim hProp As Long
Dim iObjIDE As Object
Dim iObjVBE As Object
hwndMain = FindWindow("wndclass_desked_gsk", vbNullString)
If hwndMain <> 0 Then
hProp = GetProp(hwndMain, "VBAutomation")
If hProp <> 0 Then
CopyMemory iObjIDE, hProp, 4& '= VBIDE.Window
On Error Resume Next
Set iObjVBE = iObjIDE.VBE
mIsUncompiledAndDesignTime = True
If Err.Number = 70 Then ' run time raises an access denied error
mIsUncompiledAndDesignTime = False
End If
On Error GoTo 0
CopyMemory iObjIDE, 0&, 4&
End If
End If
End Sub
Private Function MakeTrue(value As Boolean) As Boolean
MakeTrue = True
value = True
End Function↧
(VB6) Add-In to change the default font of new forms
It changes the default font from 'MS Sans Serif' to other font of new Forms, UserControls and PropertyPages that are added to the project.
You can configure the font that you want, the default one is Segoe UI 9.
![Name: def.font-config.png
Views: 49
Size: 3.7 KB]()
Download from GitHub
Note: To change the fonts of existent forms, you can use the add-in Project Examiner.
You can configure the font that you want, the default one is Segoe UI 9.
Download from GitHub
Note: To change the fonts of existent forms, you can use the add-in Project Examiner.
↧
how to transparency Button like Listbox by vb6?
Code:
Option Explicit
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetBrushOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal nXOrg As Long, ByVal nYOrg As Long, lppt As Any) As Long
Private Declare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As Long, ByVal hwndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Const TRANSPARENT As Long = 1
Private Const WM_CTLCOLORLISTBOX As Long = &H134
Private Const WM_CTLCOLORSTATIC As Long = &H138
Private Const WM_VSCROLL As Long = &H115
Dim WithEvents WndProc As clsTrickSubclass ' Объект для сабклассинга формы
Dim WithEvents lstProc As clsTrickSubclass ' Объект для сабклассинга списка
Dim hBackBrush As Long ' Фоновая кисть
Private Sub list1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 Then
Call ReleaseCapture
SendMessage List1.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
List1.Refresh
End If
End Sub
Private Sub Form_Load()
'Set a larger background image test.jpg for the form, and move the text box to see the transparency effect
Me.Picture = LoadPicture(App.Path & "\test.jpg")
' Создаем кисть для отрисовки фона на основе фонового изображения формы
hBackBrush = CreatePatternBrush(Me.Picture.Handle)
' Сабклассинг формы
Set WndProc = New clsTrickSubclass
Set lstProc = New clsTrickSubclass
WndProc.Hook Me.hwnd
lstProc.Hook List1.hwnd
' Добавляем в список тестовые значения
Do While List1.ListCount < 100
List1.AddItem Format(List1.ListCount, "ITE\M 00")
Loop
End Sub
Private Sub Form_Unload(Cancel As Integer)
' Удаляем кисть
DeleteObject hBackBrush
End Sub
' Оконная процедура списка
Private Sub lstProc_wndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
Select Case Msg
' При прокрутке списка
Case WM_VSCROLL
' Объявляем всю область списка недействительной и требующей перерисовки
InvalidateRect hwnd, ByVal 0&, 0
End Select
' Вызов по умолчанию
DefCall = True
End Sub
' Оконная процедура формы
Private Sub wndProc_WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
Select Case Msg
' При запросе кисти фона списка или слайдера
Case WM_CTLCOLORSTATIC, WM_CTLCOLORLISTBOX
Dim pts(1) As Long
' Получаем координаты элемента
MapWindowPoints lParam, Me.hwnd, pts(0), 1
' Сдвигаем точку отсчета координат кисти, чтобы она совпадала с фоновом изображением под контролом
SetBrushOrgEx wParam, -pts(0), -pts(1), ByVal 0&
' Если это список
If lParam = List1.hwnd Then
' Устанавливаем прозрачный фон для текста
SetBkMode wParam, TRANSPARENT
' Устанавливаем цвет текста
SetTextColor wParam, vbWhite
End If
' Возвращаем кисть
Ret = hBackBrush
Case Else: DefCall = True ' Остальное оставляем без изменений
End Select
End Sub↧
Simple transparent button control For VB6
Private Sub Form_Load()
Me.Picture = LoadPicture(App.Path & "\bg.jpg")
'MyButton1(0).FilePath = "bt1a.png"
'MyButton1(0).FileClick = "bt1b.png"
End Sub
Private Sub Form_Activate()
If Me.Tag = "" Then
Me.Tag = "a"
Picture1.AutoRedraw = True
'Picture1.Picture = LoadPicture(App.Path & "\bg.jpg")
TransparentWithHdc Picture1.hwnd, Picture1.hDC
MyButton1(0).CutBgImg
MyButton1(0).ShowImg
MyButton1(2).CutBgImg
MyButton1(2).ShowImg
End If
End Sub
Me.Picture = LoadPicture(App.Path & "\bg.jpg")
'MyButton1(0).FilePath = "bt1a.png"
'MyButton1(0).FileClick = "bt1b.png"
End Sub
Private Sub Form_Activate()
If Me.Tag = "" Then
Me.Tag = "a"
Picture1.AutoRedraw = True
'Picture1.Picture = LoadPicture(App.Path & "\bg.jpg")
TransparentWithHdc Picture1.hwnd, Picture1.hDC
MyButton1(0).CutBgImg
MyButton1(0).ShowImg
MyButton1(2).CutBgImg
MyButton1(2).ShowImg
End If
End Sub
↧
↧
VB6 Png Control,Simple transparent button control For VB6
Simulate the control transparency effect: the developed custom control usercontrol sets a screenshot function as the base image, bitblt draws the background image on the form (or screenshots with other controls), and then draws the button image or text on it, you can use it usercontrol.cls is cleared (the base map remains unchanged)
Private Sub Form_Load()
Me.Picture = LoadPicture(App.Path & "\bg.jpg")
'MyButton1(0).FilePath = "bt1a.png"
'MyButton1(0).FileClick = "bt1b.png"
End Sub
Private Sub Form_Activate()
If Me.Tag = "" Then
Me.Tag = "a"
Picture1.AutoRedraw = True
'Picture1.Picture = LoadPicture(App.Path & "\bg.jpg")
TransparentWithHdc Picture1.hwnd, Picture1.hDC
MyButton1(0).CutBgImg
MyButton1(0).ShowImg
MyButton1(2).CutBgImg
MyButton1(2).ShowImg
End If
End Sub
Private Sub Form_Load()
Me.Picture = LoadPicture(App.Path & "\bg.jpg")
'MyButton1(0).FilePath = "bt1a.png"
'MyButton1(0).FileClick = "bt1b.png"
End Sub
Private Sub Form_Activate()
If Me.Tag = "" Then
Me.Tag = "a"
Picture1.AutoRedraw = True
'Picture1.Picture = LoadPicture(App.Path & "\bg.jpg")
TransparentWithHdc Picture1.hwnd, Picture1.hDC
MyButton1(0).CutBgImg
MyButton1(0).ShowImg
MyButton1(2).CutBgImg
MyButton1(2).ShowImg
End If
End Sub
↧
how to use alpha png for buttons，Transparent toolbar Control by vb6
it's use ImageList1.MaskColor ,how to use alpha png for buttons ?or use api without imagelist control ?
[VB6] ListView / TreeView Extended and Custom Checkboxes-VBForums
https://www.vbforums.com/showthread....tom-Checkboxes
[VB6] ListView / TreeView Extended and Custom Checkboxes-VBForums
https://www.vbforums.com/showthread....tom-Checkboxes
Code:
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 OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByRef lColorRef As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32.dll" (ByVal hBitmap As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long
Private Const GCL_HBRBACKGROUND As Long = -10
Private Function GDI_TranslateColor(OleClr As OLE_COLOR, Optional hPal As Integer = 0) As Long
' used to return the correct color value of OleClr as a long
If OleTranslateColor(OleClr, hPal, GDI_TranslateColor) Then
GDI_TranslateColor = &HFFFF&
End If
End Function
Function GDI_CreateSoildBrush(bColor As OLE_COLOR) As Long
'Create a Brush form a picture handle
GDI_CreateSoildBrush = CreateSolidBrush(GDI_TranslateColor(bColor))
End Function
Public Sub SetToolbarBG(hwnd As Long, hBmp As Long)
'Set the toolbars background image
DeleteObject SetClassLong(hwnd, GCL_HBRBACKGROUND, CreatePatternBrush(hBmp))
InvalidateRect 0&, 0&, False
End Sub
Public Sub SetToolbarBK(hwnd As Long, hColor As OLE_COLOR)
' Set a toolbars Backcolor
DeleteObject SetClassLong(hwnd, GCL_HBRBACKGROUND, GDI_CreateSoildBrush(hColor))
InvalidateRect 0&, 0&, False
End Sub
Private Sub cmdBk_Click()
Call SetToolbarBK(Toolbar1.hwnd, vbYellow)
End Sub
Private Sub Command1_Click()
SetToolbarBG Toolbar1.hwnd, Image1.Picture
End Sub↧
(VB6 Add-In) Move selected controls
Move several controls certain left and/or top at the same time.
Not sure if other add-ins do this (probably), but one feature that the VB6 IDE lacks is the ability to move all the selected controls at the same time certain left and/or top.
![Name: MoveControls.png
Views: 25
Size: 15.0 KB]()
Download from GitHub.
Not sure if other add-ins do this (probably), but one feature that the VB6 IDE lacks is the ability to move all the selected controls at the same time certain left and/or top.
Download from GitHub.
↧
More Misc Programs
Here are 8 more misc programs from my unfinished folder. They are : Create Dummy Files , DrawOnForm with floodfill, Filename generator, Morse Code, Names List Maker, On/off usercontrol, random Strings, State abbrev.
Maybe there's something here someone can use.
Maybe there's something here someone can use.
↧
↧
(VB6) Add-In - Move selected controls
Move several controls certain left and/or top at the same time.
Not sure if other add-ins do this (probably), but one feature that the VB6 IDE lacks is the ability to move all the selected controls at the same time certain left and/or top.
![Name: MoveControls.png
Views: 41
Size: 15.0 KB]()
Sometimes it is necessary to add one or more controls to a form in the middle of other controls and you need to make room for them, so you need to shift an entire block of controls in some vertical (or horizontal, but more generally vertical) space, and the IDE does not provide the ability to move them in the exact offset.
You have to move them around with the mouse, but whether you have the IDE set to snap to the grid or not, the controls never end up in the right place. In the end, you have to set the position of each one by hand, and that's very cumbersome.
This add-in provides a solution for that problem.
Download from GitHub.
Not sure if other add-ins do this (probably), but one feature that the VB6 IDE lacks is the ability to move all the selected controls at the same time certain left and/or top.
Sometimes it is necessary to add one or more controls to a form in the middle of other controls and you need to make room for them, so you need to shift an entire block of controls in some vertical (or horizontal, but more generally vertical) space, and the IDE does not provide the ability to move them in the exact offset.
You have to move them around with the mouse, but whether you have the IDE set to snap to the grid or not, the controls never end up in the right place. In the end, you have to set the position of each one by hand, and that's very cumbersome.
This add-in provides a solution for that problem.
Download from GitHub.
↧
XML Class to read & write
Hi.
I am wondering if anyone has a drop in class that is easy to read & write nested xml files. Ive seen and got a few that read very basic xml files.
but i am not good enough to make it read & write nested tags.
ie
<config>
<Screen>
<Size>10</Size>
<somethingelse>blah blah</somethingelse>
<Screen>
<Next setting>test</Next setting>
<Anotherone>xxxxxxx</Anotherone>
</config>
tks
I am wondering if anyone has a drop in class that is easy to read & write nested xml files. Ive seen and got a few that read very basic xml files.
but i am not good enough to make it read & write nested tags.
ie
<config>
<Screen>
<Size>10</Size>
<somethingelse>blah blah</somethingelse>
<Screen>
<Next setting>test</Next setting>
<Anotherone>xxxxxxx</Anotherone>
</config>
tks
↧
Abbreviate Text
This has very little use but I enjoyed the programming. Can be used to create control labels. See what you think about it.
↧