objdraw.ctl

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

Dim LeftSel As Single
Dim TopSel As Single

Dim DownX As Single
Dim DownY As Single
Dim MouseSel As Boolean

Dim mClipBoard() As myObject
Dim ClipQty As Long

Dim UndoBuffer() As String
Dim mUndoSize As Integer
Dim UndoStack As Integer
Dim UndoPointer As Integer
Dim isUndo As Boolean

Dim mDefaultText As String
Dim mCanvasWidth As Long
Dim mCanvasHeight As Long
Dim mShowCanvasSize As Boolean
Dim mZF As Single
Dim toZoom As Boolean
Dim GroupQty As Integer

Dim Drag As Boolean

Private Const Pi = 3.14159265358979

Public Event Click()
Public Event DblClick()
Public Event KeyDown(KeyAscii As Integer, Shift As Integer)
Public Event KeyPress(KeyCode As Integer)
Public Event KeyUp(KeyAscii As Integer, Shift As Integer)
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event NewDrawingEnd()

Public Event UndoRedo(LastUndo As Boolean, LastRedo As Boolean)
Public Event Prompt2Save()

Public Event ObjSelected(ObjType As myObType, Index As Long, ObjLeft As Single, ObjTop As Single, _
ObjWidth As Single, ObjHeight As Single, ObjAngle As Single, ObjFillColor As Long, ObjFillStyle As myFill, _
ObjBorderColor As Long, ObjBorderWidth As Integer, ObjAspect As Single, ObjFontName As String, _
ObjFontSize As Single, ObjFontBold As Boolean, ObjFontItalic As Boolean, ObjFontUnderline As Boolean, _
ObjFontStrikethru As Boolean, ObjText As String, ObjTextAlign As AlignmentConstants, ObjPointQty As Integer)

Public Event ObjectResize(ObjType As myObType, Index As Long, ObjLeft As Single, ObjTop As Single, _
ObjWidth As Single, ObjHeight As Single, ObjAspect As Single)

Private Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateFont Lib "gdi32.dll" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long

Private Const LOGPIXELSY = 90                    'For GetDeviceCaps - returns the height of a logical pixel
Private Const ANSI_CHARSET = 0                   'Use the default Character set
Private Const CLIP_LH_ANGLES = 16                ' Needed for tilted fonts.
Private Const OUT_TT_PRECIS = 9                  'Tell it to use True Types when Possible
Private Const PROOF_QUALITY = 9                  'Make it as clean as possible.
Private Const DEFAULT_PITCH = 0                  'We want the font to take whatever pitch it defaults to
Private Const FF_DONTCARE = 0                    'Use whatever fontface it is.


Private Enum FontWeight
    FW_DONTCARE = 0
    FW_THIN = 100
    FW_EXTRALIGHT = 200
    FW_ULTRALIGHT = 200
    FW_LIGHT = 300
    FW_NORMAL = 400
    FW_REGULAR = 400
    FW_MEDIUM = 500
    FW_SEMIBOLD = 600
    FW_DEMIBOLD = 600
    FW_BOLD = 700
    FW_EXTRABOLD = 800
    FW_ULTRABOLD = 800
    FW_HEAVY = 900
    FW_BLACK = 900
End Enum

Private Declare Function PolyBezier Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function StrokeAndFillPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Private Declare Function RoundRect Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Declare Function PlgBlt Lib "gdi32" (ByVal hdcDest As Long, lpPoint As POINTAPI, ByVal hdcSrc As Long, _
ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hbmMask As Long, _
ByVal xMask As Long, ByVal yMask As Long) As Long

