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 Dieser Tipp wurde bereits 14.372 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
vb@rchiv CD Vol.6 Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 Neu! sevCommand 4.0 Professionelle Schaltflächen im modernen Design! Mit nur wenigen Mausklicks statten auch Sie Ihre Anwendungen ab sofort mit grafischen Schaltflächen im modernen Look & Feel aus (WinXP, Office, Vista oder auch Windows 8), inkl. große Symbolbibliothek. |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |