PC go! 2008 April/PCgo 2008-04 (DVD).iso/interface/contents/demoversionen_3846/13664/files/Data1.cab/vbnetroundrect.vb

Text File | 2004-07-15 | 24.5 KB | 629 lines

'******************************************************************'
'*                                                                *'
'*                      TurboCAD for Windows                      *'
'*                   Copyright (c) 1993 - 2004                    *'
'*             International Microcomputer Software, Inc.         *'
'*                            (IMSI)                              *'
'*                      All rights reserved.                      *'
'*                                                                *'
'******************************************************************'
Public Class VBNETRoundRect
    Const gkGraphic As Integer = 11
    Const gkArc As Integer = 2
    Const gkText As Integer = 6
    Const gfCosmetic As Integer = 128

    'Useful math constants
    Const Pi# = 3.14159265

    'Real variant types!
    Const typeEmpty As Integer = 0
    Const typeInteger As Integer = 2
    Const typeLong As Integer = 3
    Const typeSingle As Integer = 4
    Const typeDouble As Integer = 5
    Const typeCurrency As Integer = 6
    Const typeDate As Integer = 7
    Const typeString As Integer = 8
    Const typeObject As Integer = 9
    Const typeBoolean As Integer = 11
    Const typeVariant As Integer = 12
    Const typeIntegerEnum As Integer = typeInteger + 100
    Const typeLongEnum As Integer = typeLong + 100
    Const typeStringEnum As Integer = typeString + 100

    'Stock property pages
    Const ppStockPen As Integer = 1
    Const ppStockBrush As Integer = 2
    Const ppStockText As Integer = 4
    Const ppStockInsert As Integer = 8
    Const ppStockViewport As Integer = 16
    Const ppStockAuto As Integer = 32

    'Property Ids
    Const idRoundness As Integer = 1
    Const idBeginColor As Integer = 2
    Const idEndColor As Integer = 3
    Const idGradientMode As Integer = 4

    'Property enums

    'Number of properties, pages, wizards
    Const NUM_PROPERTIES As Integer = 4
    Const NUM_PAGES As Integer = 1
    Const NUM_WIZARDS As Integer = 0

    Dim m_RRectPropertyPage As frmRRect
    Dim m_MyFill As GradientFill
    Dim m_LB As Drawing.Drawing2D.LinearGradientBrush
    Dim m_rRect As New Drawing.Rectangle
    Public Function Description() As String
        Description = "SDK VB NET RoundRectangle (VB NET sample)"
    End Function

    'Returns the persistent class id for this RegenMethod's property section
    Public Function ClassID() As String
        ClassID = "{0B5266B5-9EC0-446A-8A97-EFED748B2803}"
    End Function

    'Retrieve types and names
    Public Function GetPropertyInfo(ByRef Names As Object, ByRef Types As Object, _
    ByRef IDs As Object, ByRef Defaults As Object) As Integer
        '        ReDim Names(NUM_PROPERTIES), Types(NUM_PROPERTIES), _
        '           IDs(NUM_PROPERTIES), Defaults(NUM_PROPERTIES)
        Dim strNames(NUM_PROPERTIES - 1) As String
        Dim intTypes(NUM_PROPERTIES - 1) As Integer
        Dim intIds(NUM_PROPERTIES - 1) As Integer
        Dim dblDefaults(NUM_PROPERTIES - 1) As Object
        Dim retVal As Integer

        strNames(0) = "Roundness"
        intTypes(0) = typeDouble
        intIds(0) = idRoundness
        dblDefaults(0) = 0.0#

        strNames(1) = "BeginColor"
        intTypes(1) = typeInteger
        intIds(1) = idBeginColor
        dblDefaults(1) = 0

        strNames(2) = "EndColor"
        intTypes(2) = typeInteger
        intIds(2) = idEndColor
        dblDefaults(2) = 16777215

        strNames(3) = "GradientMode"
        intTypes(3) = typeInteger
        intIds(3) = idGradientMode
        dblDefaults(3) = 0

        Names = strNames
        Types = intTypes
        IDs = intIds
        Defaults = dblDefaults

        retVal = NUM_PROPERTIES
        GetPropertyInfo = retVal
    End Function

    'Get the number of property pages supporting this RegenMethod
    Public Function GetPageInfo(ByVal AGraphic As Object, ByRef StockPages As Integer, _
    ByRef Names As Object) As Integer
        '        ReDim Names(NUM_PAGES)
        Dim strNames(NUM_PAGES) As String

        strNames(0) = m_RRectPropertyPage.Text
        StockPages = ppStockBrush + ppStockPen + ppStockAuto
        Names = strNames
        GetPageInfo = NUM_PAGES
        Exit Function

        StockPages = ppStockBrush + ppStockPen + ppStockAuto
        GetPageInfo = NUM_PAGES
    End Function

    Public Function GetWizardInfo(ByVal Names As Object) As Long
        ReDim Names(NUM_WIZARDS)
        GetWizardInfo = NUM_WIZARDS
    End Function

    'Enumerate the names and values of a specified property
    Public Function GetEnumNames(ByVal PropID As Long, ByVal Names As Object, ByVal Values As Object) As Integer
        GetEnumNames = 0
    End Function

    Public Function PageControls(ByVal ThisRegenMethod As Object, ByVal Graphic As Object, ByVal PageNumber As Integer, ByVal SaveProperties As Boolean) As Boolean
        'Set up error function
        On Error GoTo Failed
        Dim gxProp As IMSIGX.Property
        Dim Roundness#
        Dim BeginColor As Drawing.Color
        Dim EndColor As Drawing.Color
        Dim GradientMode As Drawing.Drawing2D.LinearGradientMode
        Dim mbMode As Drawing.Drawing2D.LinearGradientMode
        Dim mBeginColor As Drawing.Color
        Dim mEndColor As Drawing.Color
        Dim mGradientMode As Drawing.Drawing2D.LinearGradientMode



        If SaveProperties Then
            'OK button on property page was clicked
            'Form is still loaded
            With m_RRectPropertyPage
                'Need On Error statement for the case where you have
                'RRect Turbo Shape and ahother "shape" selected
                On Error Resume Next

                'When the property page is closed, transfer the numeric
                'roundness value from the TextBox to the Graphic
                'Get the value as a double-precision number
                Roundness# = CDbl(.tbRoundness.Text)
                mBeginColor = .cmColor1.BackColor
                mEndColor = .cmColor2.BackColor
                mGradientMode = .cModesCombo.SelectedIndex
                'Make sure it's between 0 and 100
                If Roundness# < 0.0# Then Roundness# = 0.0#
                If Roundness# > 100.0# Then Roundness# = 100.0#
                'Set the roundness property value in the Graphic
                gxProp = Graphic.Properties("Roundness")
                gxProp.Value = Roundness#
                gxProp = Graphic.Properties("BeginColor")
                gxProp.Value = Drawing.ColorTranslator.ToWin32(mBeginColor)
                gxProp = Graphic.Properties("EndColor")
                gxProp.Value = Drawing.ColorTranslator.ToWin32(mEndColor)
                gxProp = Graphic.Properties("GradientMode")
                gxProp.Value = mGradientMode
            End With
        Else
            'Property page is about to be opened
            'Make sure the form is loaded
            ''  Load(frmRRect)
            With m_RRectPropertyPage
                'If more than one RRect is selected and they do not
                'have the same properties, don't set up this field
                On Error GoTo NoRType

                'When the property page is opening, transfer the numeric
                'roundness value from the Graphic to the TextBox
                'Get the roundness property value from the Graphic
                gxProp = Graphic.Properties("Roundness")
                Roundness# = gxProp.Value
                'Set the TextBox control's text
                .tbRoundness.Text = Roundness#
                gxProp = Graphic.Properties("BeginColor")
                mBeginColor = Drawing.ColorTranslator.FromWin32(gxProp.Value)
                gxProp = Graphic.Properties("EndColor")
                mEndColor = Drawing.ColorTranslator.FromWin32(gxProp.Value)
                gxProp = Graphic.Properties("GradientMode")
                mGradientMode = gxProp.Value

                .cmColor1.BackColor = mBeginColor
                .cmColor2.BackColor = mEndColor
                .cModesCombo.SelectedIndex = mGradientMode

