objdraw.ctl

一款开源的完整矢量绘图控件源码,支持直线、弧线、矩形、圆角矩形、椭圆、多边形、星形、文本和图片等的绘制

    DragBezier Source.Index, X, Y
End Sub


Private Sub griff_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        griff(Index).Drag
        Drag = True
    End If
End Sub


Private Sub griff_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Drag = False
End Sub


Private Sub HScroll1_Change()
    On Error Resume Next
    DrawControl.Left = HScroll1.Value
    UserControl.Cls
    UserControl.DrawWidth = 1
    UserControl.Line (DrawControl.Left + 4, DrawControl.Top + 4)-Step(DrawControl.Width + 2, DrawControl.Height + 2), &H80000015, BF
    UserControl.Line (DrawControl.Left - 1, DrawControl.Top - 1)-Step(DrawControl.Width + 1, DrawControl.Height + 1), , B
    If mShowCanvasSize = True Then
        UserControl.CurrentX = DrawControl.Left + DrawControl.Width - UserControl.TextWidth(mCanvasWidth & " X " & mCanvasHeight) + 7
        UserControl.CurrentY = DrawControl.Top + DrawControl.Height + 7
        UserControl.Print mCanvasWidth & " X " & mCanvasHeight
    End If
    DrawControl.SetFocus
End Sub

Private Sub DrawControl_Click()
    RaiseEvent Click
End Sub

Private Sub DrawControl_DblClick()
    Dim n As Integer
    ' for edit selected text and arc
    
    If ObjIndex = -1 Then Exit Sub
    
    If ObjList(ObjIndex).mObjectType = mText Then
        NewText = True
        DrawControl.Font = ObjList(ObjIndex).mFontName
        DrawControl.FontSize = ObjList(ObjIndex).mFontSize
        DrawControl.FontBold = ObjList(ObjIndex).mFontBold
        DrawControl.FontItalic = ObjList(ObjIndex).mFontItalic
        DrawControl.FontUnderline = ObjList(ObjIndex).mFontUnderline
        DrawControl.FontStrikethru = ObjList(ObjIndex).mFontStrikethru
        myText.Left = ObjList(ObjIndex).mLeft * mZF
        myText.Top = ObjList(ObjIndex).mTop * mZF
        myText.Font = ObjList(ObjIndex).mFontName
        myText.FontSize = ObjList(ObjIndex).mFontSize * mZF
        myText.FontBold = ObjList(ObjIndex).mFontBold
        myText.FontItalic = ObjList(ObjIndex).mFontItalic
        myText.FontUnderline = ObjList(ObjIndex).mFontUnderline
        myText.FontStrikethru = ObjList(ObjIndex).mFontStrikethru
        myText.Text = ObjList(ObjIndex).mText
        myText.Width = ObjList(ObjIndex).mWidth * mZF
        myText.Height = ObjList(ObjIndex).mHeight * mZF
        myText.Visible = True
        ObjList(ObjIndex).mText = ""
        ReDraw
        myText.SelStart = 0
        myText.SelLength = Len(myText.Text)
        myText.SetFocus
    ElseIf ObjList(ObjIndex).mObjectType = mArc Then
        ReDraw False
        griff(0).Left = ObjList(ObjIndex).mPosX0 * mZF
        griff(0).Top = ObjList(ObjIndex).mPosY0 * mZF
        griff(1).Left = ObjList(ObjIndex).mPosX1 * mZF
        griff(1).Top = ObjList(ObjIndex).mPosY1 * mZF
        griff(2).Left = ObjList(ObjIndex).mPosX2 * mZF
        griff(2).Top = ObjList(ObjIndex).mPosY2 * mZF
        griff(3).Left = ObjList(ObjIndex).mPosX3 * mZF
        griff(3).Top = ObjList(ObjIndex).mPosY3 * mZF
        DrawControl.DrawStyle = vbDot
        DrawControl.DrawMode = vbInvert
        DrawControl.Line (griff(0).Left + 4, griff(0).Top)-(griff(1).Left + 4, griff(1).Top)
        DrawControl.Line (griff(2).Left + 4, griff(2).Top)-(griff(3).Left + 4, griff(3).Top)
        DrawControl.DrawStyle = vbSolid
        DrawControl.DrawMode = 13
        For n = 0 To 3
        griff(n).Visible = True
        Next n
    End If
    RaiseEvent DblClick
End Sub



Private Sub UserControl_Click()
    If NewObj = False And NewText = False And NextLine = False Then
        RaiseEvent ObjSelected(-1, -1, -1, -1, -1, -1, 0, -1, 0, -1, -1, -1, -1, -1, False, False, False, False, -1, -1, -1)
        ObjIndex = -1
        QtySel = 0
        ReDraw
    End If
