Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0720: Gedrehte Ellipsen mit GDI+ zeichnen

VB 5/6-Tipp 0720: Gedrehte Ellipsen mit GDI+ zeichnen

 von Philipp Stephani

Schwierigkeitsgrad:

Verwendete API-Aufrufe: GdipCreateFromHDC, GdipCreateMatrix, GdipCreatePen1, GdipDeleteGraphics, GdipDeleteMatrix, GdipDeletePen, GdipDrawEllipse, GdipGraphicsClear, GdipRotateMatrix, GdipSetWorldTransform, GdipTranslateMatrix, GdiplusShutdown, GdiplusStartup

Download: Download des Beispielprojektes [3,3 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'--- Anfang Projektdatei prjGedrehteEllipseMitGDIPlus.vbp ---
'--- Anfang Formular "frmGedrehteEllipseMitGDIPlus" alias frmGedrehteEllipseMitGDIPlus.frm  ---
Option Explicit

' Global:
Private Declare Function GdiplusStartup Lib "gdiplus.dll" ( _
                         ByRef token As Long, _
                         ByRef inputX As GdiplusStartupInput, _
                         ByVal Output As Long) As Status
                         
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" ( _
                    ByVal token As Long)
                    
' Graphics:
Private Declare Function GdipCreateFromHDC Lib "gdiplus.dll" ( _
                         ByVal hdc As Long, _
                         ByRef graphics As Long) As Status
                         
Private Declare Function GdipDeleteGraphics Lib "gdiplus.dll" ( _
                         ByVal graphics As Long) As Status
                         
Private Declare Function GdipGraphicsClear Lib "gdiplus.dll" ( _
                         ByVal graphics As Long, _
                         ByVal color As Long) As Status
                         
Private Declare Function GdipSetWorldTransform Lib "gdiplus.dll" ( _
                         ByVal graphics As Long, _
                         ByVal Matrix As Long) As Status
                         
Private Declare Function GdipDrawEllipse Lib "gdiplus.dll" ( _
                         ByVal graphics As Long, _
                         ByVal Pen As Long, _
                         ByVal X As Single, _
                         ByVal Y As Single, _
                         ByVal Width As Single, _
                         ByVal Height As Single) As Status
                         
' Pens:
Private Declare Function GdipCreatePen1 Lib "gdiplus.dll" ( _
                         ByVal color As Long, _
                         ByVal Width As Single, _
                         ByVal Unit As Unit, _
                         ByRef Pen As Long) As Status
                         
Private Declare Function GdipDeletePen Lib "gdiplus.dll" ( _
                         ByVal Pen As Long) As Status
                         
' Matrices:
Private Declare Function GdipCreateMatrix Lib "gdiplus.dll" ( _
                         ByRef Matrix As Long) As Status
                         
Private Declare Function GdipDeleteMatrix Lib "gdiplus.dll" ( _
                         ByVal Matrix As Long) As Status
                         
Private Declare Function GdipTranslateMatrix Lib "gdiplus.dll" ( _
                         ByVal Matrix As Long, _
                         ByVal offsetX As Single, _
                         ByVal offsetY As Single, _
                         ByVal order As MatrixOrder) As Status
                         
Private Declare Function GdipRotateMatrix Lib "gdiplus.dll" ( _
                         ByVal Matrix As Long, _
                         ByVal angle As Single, _
                         ByVal order As MatrixOrder) As Status
                         
Private Enum Status
    Ok = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
    ProfileNotFound = 21
End Enum

Private Enum Unit
    UnitWorld = 0
    UnitDisplay = 1
    UnitPixel = 2
    UnitPoint = 3
    UnitInch = 4
    UnitDocument = 5
    UnitMillimeter = 6
End Enum

Private Enum MatrixOrder
    MatrixOrderPrepend = 0
    MatrixOrderAppend = 1
End Enum

Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Type PointF
    X As Single
    Y As Single
End Type

Private Type SizeF
    Width As Single
    Height As Single
End Type

Private Type RectF
    X As Single
    Y As Single
    Width As Single
    Height As Single
End Type

' Mathematical constants:
Private Const mPi As Double = 3.14159265358979
Private Const mDegree As Double = 180 / mPi

' ARGB colors:
Private Const mBlue As Long = &HFF0000FF
Private Const mGreen As Long = &HCC00FF00
Private Const mRed As Long = &H99FF0000
Private mInstance As Long
Private mGraphics As Long

