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

Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.

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.