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.