Private Sub EllipseAxes(ByVal Pen As Long, ByRef Center As PointF, ByVal a _
    As Single, ByVal b As Single, Optional ByVal Rotation As Single = 0)
    
    Dim Matrix As Long
    
    GdipCreateMatrix Matrix
    GdipTranslateMatrix Matrix, Center.X, Center.Y, MatrixOrderPrepend
    GdipRotateMatrix Matrix, Rotation, MatrixOrderPrepend
    GdipSetWorldTransform mGraphics, Matrix
    GdipDrawEllipse mGraphics, Pen, -a, -b, 2 * a, 2 * b
    GdipDeleteMatrix Matrix
    
End Sub

Private Sub EllipseRect(ByVal Pen As Long, ByRef Rectangle As RectF, _
    Optional ByVal Rotation As Single = 0)
    
    Dim HalfSize As SizeF
    Dim Center As PointF
    
    HalfSize.Width = Rectangle.Width / 2
    HalfSize.Height = Rectangle.Height / 2
    Center.X = Rectangle.X + HalfSize.Width
    Center.Y = Rectangle.Y + HalfSize.Height
    EllipseAxes Pen, Center, HalfSize.Width, HalfSize.Height, Rotation
End Sub

Private Sub EllipseFocuses(ByVal Pen As Long, ByRef F1 As PointF, ByRef F2 _
    As PointF, ByVal a As Single)
    
    Dim Distance As PointF
    Dim e As Single
    Dim b As Single
    Dim Center As PointF
    Dim Rotation As Single
    
    With Distance
    
        .X = F2.X - F1.X
        .Y = F2.Y - F1.Y
        e = Sqr((.X * .X) + (.Y * .Y)) / 2
        
    End With
    
    If e > a Then Exit Sub
    
    b = Sqr((a * a) - (e * e))
    Center.X = F1.X + (Distance.X / 2)
    Center.Y = F1.Y + (Distance.Y / 2)
    
    If e Then Rotation = ArcSin(Distance.Y / (2 * e)) * mDegree
    
    EllipseAxes Pen, Center, a, b, Rotation
End Sub

Private Function ArcSin(ByVal X As Single) As Single
    Select Case X
    Case 1
        ArcSin = mPi / 2
    Case -1
        ArcSin = (3 * mPi) / 2
    Case Else
        ArcSin = Atn(X / Sqr(1 - (X * X)))
    End Select
End Function

Private Sub Form_Load()
    Dim Data As GdiplusStartupInput
    
    Data.GdiplusVersion = 1
    
    If GdiplusStartup(mInstance, Data, 0) Then
        MsgBox "GDI+ could not be initialized", vbCritical
        Exit Sub
    End If
End Sub

Private Sub Form_Paint()
    Dim Pen As Long
    Dim Rectangle As RectF
    Dim Center As PointF
    Dim F1 As PointF
    Dim F2 As PointF
    
    GdipCreatePen1 mBlue, 5, UnitPixel, Pen
    Center.X = 200
    Center.Y = 300
    EllipseAxes Pen, Center, 200, 160, -40
    GdipDeletePen Pen
    GdipCreatePen1 mGreen, 10, UnitPixel, Pen
    Rectangle.X = 100
    Rectangle.Y = 100
    Rectangle.Width = 400
    Rectangle.Height = 250
    EllipseRect Pen, Rectangle, 80
    GdipDeletePen Pen
    GdipCreatePen1 mRed, 15, UnitPixel, Pen
    F1.X = 100
    F1.Y = 20
    F2.X = 300
    F2.Y = 300
    EllipseFocuses Pen, F1, F2, 180
    GdipDeletePen Pen
End Sub

Private Sub Form_Resize()
    If GdipCreateFromHDC(Me.hdc, mGraphics) Then
        MsgBox "Graphics object could not be created", vbCritical
        Exit Sub
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If mGraphics Then
        If GdipDeleteGraphics(mGraphics) Then MsgBox "Graphics object " & _
            "could not be deleted", vbCritical
            
    End If
    
    GdiplusShutdown mInstance
End Sub


'--- Ende Formular "frmGedrehteEllipseMitGDIPlus" alias frmGedrehteEllipseMitGDIPlus.frm  ---
'---- Ende Projektdatei prjGedrehteEllipseMitGDIPlus.vbp ----