End Sub

Private Sub UserControl_GotFocus()
    DrawControl.SetFocus
End Sub


Private Sub UserControl_Initialize()
    ObjIndex = -1
    myFont = "Arial"
End Sub

Private Sub UserControl_InitProperties()
    mDefaultText = "New Text"
End Sub

Private Sub DrawControl_KeyDown(KeyCode As Integer, Shift As Integer)
    'used for arrow keys
    Dim n As Long
    Select Case Shift
        Case 0
        Select Case KeyCode
            Case vbKeyAdd
            mZF = mZF + 0.1
            If mZF > 10 Then mZF = 10
            toZoom = True
            UserControl_Resize
            ReDraw
            Case vbKeySubtract
            mZF = mZF - 0.1
            If mZF < 0.1 Then mZF = 0.1
            toZoom = True
            UserControl_Resize
            ReDraw
        End Select
    
        If QtySel > 0 Then
            For n = 0 To QtySel - 1
            Select Case KeyCode
                Case vbKeyLeft
                ObjList(ListSel(n)).mLeft = ObjList(ListSel(n)).mLeft - 1 * mArrowStep * mZF
                If ObjList(ListSel(n)).mObjectType = mArc Then EditArc ListSel(n), toLeft, mArrowStep * mZF
                Case vbKeyUp
                ObjList(ListSel(n)).mTop = ObjList(ListSel(n)).mTop - 1 * mArrowStep * mZF
                If ObjList(ListSel(n)).mObjectType = mArc Then EditArc ListSel(n), toTop, mArrowStep * mZF
                Case vbKeyRight
                ObjList(ListSel(n)).mLeft = ObjList(ListSel(n)).mLeft + 1 * mArrowStep * mZF
                If ObjList(ListSel(n)).mObjectType = mArc Then EditArc ListSel(n), toRight, mArrowStep * mZF
                Case vbKeyDown
                ObjList(ListSel(n)).mTop = ObjList(ListSel(n)).mTop + 1 * mArrowStep * mZF
                If ObjList(ListSel(n)).mObjectType = mArc Then EditArc ListSel(n), toBottom, mArrowStep * mZF
            End Select
            Next n
            ReDraw
        End If
        Case 2
        Select Case KeyCode
            Case vbKeyLeft
            ObjIndex = ObjIndex - 1
            Case vbKeyUp
            ObjIndex = ObjIndex + 1
            Case vbKeyRight
            ObjIndex = ObjIndex + 1
            Case vbKeyDown
            ObjIndex = ObjIndex - 1
        End Select
        If ObjIndex <= -1 Then ObjIndex = ObjQty - 1
        If ObjIndex >= ObjQty Then ObjIndex = 0
        Add2Selection -1
        Add2Selection ObjIndex
        ReDraw
    End Select
    
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub DrawControl_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub DrawControl_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode >= 37 And KeyCode <= 40 And ObjIndex > -1 And Shift = 0 Then Add2UndoBuffer
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub DrawControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    Dim n As Long
    Dim tSelect As Boolean
    Dim tC As myCoorType
    Dim minX As Single
    Dim maxX As Single
    Dim minY As Single
    Dim maxY As Single
    
    If NextLine = True Then
        Exit Sub
    End If
    
    If NewText = True And myText.Visible = True Then
        DrawControl.MousePointer = 0
        NewText = False
        DrawControl.Font = ObjList(ObjIndex).mFontName
        DrawControl.FontSize = ObjList(ObjIndex).mFontSize * mZF
        DrawControl.FontBold = ObjList(ObjIndex).mFontBold
        DrawControl.FontItalic = ObjList(ObjIndex).mFontItalic
        DrawControl.FontUnderline = ObjList(ObjIndex).mFontUnderline
        DrawControl.FontStrikethru = ObjList(ObjIndex).mFontStrikethru
        ObjList(ObjIndex).mText = myText.Text
        ObjList(ObjIndex).mWidth = myText.Width + 10 'DrawControl.TextWidth(myText.Text)
        ObjList(ObjIndex).mHeight = myText.Height 'DrawControl.TextHeight(myText.Text)
        If Trim(Len(myText.Text)) > 0 Then
        myText.Visible = False
        Else
        NewText = False
        ObjQty = ObjQty - 1
        ReDim Preserve ObjList(ObjQty)
        ReDraw
        DrawControl_MouseDown 1, 0, -5, -5
        End If
        myText.Visible = False
        NewObj = False
        'Exit Sub
    End If
    
    If NewObj = True Then 'set new object position
        isDown = True
        ObjList(ObjIndex).mTop = Y
        ObjList(ObjIndex).mLeft = X
    Else
        onObject = False
        
        toSize = CheckSelection(X, Y) 'check which resize dot is clicked
        If toSize = -1 Then
            ObjIndex = -1
            ReDraw
        Else
            isResize = True
            Exit Sub
        End If
        
        LeftSel = 0 ' used to correct position when moving object
        TopSel = 0  '
        For n = ObjQty - 1 To 0 Step -1
            tC = GetSelPosition(ObjList(n).mLeft * mZF, ObjList(n).mTop * mZF, ObjList(n).mWidth * mZF, ObjList(n).mHeight * mZF, ObjList(n).mAngle)
            With tC
                minX = .posX1 - ObjList(n).mBorderWidth
                minY = .posY1 - ObjList(n).mBorderWidth
                maxX = .posX3 + ObjList(n).mBorderWidth
                maxY = .posY3 + ObjList(n).mBorderWidth
            End With
        
            If X > minX And X < maxX And Y > minY And Y < maxY Then
                tSelect = True
                LeftSel = X - ObjList(n).mLeft
                TopSel = Y - ObjList(n).mTop
            Else
                tSelect = False
            End If
           
            If tSelect = True Then
                onObject = True
                ObjIndex = n
                If Shift = 0 Then Add2Selection -1
                Add2Selection ObjIndex
                ShowSelection
                Exit For
            End If
        Next n
    End If
    
    DownX = X
    DownY = Y
    
    If ObjIndex = -1 And NewText = False Then
        QtySel = 0
        RaiseEvent ObjSelected(-1, -1, -1, -1, -1, -1, 0, -1, 0, -1, -1, -1, -1, -1, False, False, False, False, -1, -1, -1)
        Add2Selection -1
        ReDraw
    End If
    
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub DrawControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    Dim tAspect As Single
    Dim n As Long
    Dim Tmp As Single
    Dim tx As Single
    Dim ty As Single
    Dim tX2 As Single
    Dim tY2 As Single
    Dim tRatio As Double
    Dim tIndex As Long
    Dim tGr As Integer
    
    If isDown = True Or NextLine = True Then ' show dot line for new object
    ReDraw
    DrawControl.DrawStyle = 2
    DrawControl.DrawWidth = 1
    DrawControl.DrawMode = 7
    
    Select Case ObjList(ObjIndex).mObjectType
        Case mline
        DrawControl.Line (ObjList(ObjIndex).mLeft, ObjList(ObjIndex).mTop)-(X, Y), vbYellow
        Case mArc
        tx = X
        ty = Y
            If Shift = 2 Then
            tAspect = 1
            ty = tx - ObjList(ObjIndex).mLeft + ObjList(ObjIndex).mTop
            ObjList(ObjIndex).mHeight = ty - ObjList(ObjIndex).mTop
            End If
            DrawControl.ForeColor = vbYellow
            DrawArc ObjIndex, ObjList(ObjIndex).mLeft, ObjList(ObjIndex).mTop, _
            (tx - ObjList(ObjIndex).mLeft), (ty - ObjList(ObjIndex).mTop), _
            ObjList(ObjIndex).mPosX0 * mZF, ObjList(ObjIndex).mPosY0 * mZF, _
            ObjList(ObjIndex).mPosX1 * mZF, ObjList(ObjIndex).mPosY1 * mZF, _
            ObjList(ObjIndex).mPosX2 * mZF, ObjList(ObjIndex).mPosY2 * mZF, _
            ObjList(ObjIndex).mPosX3 * mZF, ObjList(ObjIndex).mPosY3 * mZF
    
        Case mRectangle
        tx = X
        ty = Y
            If Shift = 2 Then
            tAspect = 1
            ty = tx - ObjList(ObjIndex).mLeft + ObjList(ObjIndex).mTop
            ObjList(ObjIndex).mHeight = ty - ObjList(ObjIndex).mTop
            End If
            DrawControl.ForeColor = vbYellow
            DrawRectangle ObjList(ObjIndex).mLeft, ObjList(ObjIndex).mTop, _
            (tx - ObjList(ObjIndex).mLeft), (ty - ObjList(ObjIndex).mTop), ObjList(ObjIndex).mAngle
            
        Case mRoundRectangle
        tx = X
        ty = Y
            If Shift = 2 Then
            tAspect = 1
            ty = tx - ObjList(ObjIndex).mLeft + ObjList(ObjIndex).mTop
            ObjList(ObjIndex).mHeight = ty - ObjList(ObjIndex).mTop
            End If
            DrawControl.ForeColor = vbYellow