Hallo HarryLobster,
sieh' dir mal das an:
http://www.activevb.de/tipps/vb6tipps/tipp0740.html
http://www.activevb.de/cgi-bin/upload/download.pl?id=3348
https://www.vb-paradise.de/index.php/Thread/100377-Halbtransparente-Objekte-mit-Polygon-Funktion-aus-gdi32-dll/?postID=855539#post855539
Probier' mal dies:
Controls: 1 * Button, 1 * Picturebox
' © 2018 by Zardoz
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal _
hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As _
Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc 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 FillRect Lib "user32" (ByVal hdc As Long, lpRect As _
RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As _
Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) _
As Long
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdcDest As Long, _
ByVal XDest As Long, ByVal YDest As Long, ByVal WidthDest As Long, _
ByVal HeightDest As Long, ByVal hDCSrc As Long, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long, _
ByVal Blendfunc As Long) As Long
Private Sub Form_Load()
Dim W&, H&, Dat1$, TmpPic As StdPicture
Dat1 = "D:\EinBild.Jpeg" ' Bildpfad hier einsetzen
Set TmpPic = LoadPicture(Dat1)
Me.ScaleMode = vbPixels
Command1.Move 4, 4
Command1.Caption = "Zeichne"
With Picture1
.BorderStyle = vbBSNone
.ScaleMode = vbPixels
W = Int(0.5 + .ScaleX(TmpPic.Width, vbHimetric))
H = Int(0.5 + .ScaleX(TmpPic.Width, vbHimetric))
.Move 4, 8 + Command1.Height, W, H
.AutoRedraw = True
.PaintPicture TmpPic, 0, 0
End With
Set TmpPic = LoadPicture()
End Sub
Private Sub Command1_Click()
Dim XPos&, YPos&, Breite&, Hoehe&
XPos = 100
YPos = 50
Breite = 150
Hoehe = 70
Call ZeichneRechteck(Picture1, XPos, YPos, Breite, Hoehe, vbYellow)
XPos = 120
YPos = 200
Breite = 80
Hoehe = 112
Call ZeichneRechteck(Picture1, XPos, YPos, Breite, Hoehe, vbRed, 200)
Picture1.Refresh
End Sub
Private Sub ZeichneRechteck(Ziel As PictureBox, XPos As Long, YPos As Long, _
Breite As Long, Hoehe As Long, Farbe As Long, Optional Alpha As Long = 128)
Dim Desthdc&, P1hdc&, P1OldHandle&, Brush1&, R1 As RECT
Call SetRect(R1, XPos, YPos, XPos + Breite, YPos + Hoehe)
Brush1 = CreateSolidBrush(Farbe)
Desthdc = Ziel.hdc
P1hdc = CreateCompatibleDC(0)
P1OldHandle = SelectObject(P1hdc, CreateCompatibleBitmap(Desthdc, Breite, _
Hoehe))
Call BitBlt(P1hdc, 0, 0, Breite, Hoehe, Desthdc, XPos, YPos, vbSrcCopy)
Call FillRect(Desthdc, R1, Brush1)
Call AlphaBlend(Desthdc, XPos, YPos, Breite, Hoehe, _
P1hdc, 0, 0, Breite, Hoehe, Alpha * &H10000)
Call DeleteObject(SelectObject(P1hdc, P1OldHandle))
Call DeleteDC(P1hdc)
Call DeleteObject(Brush1)
End Sub Gruss,
Zardoz |