Special-Draw transparent picture - vb6

got a PictureBox (called i_MC) and i draw a simple image (m_ImgMCN) on it doing:
Call i_MC.PaintPicture(m_ImgMCN, 0, 0, i_MC.width, i_MC.height)
now i would like to put a transparent image on this picture, on a specific position. i found a sample code, which does the job quite well with one problem: parts of the image that shouldn't be overdrawn with the 2nd (transparent) image are overdrawn with plain black.
the algo works perfectly if the background image from above is drawn by setting the Picture-property. cannot do this because this does not allow any stretching.
the transparent image is a simple image smaller than the box containing a color that is masked. i've used the following sample code (.AutoRedraw=true for all boxes and .ScaleMode=3 'Pixel):
Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As _
Long, ByVal XDest As Long, ByVal YDest As Long, ByVal _
nWidth As Long, ByVal nHeight As Long, ByVal hDCSrc _
As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal _
dwRop As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth _
As Long, ByVal nHeight As Long, ByVal nPlanes As Long, _
ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As _
Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As _
Long, ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal _
hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) _
As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc _
As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) _
As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject _
As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Dim R As RECT
Private Sub TranspPic(OutDstDC&, DstDC&, SrcDC&, SrcRect _
As RECT, ByVal DstX&, ByVal DstY&, _
TransColor&)
Dim Result&, W&, H&
Dim MonoMaskDC&, hMonoMask&, MonoInvDC&, hMonoInv&
Dim ResultDstDC&, hResultDst&, ResultSrcDC&, hResultSrc&
Dim hPrevMask&, hPrevInv&, hPrevSrc&, hPrevDst&
W = SrcRect.Right - SrcRect.Left
H = SrcRect.Bottom - SrcRect.Top
'Generieren einer Monochromen & einer inversen Maske
MonoMaskDC = CreateCompatibleDC(DstDC)
MonoInvDC = CreateCompatibleDC(DstDC)
hMonoMask = CreateBitmap(W, H, 1, 1, ByVal 0&)
hMonoInv = CreateBitmap(W, H, 1, 1, ByVal 0&)
hPrevMask = SelectObject(MonoMaskDC, hMonoMask)
hPrevInv = SelectObject(MonoInvDC, hMonoInv)
'Puffer erstellen
ResultDstDC = CreateCompatibleDC(DstDC)
ResultSrcDC = CreateCompatibleDC(DstDC)
hResultDst = CreateCompatibleBitmap(DstDC, W, H)
hResultSrc = CreateCompatibleBitmap(DstDC, W, H)
hPrevDst = SelectObject(ResultDstDC, hResultDst)
hPrevSrc = SelectObject(ResultSrcDC, hResultSrc)
'Sourcebild in die monochrome Maske kopieren
Dim OldBC As Long
OldBC = SetBkColor(SrcDC, TransColor)
Result = BitBlt(MonoMaskDC, 0, 0, W, H, SrcDC, _
SrcRect.Left, SrcRect.Top, vbSrcCopy)
TransColor = SetBkColor(SrcDC, OldBC)
'Inverse Maske erstellen
Result = BitBlt(MonoInvDC, 0, 0, W, H, _
MonoMaskDC, 0, 0, vbNotSrcCopy)
'Hintergrund des Zielbildes auslesen
Result = BitBlt(ResultDstDC, 0, 0, W, H, _
DstDC, DstX, DstY, vbSrcCopy)
'AND mit der Maske
Result = BitBlt(ResultDstDC, 0, 0, W, H, _
MonoMaskDC, 0, 0, vbSrcAnd)
'Überlappung des Sourcebildes mit dem Zielbild auslesen
Result = BitBlt(ResultSrcDC, 0, 0, W, H, SrcDC, _
SrcRect.Left, SrcRect.Top, vbSrcCopy)
'AND mit der invertierten, monochromen Maske
Result = BitBlt(ResultSrcDC, 0, 0, W, H, _
MonoInvDC, 0, 0, vbSrcAnd)
'XOR mit beiden
Result = BitBlt(ResultDstDC, 0, 0, W, H, _
ResultSrcDC, 0, 0, vbSrcInvert)
'Ergebnis in das Zielbild kopieren
Result = BitBlt(OutDstDC, DstX, DstY, W, H, _
ResultDstDC, 0, 0, vbSrcCopy)
'Erstellte Objekte & DCs wieder freigeben
hMonoMask = SelectObject(MonoMaskDC, hPrevMask)
DeleteObject hMonoMask
DeleteDC MonoMaskDC
hMonoInv = SelectObject(MonoInvDC, hPrevInv)
DeleteObject hMonoInv
DeleteDC MonoInvDC
hResultDst = SelectObject(ResultDstDC, hPrevDst)
DeleteObject hResultDst
DeleteDC ResultDstDC
hResultSrc = SelectObject(ResultSrcDC, hPrevSrc)
DeleteObject hResultSrc
DeleteDC ResultSrcDC
End Sub
Private Sub MovePicTo(ByVal X&, ByVal Y&)
i_MC.Cls
picSrc.Picture = m_ImgMCN
With R
.Left = 0
.Top = 0
.Right = Picture2.ScaleWidth
.Bottom = Picture2.ScaleHeight
End With
Call TranspPic(i_MC.hdc, i_MC.hdc, picSrc.hdc, R, X, Y, vbWhite)
i_MC.Refresh
DoEvents
End Sub
this code originally resides on activevb.de, i modified it a little bit without changing the algorithm or functionality. i may post a link to an original article.
without success, I've tried to modify the sizes for the different intermediate pictures, but it keeps painting the image wrong:
the part of the image where the transparent picture is drawn is correct, the background is included. the rest of the picture (which shouldn't be touched by the algo) is overwritten with black.
any idea is appreciated. an algorithm to paint 24-bit alphablended images would be fine as well! I've googled quite long and didn't find a working piece of code.
PS: this is plain old VB6, moving to .NET or any other language is unfortunately not an option.
thanks in advance and best regards

damn. a friend of mine gave me the tip using the TransparentBlt (MSDN)-Function from WinAPI. works now quite well. thanks to those who took a look at it.

Related

VB6 pixel based object control Collision Detection

Currently, I'm trying to make a simple platformer in VB6 and I'm drawing objects onto the WinForm using BitBlt. I can program rectangular, circular, and line collisions but I want to have pixel-based collision detection.
I assume this can be done with Windows GDI APIs, like MaskBlt, StretchBlt, BitBlt, PltBlt... etc, but I can't get my head around how this would work out.
This is my current VB code for the form:
I currently have 2 PictureBox controls (one for player sprite, one for mask) and one timer control, and another PictureBox which is an obstacle.
Option Explicit
Dim Keys(255) As Boolean
Dim Player As PlayerPos
Private Type PlayerPos
x As Integer
y As Integer
End Type
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 Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Keys(KeyCode) = True
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
Keys(KeyCode) = False
End Sub
Private Sub timTick_Timer()
Cls
' Draw collision obj
BitBlt Me.hDC, 100, 100, pic3.Width \ 15, pic3.Height \ 15, pic3.hDC, 0, 0, vbSrcAnd
BitBlt Me.hDC, 100, 100, pic3.Width \ 15, pic3.Height \ 15, pic3.hDC, 0, 0, vbSrcPaint
' End Draw
With Player
Dim Result(0 To 2) As Integer
If Keys(vbKeyUp) Then .y = .y - 5
If Keys(vbKeyDown) Then .y = .y + 5
If Keys(vbKeyRight) Then .x = .x + 5
If Keys(vbKeyLeft) Then .x = .x - 5
' Draw player
Result(0) = BitBlt(Me.hDC, .x, .y, pic1.Width \ 15, pic1.Height \ 15, pic1.hDC, 0, 0, vbSrcAnd)
Result(1) = BitBlt(Me.hDC, .x, .y, pic1.Width \ 15, pic1.Height \ 15, pic1Mask.hDC, 0, 0, vbSrcPaint)
Result(2) = BitBlt(Me.hDC, .x, .y, pic1.Width \ 15, pic1.Height \ 15, pic1.hDC, 0, 0, vbSrcAnd)
' End Draw
lblTest.Caption = Result(0) & Result(1) & Result(2)
End With
Me.Refresh
End Sub
Thanks in advance!

How to set the mouse cursor to a specified location on a label?

so i have developed this game in visual basic 6.0,a maze game in which i want my mouse cursor to be set on the start label on the form with maze and once the form is activated and gets focus!
Dim label1 As New label=Start
I've done similar tasks in the past using the Windows API. In the following example, a Form contains a Label named 'Label1' that is positioned somewhere on the Form. When the Form is Activated, the cursor will be centered on 'Label1':
Option Explicit
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub Form_Activate()
Dim wr As RECT
Dim tb As Long
Dim le As Long
Dim x As Long
Dim y As Long
'calculate coordinates
Call GetWindowRect(Me.hwnd, wr) 'window coordinates
tb = (Me.Height - Me.ScaleHeight) - (Me.Width - Me.ScaleWidth) / 2 'title bar height
le = (Me.Width - Me.ScaleWidth) * 0.5 'left edge of client area
'calculate center of label
x = wr.Left + ScaleX(le + Label1.Left + Label1.Width * 0.5, Me.ScaleMode, vbPixels)
y = wr.Top + ScaleY(tb + Label1.Top + Label1.Height * 0.5, Me.ScaleMode, vbPixels)
SetCursorPos x, y
End Sub

Visual basic- How do I make a bot that automatically clicks a button if it is there?

I need it to refresh the page, until it sees a new button, then automatically clicks it if
if the image is static you can create an image comparision tool.
first of all you will need the code from this page:
Private Sub btnGo_Click(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles btnGo.Click
Me.Cursor = Cursors.WaitCursor
Application.DoEvents()
' Load the images.
Dim bm1 As Bitmap = Image.FromFile(txtFile1.Text)
Dim bm2 As Bitmap = Image.FromFile(txtFile2.Text)
' Make a difference image.
Dim wid As Integer = Math.Min(bm1.Width, bm2.Width)
Dim hgt As Integer = Math.Min(bm1.Height, bm2.Height)
Dim bm3 As New Bitmap(wid, hgt)
' Create the difference image.
Dim are_identical As Boolean = True
Dim r1, g1, b1, r2, g2, b2, r3, g3, b3 As Integer
Dim eq_color As Color = Color.White
Dim ne_color As Color = Color.Red
For x As Integer = 0 To wid - 1
For y As Integer = 0 To hgt - 1
If bm1.GetPixel(x, y).Equals(bm2.GetPixel(x, _
y)) Then
bm3.SetPixel(x, y, eq_color)
Else
bm3.SetPixel(x, y, ne_color)
are_identical = False
End If
Next y
Next x
' Display the result.
picResult.Image = bm3
Me.Cursor = Cursors.Default
If (bm1.Width <> bm2.Width) OrElse (bm1.Height <> _
bm2.Height) Then are_identical = False
If are_identical Then
MessageBox.Show("The images are identical")
Else
MessageBox.Show("The images are different")
End If
bm1.Dispose()
bm2.Dispose()
End Sub
this code allows you to compare the image, so you can make a screenshot of the button and store it as the main image you want to compare to, then you will need to make a screenschot of your computer screen and extract the pixels where the button should be.
Here is a tutorial on how to get a screenshot from your computer screen.
After this you can use the system mouse functions to emulate a click withthe code from this page:
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
Private Sub SingleClick()
SetCursorPos 100, 100 'x and y position
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
Private Sub DoubleClick()
'Simulate a double click as a quick series of two clicks
SetCursorPos 100, 100 'x and y position
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
Private Sub RightClick()
'Simulate a right click
SetCursorPos 200, 200 'x and y position
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

how to clear dialog picture control type=frame

I have a dialog picture control of type = frame that I've used as a parent for something else.
When the child window is destroyed, the remnants are left in the control. What can I do to either clear the control or cause the demise of the child window to clear the control?
winapi c++
I thought there might be a simpler method but the following does the trick and allows you to color it however you like.
int s;
HDC dc;
RECT R;
z = GetDlgItem (hDlg, IDC_PS_AREA); // clear the containing control
dc = GetWindowDC (z);
s = GetClientRect (z,&R);
FillRect (dc, &R, (HBRUSH) GetStockObject (LTGRAY_BRUSH));
ReleaseDC (z, dc);
And even better
int s;
HDC dc;
RECT R;
HBRUSH hB;
z = GetDlgItem (hDlg, IDC_PS_AREA); // clear the parent containing control
dc = GetWindowDC (z);
s = GetClientRect (z,&R);
hB = GetSysColorBrush (COLOR_3DFACE);
FillRect (dc, &R, hB);
ReleaseDC (z, dc);

How to draw original diameter in form?

How i can to Draw Original diameter in form, with Pset method?
i want to draw a line like this : see image
thanks.
Open a new vb project (Standard Executable) and copy/paste this code.
Option Explicit
Private Sub Form_Load()
Me.AutoRedraw = True
Me.ScaleMode = vbPixels
End Sub
Private Sub DrawLine()
Dim i As Single
Dim Angle As Single
Cls
If Me.ScaleHeight = 0 Then
Exit Sub
End If
If Me.WindowState = vbMinimized Then
Exit Sub
End If
Angle = Atn(Me.ScaleWidth / Me.ScaleHeight)
For i = 0 To Sqr(Me.ScaleWidth * Me.ScaleWidth + Me.ScaleHeight * Me.ScaleHeight)
PSet (i * Sin(Angle), i * Cos(Angle))
Next
End Sub
Private Sub Form_Resize()
Call DrawLine
End Sub
Private Sub circleRoutine(aX As Single, aY As Single, Radius As Single, Steps As Single)
Dim currAngleX As Single
Dim i As Integer
aX = aX - Radius * 1 / Steps
For currAngleX = 0 To Rad(360) Step Steps
aX = aX + Radius * Sin(currAngleX)
aY = aY + Radius * Cos(currAngleX)
Me.PSet (aX, aY)
Next currAngleX
End Sub
Private Sub DrawCircle(ByVal X As Single, ByVal Y As Single, ByVal Diameter As Single, ByVal PointsToDraw As Long)
Dim Angle As Single
For Angle = 0 To 2 * 3.14159 Step (2 * 3.14159) / PointsToDraw
Me.PSet (X + Diameter * Sin(Angle) / 2, Y + Diameter * Cos(Angle) / 2), vbRed
Next
End Sub
You should be aware that there is a Circle function that you can use instead. The code above could be replaced with:
Me.Circle (X,Y), Diameter / 2, vbRed
PSet is a relatively slow way to draw graphics, especially when there is already a built-in function you can use instead.

Resources