Private Function EllipsePts(cLeft As Single, cTop As Single, cWidth As Single, cHeight As Single, cAngle As Single) As POINTAPI()
    Dim offsetX As Single
    Dim offsetY As Single
    Dim R As Single
    Dim Alfa As Single
    Dim PX(12) As Single
    Dim PY(12) As Single
    Dim Point(12) As POINTAPI
    Dim n As Integer
    Dim CenterX As Single
    Dim CenterY As Single
    Dim eFactor As Double
    
    eFactor = 2 / 3 * (Sqr(2) - 1)

    offsetX = cWidth * eFactor
    offsetY = cHeight * eFactor
    CenterX = cWidth / 2
    CenterY = cHeight / 2
    
    PX(0) = cWidth
    PX(1) = PX(0)
    PX(11) = PX(0)
    PX(12) = PX(0)
    
    PX(5) = 0
    PX(6) = PX(5)
    PX(7) = PX(5)
    
    PX(2) = CenterX + offsetX
    PX(10) = PX(2)
    
    PX(4) = CenterX - offsetX
    PX(8) = PX(4)

    PX(3) = CenterX
    PX(9) = PX(3)
    
    PY(2) = 0
    PY(3) = PY(2)
    PY(4) = PY(2)
    
    PY(8) = cHeight
    PY(9) = PY(8)
    PY(10) = PY(8)
    
    PY(7) = CenterY + offsetY
    PY(11) = PY(7)
    
    PY(1) = CenterY - offsetY
    PY(5) = PY(1)
    
    PY(0) = CenterY
    PY(12) = PY(0)
    PY(6) = PY(0)

    For n = 0 To 12
        R = Sqr(PX(n) ^ 2 + PY(n) ^ 2)
        Alfa = Atn2(PY(n), PX(n)) - (cAngle * Pi / 180)
        Point(n).X = cLeft + R * Cos(Alfa)
        Point(n).Y = cTop + R * Sin(Alfa)
    Next n

    EllipsePts = Point
End Function

Private Function Atn2(ByVal Y As Single, ByVal X As Single) As Single
    If X = 0 Then
        Atn2 = IIf(Y = 0, Pi / 4, Sgn(Y) * Pi / 2)
    Else
        Atn2 = Atn(Y / X) + (1 - Sgn(X)) * Pi / 2
    End If
End Function

Public Sub AddObject(tObjectType As myObType, Optional tTop As Single = -1, Optional tLeft As Single = -1, _
    Optional tHeight As Single = -1, Optional tWidth As Single = -1, Optional tAngle As Single, Optional tFillColor As Long = -1, _
    Optional tFillStyle As myFill = mSolid, Optional tBorderColor As Long = -1, Optional tBorderWidth As Integer = 0, Optional tPicture As StdPicture, _
    Optional tFontName As String = "", Optional tFontSize As Single = 8, Optional tFontBold As Boolean = False, _
    Optional tFontItalic As Boolean = False, Optional tFontUnderline As Boolean = False, _
    Optional tFontStrikethru As Boolean = False, Optional tText As String = "", Optional tTextAlign As AlignmentConstants = vbLeftJustify, Optional tPointQty As Integer = 3, _
    Optional tPosX0 As Single = -1, Optional tPosY0 As Single = -1, Optional tPosX1 As Single = -1, _
    Optional tPosY1 As Single = -1, Optional tPosX2 As Single = -1, Optional tPosY2 As Single = -1, _
    Optional tPosX3 As Single = -1, Optional tPosY3 As Single = -1, Optional tGroupMember As Integer = 0, Optional tAspect As Single)

    NextLine = False
    NewObj = False
    
    Add2Selection -1
    
    If tObjectType = mText Then
        If tText = "" Then tText = mDefaultText
        If tFontName = "" Then tFontName = myFont
    Else
        tText = ""
        tFontName = ""
        tFontSize = 0
        tFontBold = False
        tFontItalic = False
        tFontUnderline = False
        tFontStrikethru = False
    End If
    
    ObjQty = ObjQty + 1
    ReDim Preserve ObjList(ObjQty)
    ObjIndex = ObjQty - 1
    
    Add2Selection ObjIndex
    
    With ObjList(ObjIndex)
        .mObjectType = tObjectType
        .mTop = tTop
        .mLeft = tLeft
        .mHeight = tHeight
        .mWidth = tWidth
        .mAngle = tAngle
            If .mObjectType = mArc Then .mAngle = 0
        .mFillColor = tFillColor
        .mFillStyle = tFillStyle
        .mBorderColor = tBorderColor
        .mBorderWidth = tBorderWidth
        .mFontName = tFontName
        .mFontSize = tFontSize
        .mFontBold = tFontBold
        .mFontItalic = tFontItalic
        .mFontUnderline = tFontUnderline
        .mFontStrikethru = tFontStrikethru
        .mText = tText
        .mTextAlign = tTextAlign
        .mPointQty = tPointQty
        .mPosX0 = tPosX0
        .mPosY0 = tPosY0
        .mPosX1 = tPosX1
        .mPosY1 = tPosY1
        .mPosX2 = tPosX2
        .mPosY2 = tPosY2
        .mPosX3 = tPosX3
        .mPosY3 = tPosY3
        .mGroupMember = tGroupMember
        .mAspect = tAspect
        Set .mPicture = tPicture
    End With
    
    If tTop = -1 And tLeft = -1 Then ' if no position mouse position will be used
        Select Case tObjectType
            Case mline
            DrawControl.MousePointer = 99
            Set DrawControl.MouseIcon = cLine.Picture
            Case mArc
            DrawControl.MousePointer = 99
            Set DrawControl.MouseIcon = cArc.Picture
            Case mRectangle
            DrawControl.MousePointer = 99
            Set DrawControl.MouseIcon = cRect.Picture
            Case mRoundRectangle
            DrawControl.MousePointer = 99
            Set DrawControl.MouseIcon = cRoundRect.Picture
            Case mEllipse
            DrawControl.MousePointer = 99
            Set DrawControl.MouseIcon = cEllipse.Picture
            Case mText
            DrawControl.MousePointer = 99
            Set DrawControl.MouseIcon = cText.Picture
            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
            ObjList(ObjIndex).mWidth = DrawControl.TextWidth(tText) + DrawControl.TextWidth("XX")
            ObjList(ObjIndex).mHeight = DrawControl.TextHeight(tText)
            NewText = True
            Case mImage
            DrawControl.MousePointer = 99
            Set DrawControl.MouseIcon = cPicture.Picture
            Case mPolygon
            DrawControl.MousePointer = 99
            Set DrawControl.MouseIcon = cPolygon.Picture
            Case mStar
            DrawControl.MousePointer = 99
            Set DrawControl.MouseIcon = cStar.Picture
        End Select
        NewObj = True
    Else
        DrawControl.MousePointer = 0
        Select Case tObjectType
            Case mText
            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
                If tWidth = -1 Or tHeight = -1 Then
                ObjList(ObjIndex).mWidth = DrawControl.TextWidth(tText) + DrawControl.TextWidth("XX")
                ObjList(ObjIndex).mHeight = DrawControl.TextHeight(tText)
                End If
            Case mImage
            If ObjList(ObjIndex).mWidth = -1 Then
            ObjList(ObjIndex).mWidth = DrawControl.ScaleX(ObjList(ObjIndex).mPicture.Width)
            End If
            If ObjList(ObjIndex).mHeight = -1 Then
            ObjList(ObjIndex).mHeight = DrawControl.ScaleY(ObjList(ObjIndex).mPicture.Height)
            End If
        End Select
        RaiseEvent NewDrawingEnd
        ReDraw
    End If
End Sub

Public Property Get CurrentObject() As Long
    CurrentObject = ObjIndex
End Property

Public Property Get ObjectInClipboard() As Boolean
    ObjectInClipboard = CBool(ClipQty)
End Property

Public Property Get Image() As StdPicture
    Set Image = DrawControl.Image
End Property
Public Property Get ObjectType() As myObType
    On Error Resume Next
    ObjectType = ObjList(ObjIndex).mObjectType
End Property
Public Property Get ObjectQty() As Long
    ObjectQty = ObjQty
End Property

Public Property Get SelectionQty() As Long
    SelectionQty = QtySel
End Property
Private Sub Corner_Click()
    HScroll1.Value = (HScroll1.Max - HScroll1.Min) \ 2
    VScroll1.Value = (VScroll1.Max - VScroll1.Min) \ 2
End Sub

Private Sub DrawControl_DragDrop(Source As Control, X As Single, Y As Single)
    DragBezier Source.Index, X, Y
    Add2UndoBuffer
End Sub

Private Sub DrawControl_DragOver(Source As Control, X As Single, Y As Single, State As Integer)