NoRType:
            End With
        End If

        PageControls = True
        Exit Function

Failed:
        'For debugging purposes, report that an error occurred
        If Err.Number <> 0 Then
            MsgBox("Error in PageControls: " & Err.Description)
        End If

        'Return false if an error occurred
        PageControls = False
    End Function

    Public Function PageDone(ByVal ThisRegenMethod As Object, ByVal PageNumber As Object)
        'Done with form
        ''Unload(frmRRect)
    End Function

    Public Function PropertyPages(ByVal ThisRegenMethod As Object, Optional ByVal PageNumber As Object = 0) As Boolean
        m_RRectPropertyPage.ShowDialog()
        PropertyPages = Not m_RRectPropertyPage.bCanceled
    End Function

    Public Function Wizard(ByVal ThisRegenMethod As Object, Optional ByVal WizardNumber As Object = 0) As Boolean
        Wizard = False
    End Function

    'Called when vertex has been moved, or other geometry change
    Public Function OnGeometryChanged(ByVal Graphic As Object, ByVal GeomID As Long, ByVal paramOld As Object, ByVal paramNew As Object)
        'Do nothing
        'Regen Graphic
    End Function

    'Called when vertex is moved, or other geometry change
    Public Function OnGeometryChanging(ByVal Graphic As Object, ByVal GeomID As Long, ByVal paramOld As Object, ByVal paramNew As Object) As Boolean
        'OK to continue with change
        OnGeometryChanging = True
    End Function

    Public Function OnNewGraphic(ByVal grfThis As Object, ByVal boolCopy As Boolean) As Boolean
        If boolCopy Then
            'Vertices are already added for us...
            OnNewGraphic = True
            Exit Function
        End If

        On Error GoTo Failed
        'New Graphic being created
        'X, Y, Z, PenDown, Selectable, Snappable, Editable, Linkable
        'First Vertex is "lower left" corner
        grfThis.Vertices.Add(-1.0#, -0.5, 0.0#, False, True, False, False, False)
        'Second Vertex is "upper right" corner
        grfThis.Vertices.Add(1.0#, 0.5, 0.0#, False, True, False, False, False)
        'Third Vertex is rounding handle (calculated)
        Dim R#, Roundness#, Offset#
        Dim P As IMSIGX.Property
        P = grfThis.Properties("Roundness")
        Roundness# = P.Value
        P = Nothing
        R# = 0.5 * Roundness# / 100.0#
        Offset# = 0.1 * R#
        grfThis.Vertices.Add(1.0# - R#, 0.5 + Offset#, 0.0#, False, False, False, False, False)
        'Fourth Vertex is rounding handle (editable)
        grfThis.Vertices.Add(1.0# - R#, 0.5 + Offset#, 0.0#, False, True, False, True, False)
        grfThis.Properties("LimitVertices") = 4
        OnNewGraphic = True
        Exit Function

Failed:
        'Return false on failure
        OnNewGraphic = False
    End Function

    'Function called whenever a copy of a graphic is being made
    Public Function OnCopyGraphic(ByVal grfCopy As Object, ByVal grfSource As Object) As Boolean
        'Return false on failure
        OnCopyGraphic = True
    End Function

    'Notification function called after graphic property is saved
    Public Function OnPropertyChanged(ByVal Graphic As Object, ByVal PropID As Long, _
    ByVal ValueOld As Object, ByVal ValueNew As Object)
        'Do nothing
    End Function

    'Notification function called when graphic property is saved
    Public Function OnPropertyChanging(ByVal Graphic As Object, ByVal PropID As Long, _
    ByVal ValueOld As Object, ByVal ValueNew As Object) As Boolean
        'OK to proceed
        OnPropertyChanging = True
    End Function

    'Notification function called when graphic property is retrieved
    Public Function OnPropertyGet(ByVal Graphic As Object, ByVal PropID As Long)
        'Do nothing
    End Function

    'Called when we need to update our object
    Public Function Regen(ByVal grfThis As Object)
        'Setup error handler
        On Error GoTo Failed

        'Set up lock (prevent recursion)
        Dim LockCount&
        LockCount& = grfThis.RegenLock

        'Setup error handler (make sure lock is removed)
        On Error GoTo FailedLock
        If LockCount& = 0 Then
            'Delete any previous cosmetic children
            grfThis.Graphics.Clear(gfCosmetic)

            Dim boolHandleMoved As Boolean


            'Calculate height, width and radius of corners
            Dim W#, H#, R#, Roundness#
            With grfThis.Vertices
                If (Math.Abs(.Item(2).X - .Item(3).X) < 0.000001 And _
                    Math.Abs(.Item(2).Y - .Item(3).Y) < 0.000001) Then
                    boolHandleMoved = False
                Else
                    boolHandleMoved = True
                End If
                W# = Math.Abs(.Item(1).X - .Item(0).X)
                H# = Math.Abs(.Item(1).Y - .Item(0).Y)
            End With
            'Radius of arcs is based on minimum of width and height
            If W# < H# Then
                R# = W# / 2.0#
            Else
                R# = H# / 2.0#
            End If
            'Adjust radius for roundness
            If boolHandleMoved Then
                Roundness# = Math.Abs(grfThis.Vertices(2).X - grfThis.Vertices(3).X)
                Roundness# = Roundness# * 100.0# / R#
                If Roundness# > 100.0# Then Roundness# = 100.0#
                'Relocate handle

                'Update property to reflect handle location
                Dim P As IMSIGX.Property
                P = grfThis.Properties("Roundness")
                grfThis.Properties("Roundness") = Roundness#
                P.Value = Roundness#
                P = Nothing
            Else
                Dim P As IMSIGX.Property
                P = grfThis.Properties("Roundness")
                P = grfThis.Properties("Roundness")
                Roundness# = P.Value
                P = Nothing
                If Roundness# < 0.0# Then Roundness# = 0.0#
                If Roundness# > 100.0# Then Roundness# = 100.0#
            End If
            R# = R# * Roundness# / 100.0#

            'Add child Graphics
            Dim grfChild As Object
            Dim X0#, Y0#, X1#, Y1#, T#
            With grfThis.Vertices
                X0# = .Item(0).X
                Y0# = .Item(0).Y
                X1# = .Item(1).X
                Y1# = .Item(1).Y
                'Make sure X0 < X1
                If (X0# > X1#) Then
                    T# = X0#
                    X0# = X1#
                    X1# = T#
                End If
                'Make sure Y0 < Y1
                If (Y0# > Y1#) Then
                    T# = Y0#
                    Y0# = Y1#
                    Y1# = T#
                End If
            End With
            If R# = 0.0# Then
                'No rounded corners
                'All children are cosmetic
                grfChild = grfThis.Graphics.Add(gkGraphic)
                grfChild.Cosmetic = True
                'Now add vertices to the child
                With grfChild.Vertices
                    .Add(X0#, Y0#, 0)
                    .Add(X0#, Y1#, 0, True)
                    .Add(X1#, Y1#, 0, True)
                    .Add(X1#, Y0#, 0, True)
                    'Close the rectangle
                    .AddClose(PenDown:=True) 'PenDown
                End With
            Else
                'Rounded corners
                'We'll make 4 line children and 4 arc children
                'First line
                'All children are cosmetic
                grfChild = grfThis.Graphics.Add(gkGraphic)
                grfChild.Cosmetic = True
                'Now add vertices to the child
                With grfChild.Vertices
                    .Add(X0# + R#, Y0#, 0)
                    .Add(X1# - R#, Y0#, 0, True)
                End With
                'First arc
                grfChild = grfThis.Graphics.Add(gkArc)
                grfChild.Cosmetic = True
                grfChild.ArcSet(X1# - R#, Y0# + R#, 0.0#, R#, , 1.5 * Pi#, 0.0#)
                'Second line
                grfChild = grfThis.Graphics.Add(gkGraphic)
                grfChild.Cosmetic = True
                With grfChild.Vertices
                    .Add(X1#, Y0# + R#, 0)
                    .Add(X1#, Y1# - R#, 0, True)
                End With
                'Second arc
                grfChild = grfThis.Graphics.Add(gkArc)
                grfChild.Cosmetic = True
                grfChild.ArcSet(X1# - R#, Y1# - R#, 0.0#, R#, , 0.0#, 0.5 * Pi#)
                'Third line
                grfChild = grfThis.Graphics.Add(gkGraphic)
                grfChild.Cosmetic = True
                With grfChild.Vertices
                    .Add(X1# - R#, Y1#, 0)
                    .Add(X0# + R#, Y1#, 0, True)
                End With
                'Third arc
                grfChild = grfThis.Graphics.Add(gkArc)
                grfChild.Cosmetic = True
                grfChild.ArcSet(X0# + R#, Y1# - R#, 0.0#, R#, , 0.5 * Pi#, Pi#)
                'Fourth line
                grfChild = grfThis.Graphics.Add(gkGraphic)
                grfChild.Cosmetic = True
                With grfChild.Vertices
                    .Add(X0#, Y1# - R#, 0)
                    .Add(X0#, Y0# + R#, 0, True)
                End With
                'Fourth arc
                grfChild = grfThis.Graphics.Add(gkArc)
                grfChild.Cosmetic = True
                grfChild.ArcSet(X0# + R#, Y0# + R#, 0.0#, R#, , Pi#, 1.5 * Pi#)
            End If

            'Add visible child Graphics
        End If

        grfThis.RegenUnlock()
        Exit Function

FailedLock:
        'Remove lock
        grfThis.RegenUnlock()

Failed:
        'grfThis.Application.PopVertexDefaults

        If Err.Number <> 0 Then
            '            MsgBox "Regen error: " & Err.Description
        End If
    End Function

    Public Function Draw(ByVal grfThis As Object, ByVal view As Object, Optional ByVal mat As Object = Nothing) As Boolean
        'Return True if we did the redraw (no further processing necessary, no children will be drawn).
        'Since this is just a test, we return False to let TurboCAD do the drawing operation.
        Dim gxProp As IMSIGX.Property
        Dim cBegin As Drawing.Color
        Dim cEnd As Drawing.Color
        Dim iMode As Drawing.Drawing2D.LinearGradientMode
        Draw = False
        If view.SpaceMode = IMSIGX.ImsiSpaceModeType.imsiModelSpace Then
            '           for model space it is required additional programming (process matrix etc)
            Exit Function
        End If
        gxProp = grfThis.Properties("BeginColor")
        cBegin = Drawing.ColorTranslator.FromWin32(gxProp.Value)
        gxProp = grfThis.Properties("EndColor")
        cEnd = Drawing.ColorTranslator.FromWin32(gxProp.Value)
        gxProp = grfThis.Properties("GradientMode")
        iMode = gxProp.Value

        m_MyFill.FillRoundRectWithLinearGradient(grfThis, view, cBegin, cEnd, iMode)
    End Function
    Private Class GradientFill

        Public Shared Function GetScreenCords(ByVal gxView As IMSIGX.View, ByVal V As IMSIGX.Vertex, ByRef X As Double, ByRef y As Double)
            Dim XW As Double, yW As Double, xV As Double, yV As Double
            XW = V.X
            yW = V.Y
            gxView.WorldToView(XW, yW, 0, xV, yV, 0)
            gxView.ViewToScreen(xV, yV, X, y)
        End Function
        Public Shared Function GetScreenCordsEx(ByVal gxView As IMSIGX.View, ByVal xW As Double, ByVal yW As Double, ByRef X As Double, ByRef y As Double)
            Dim xV As Double, yV As Double
            gxView.WorldToView(xW, yW, 0, xV, yV, 0)
            gxView.ViewToScreen(xV, yV, X, y)
        End Function
        Public Shared Function FillRoundRectWithLinearGradient(ByVal Gr As IMSIGX.IGraphic, ByVal gxView As IMSIGX.View, ByVal BeginColor As Drawing.Color, ByVal EndColor As Drawing.Color, ByVal GradientMode As Drawing.Drawing2D.LinearGradientMode)
            Dim gxVert As IMSIGX.Vertex
            Dim P1 As New Drawing.Point
            Dim P2 As New Drawing.Point
            Dim P3 As New Drawing.Point
            Dim Ps(7) As Drawing.Point
            Dim Grs As System.Drawing.Graphics
            Dim gxGr As IMSIGX.Graphic
            Dim gxGrTmp As IMSIGX.Graphic
            Dim hW As Long
            Dim hWP As System.IntPtr
            '            Dim n As Long

            On Error GoTo ErrH
            If Gr Is Nothing Then
                Exit Function
            End If
            If gxView Is Nothing Then
                Exit Function
            End If
            'Dim i As Integer
            'i = 0
            Dim xS As Double, yS As Double

            Dim curInd As Integer
            curInd = 0
            Dim bUseWorldCS = False
            Dim P As IMSIGX.Property
            P = Gr.Properties("Roundness")
            If P.Value > 0 Then
                For Each gxGrTmp In Gr.Graphics
                    If gxGrTmp.TypeByValue = gkGraphic Then
                        bUseWorldCS = gxGrTmp.Vertices.UseWorldCS
                        gxGrTmp.Vertices.UseWorldCS = True
                        GetScreenCords(gxView, gxGrTmp.Vertices(0), xS, yS)
                        P1.X = xS
                        P1.Y = yS
                        Ps(curInd) = P1
                        curInd = curInd + 1
                        GetScreenCords(gxView, gxGrTmp.Vertices(1), xS, yS)
                        P2.X = xS
                        P2.Y = yS
                        Ps(curInd) = P2
                        curInd = curInd + 1
                        gxGrTmp.Vertices.UseWorldCS = bUseWorldCS
                    ElseIf gxGrTmp.TypeByValue = gkArc Then
                        ' Add your code here to process arc segments

                    End If
                Next
            Else
                ' in this case we have only one cosmetic - polyline
                For Each gxGrTmp In Gr.Graphics
                    If gxGrTmp.TypeByValue = 11 Then
                        bUseWorldCS = gxGrTmp.Vertices.UseWorldCS
                        gxGrTmp.Vertices.UseWorldCS = True
                        For Each gxVert In gxGrTmp.Vertices
                            GetScreenCords(gxView, gxGrTmp.Vertices(curInd), xS, yS)
                            P1.X = xS
                            P1.Y = yS
                            Ps(curInd) = P1
                            curInd = curInd + 1
                        Next
                        gxGrTmp.Vertices.UseWorldCS = bUseWorldCS
                    End If
                Next

            End If

            hW = gxView.HWND
            Dim bDC As Boolean
            bDC = False
            If hW = 0 Then
                hW = gxView.DC
                If hW = 0 Then
                    Exit Function
                End If
                bDC = True
            End If
            hWP = New System.IntPtr(hW)

            If bDC Then
                Grs = System.Drawing.Graphics.FromHdc(hWP)
            Else
                Grs = System.Drawing.Graphics.FromHwnd(hWP)
            End If

            Grs.SmoothingMode = Drawing.Drawing2D.SmoothingMode.HighQuality
            Grs.CompositingQuality = Drawing.Drawing2D.CompositingQuality.HighQuality
            Dim Bb As IMSIGX.BoundingBox
            Bb = Gr.CalcBoundingBox()
            Dim xBMin As Double, yBMin As Double, xBMax As Double, yBMax As Double
            GetScreenCordsEx(gxView, Bb.Min.X, Bb.Min.Y, P1.X, P1.Y)
            GetScreenCordsEx(gxView, Bb.Max.X, Bb.Max.Y, P3.X, P3.Y)
            Bb = Nothing
            Dim myBBRect As New Drawing.Rectangle(P1.X, P3.Y, Math.Abs(P3.X - P1.X), Math.Abs(P3.Y - P1.Y))
            Dim pG3 As New Drawing.Drawing2D.LinearGradientBrush(myBBRect, BeginColor, EndColor, GradientMode)
            pG3.GammaCorrection = True
            Grs.FillPolygon(pG3, Ps)

            myBBRect = Nothing
            pG3.Dispose()
            Grs.Dispose()
            Exit Function
ErrH:
            '            i = 1

        End Function

    End Class

    Public Sub New()
        m_RRectPropertyPage = New frmRRect
        m_MyFill = New GradientFill
        Dim m_rRect As New Drawing.Rectangle
        Dim m_bMode As Drawing.Drawing2D.LinearGradientMode

    End Sub

    Protected Overrides Sub Finalize()

        MyBase.Finalize()
    End Sub
End Class