vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
sevAniGif - als kostenlose Vollversion auf unserer vb@rchiv CD Vol.5  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2018
 
zurück
Rubrik: Grafik und Font · Grafische Effekte   |   VB-Versionen: VB630.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:   ZardozBewertung:     [ Jetzt bewerten ]Views:  10.991 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 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

Dieser Tipp wurde bereits 10.991 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!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.
 
   

Druckansicht Druckansicht Copyright ©2000-2018 vb@rchiv Dieter Otter
Alle 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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel