Rubrik: Grafik und Font · Grafische Effekte | VB-Versionen: VB6 | 30.07.08 |
Kreisring zeichnen Für das Zeichnen eines Kreisrings gibt es in VB keinen Befehl. Hier ein paar Beispiele, wie dies im Code zu realisieren ist. | ||
Autor: Zardoz | Bewertung: | Views: 14.364 |
ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Für das Zeichnen eines Kreisrings gibt es in VB keinen Befehl. Ist der Hintergrund einfarbig, kann man sich damit behelfen, dass man erst einen großen Kreis zeichnet und darüber einen kleinen Kreis in der Farbe des Hintergrundes:
Private Sub Form_Load() With Me .ScaleMode = vbPixels .AutoRedraw = True .BackColor = vbBlue .FillStyle = vbFSSolid .FillColor = vbYellow Me.Circle (.ScaleWidth / 2, .ScaleHeight / 2), .ScaleHeight * 0.45, vbBlack .FillColor = .BackColor Me.Circle (.ScaleWidth / 2, .ScaleHeight / 2), .ScaleHeight * 0.25, vbBlack End With End Sub
Ist der Hintergrund ein Bild, funktioniert das nicht mehr. Hier gibt es die Alternative, den Kreisring aus mehreren Einzelkreisen zusammenzusetzen:
Private Sub Form_Activate() Dim i As Long Call ErzeugeHintergrund With Me .DrawWidth = 2 For i = .ScaleHeight * 0.25 To .ScaleHeight * 0.45 - 1 Me.Circle (.ScaleWidth / 2, .ScaleHeight / 2), i, RGB(128, 0, 0) Next i .DrawWidth = 1 End With End Sub Private Sub ErzeugeHintergrund() Dim i As Long Dim j As Long Dim TmpPic As StdPicture Dim Kanal As Long Dim SW As Long Dim SH As Long With Me .ScaleMode = vbPixels SW = .ScaleWidth SH = .ScaleHeight .AutoRedraw = True For i = 0 To SW - 1 Me.Line (i, 0)-(i, SH), RGB(i / (SW - 1) * 255, 0, 0) Next i Set TmpPic = .Image .Cls For i = 0 To SH - 1 Kanal = i / (SH - 1) * 255 Me.Line (0, i)-(SW, i), RGB(0, Kanal, 255 - Kanal) Next i .PaintPicture TmpPic, 0, 0, , , , , , , vbSrcPaint End With Set TmpPic = LoadPicture() End Sub
Die Methode hat allerdings den Nachteil, dass sie langsam ist und dass man kein Füllmuster angeben kann. Unter Verwendung von PaintPicture kann man auch ein Füllmuster angeben:
Private Sub Form_Activate() Dim XM As Single Dim YM As Single Dim TmpPic As StdPicture DoEvents Call ErzeugeHintergrund With Me Set TmpPic = .Image .Cls .PaintPicture TmpPic, 0, 0 XM = .ScaleWidth / 2 YM = .ScaleHeight / 2 .FillStyle = vbFSSolid .FillColor = vbRed Me.Circle (XM, YM), .ScaleHeight * 0.45, vbBlack .FillStyle = vbDiagonalCross .FillColor = vbYellow Me.Circle (XM, YM), .ScaleHeight * 0.45, vbBlack .PaintPicture TmpPic, 0, 0, , , , , , , vbSrcInvert .FillStyle = vbFSSolid .FillColor = vbBlack Me.Circle (XM, YM), .ScaleHeight * 0.2, vbBlack .PaintPicture TmpPic, 0, 0, , , , , , , vbSrcInvert .FillStyle = vbFSTransparent Me.Circle (XM, YM), .ScaleHeight * 0.2, vbBlack End With Set TmpPic = LoadPicture() End Sub
Aber auch diese Methode ist langsam. Eine schnelle Methode, die auch unter allen Bedingungen funktioniert, erreicht man unter Verwendung von Regions:
Option Explicit ' benötigte API-Deklarationen Private Declare Function CombineRgn Lib "gdi32" ( _ ByVal hDestRgn As Long, _ ByVal hSrcRgn1 As Long, _ ByVal hSrcRgn2 As Long, _ ByVal nCombineMode As Long) As Long Private Declare Function CreateEllipticRgn Lib "gdi32" ( _ ByVal X1 As Long, _ ByVal Y1 As Long, _ ByVal X2 As Long, _ ByVal Y2 As Long) As Long Private Declare Function DeleteObject Lib "gdi32" ( _ ByVal hObject As Long) As Long Private Declare Function PaintRgn Lib "gdi32" ( _ ByVal hdc As Long, _ ByVal hRgn As Long) As Long ' Konstanten Private Const RGN_DIFF As Long = 4
Private Sub Form_Activate() Dim Rgn1 As Long Dim Rgn2 As Long Dim Rad1 As Long Dim XM As Long Dim YM As Long Call ErzeugeHintergrund With Me XM = .ScaleWidth / 2 ' X-Position Kreismittelpunkt YM = .ScaleHeight / 2 ' Y-Position Kreismittelpunkt Rad1 = .ScaleHeight * 0.4 ' Äußerer Radius ' 1. Region erzeugen Rgn1 = CreateEllipticRgn(XM - Rad1, YM - Rad1, XM + Rad1, YM + Rad1) Rad1 = .ScaleHeight * 0.2 ' Innerer Radius ' 2. Region erzeugen Rgn2 = CreateEllipticRgn(XM - Rad1, YM - Rad1, XM + Rad1, YM + Rad1) ' Differenz bilden (großer Kreis - kleiner Kreis) Call CombineRgn(Rgn1, Rgn1, Rgn2, RGN_DIFF) .FillStyle = vbFSSolid ' Füllmodus ausgefüllt .FillColor = RGB(255, 128, 64) ' Füllfarbe Call PaintRgn(.hdc, Rgn1) ' Kreisring ausgefüllt zeichnen .FillStyle = vbDiagonalCross ' Füllmodus Diagonalkreuz .FillColor = vbYellow ' Füllfarbe Call PaintRgn(.hdc, Rgn1) ' Kreisring mit Muster zeichnen .FillStyle = vbFSTransparent ' Füllmodus transparent ' Neuzeichnen erzwingen .Refresh End With ' Speicher aufräumen, Regions löschen Call DeleteObject(Rgn1) Call DeleteObject(Rgn2) End Sub
Private Sub ErzeugeHintergrund() ' Hintergrundbild zeichnen Dim i As Long Dim j As Long Dim Kanal As Long Dim SW As Long Dim SH As Long Dim TmpPic As StdPicture With Me .ScaleMode = vbPixels SW = .ScaleWidth SH = .ScaleHeight .AutoRedraw = True For i = 0 To SW - 1 Me.Line (i, 0)-(i, SH), RGB(i / (SW - 1) * 255, 0, 0) Next i Set TmpPic = .Image .Cls For i = 0 To SH - 1 Kanal = i / (SH - 1) * 255 Me.Line (0, i)-(SW, i), RGB(0, Kanal, 255 - Kanal) Next i .PaintPicture TmpPic, 0, 0, , , , , , , vbSrcPaint End With Set TmpPic = LoadPicture() End Sub