frmmain.frm

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

Private Sub CboFontSize_Change()
    On Error Resume Next
    
    If doNothing = True Then Exit Sub
    If ObjDraw1.ObjectType = mText And doNothing = False And Len(Trim(CboFontSize.Text)) > 0 Then
    ObjDraw1.ModifyObject , , , , , , , , , , , CboFontSize.Text
    End If
    ObjDraw1.SetFocus
End Sub

Private Sub CboFontSize_Click()
    If ObjDraw1.ObjectType = mText And doNothing = False Then
    ObjDraw1.ModifyObject , , , , , , , , , , , CboFontSize.Text
    End If
End Sub

Private Sub ColorPal1_ColorOver(cColor As Long)
    Dim sTmp As String
    sTmp = Right("000000" & Hex(cColor), 6)
    LblColor.Caption = "十六进制码:" & sTmp & vbCrLf & " 红:" & Int("&H" & Right$(sTmp, 2)) & _
    " - 绿:" & Int("&H" & Mid$(sTmp, 3, 2)) & " - 蓝:" & Int("&H" & Left$(sTmp, 2))
    
End Sub

Private Sub ColorPal1_ColorSelected(cColor As Long)
    Dim sTmp As String
    sTmp = Right("000000" & Hex(cColor), 6)
    ScrCol(0).Value = Int("&H" & Right$(sTmp, 2))
    ScrCol(1).Value = Int("&H" & Mid$(sTmp, 3, 2))
    ScrCol(2).Value = Int("&H" & Left$(sTmp, 2))
    
    OpColor(ColorIndex).BackColor = cColor
    bFillColor = OpColor(0).BackColor
    bBorderColor = OpColor(1).BackColor
    bBackColor = OpColor(2).BackColor
    
    If doNothing = True Then Exit Sub
    
    Select Case ColorIndex
        Case 0
        If ObjDraw1.CurrentObject > -1 Then
        ObjDraw1.ModifyObject , , , , , bFillColor, CboFill.ListIndex, bBorderColor
        End If
        Case 1
        If ObjDraw1.CurrentObject > -1 Then
        ObjDraw1.ModifyObject , , , , , bFillColor, CboFill.ListIndex, bBorderColor
        End If
        Case 2
        ObjDraw1.BackColor = bBackColor
    End Select
    ObjDraw1.SetFocus
End Sub

Private Sub ColorPal1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
    If Button = 2 Then
        With cDialog
        .DialogTitle = "Open Palette"
        .Filter = "Palette (*.pal)|*.pal"
        .FileName = ""
        .ShowOpen
        .FileName = Trim(.FileName)
            If Len(.FileName) > 0 And FileExist(.FileName) = True Then
            ColorPal1.LoadPalette .FileName
            End If
        End With
    End If
End Sub

Private Sub CoolBar1_HeightChanged(ByVal NewHeight As Single)
    Form_Resize
End Sub

Private Sub CoolBar3_HeightChanged(ByVal NewHeight As Single)
    Form_Resize
End Sub

Private Sub Form_Load()
    Dim n As Integer
    CboFontName.Clear
    
    For n = 1 To Screen.FontCount - 1
    CboFontName.AddItem Screen.Fonts(n)
    Next n
    
    CboFontName.Text = "Arial"
    
    For n = 5 To 100
    CboFontSize.AddItem n
    Next n
    
    CboFontSize.Text = 15
    CboFill.ListIndex = 0
    ColorIndex = 0
    
    bFillColor = OpColor(0).BackColor
    bBorderColor = OpColor(1).BackColor
    bBackColor = OpColor(2).BackColor
End Sub

Private Sub Form_Paint()
    UpdToolBar
End Sub

Private Sub Form_Resize()
    If Me.WindowState <> 1 Then
    ObjDraw1.Width = Me.Width - CoolBar2.Width - CoolBar3.Width - 175
    ObjDraw1.Height = Me.Height - CoolBar1.Height - StatusBar1.Height - 890
    ObjDraw1.Top = CoolBar1.Height
    ObjDraw1.Left = CoolBar2.Width
    
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If Modified = True Then
    Answer = MsgBox("本图片已经被修改过，是否在退出之前先保存修改？", vbDefaultButton1 + vbYesNoCancel)
        If Answer = vbYes Then
        Cancel = True
            With cDialog
            .DialogTitle = "保存工程"
            .Filter = "ObjectDraw 工程文件 (*.ojp)|*.ojp"
            .FileName = ""
            .ShowSave
            .FileName = Trim(.FileName)
                If Len(.FileName) > 0 Then
                ObjDraw1.SaveProjects .FileName
                End If
            End With
        End
        ElseIf Answer = vbCancel Then
        Cancel = True
        Exit Sub
        End If
    End If
    End
End Sub

Private Sub LblColor_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
    LblColor.Caption = ""
End Sub

Private Sub mnuEdit_Click()
    If ObjDraw1.CurrentObject > -1 Then
    SmnuEdit(3).Enabled = True
    SmnuEdit(4).Enabled = True
    SmnuEdit(7).Enabled = True
    Else
    SmnuEdit(3).Enabled = False
    SmnuEdit(4).Enabled = False
    SmnuEdit(7).Enabled = False
    End If
    
    SmnuEdit(5).Enabled = ObjDraw1.ObjectInClipboard
End Sub

Private Sub mnuZoom_Click()
    StatusBar1.Panels(1).Text = "你也可以通过键盘的 ""+"" 和 ""-"" 来放大和缩小图像。"
End Sub

Private Sub ObjDraw1_KeyDown(KeyAscii As Integer, Shift As Integer)
    If KeyAscii >= 37 And KeyAscii <= 40 Then
    StatusBar1.Panels(1).Text = "按下 ""Ctrl"" 键和方向键来切换选择对象。"
    ElseIf KeyAscii = vbKeyAdd Or KeyAscii = vbKeySubtract Then
    mnuZoom.Caption = "缩放 (" & Round(ObjDraw1.ZoomFactor * 100) & "%)"
    End If
End Sub

Private Sub ObjDraw1_KeyUp(KeyAscii As Integer, Shift As Integer)
    StatusBar1.Panels(1).Text = ""
End Sub

Private Sub ObjDraw1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
    StatusBar1.Panels(2).Text = "X: " & x & " - Y: " & Y
End Sub

Private Sub ObjDraw1_NewDrawingEnd()
    Toolbar4.Buttons(1).Value = tbrPressed
End Sub

Private Sub ObjDraw1_ObjectResize(ObjType As ObjectDraw.myObType, Index As Long, ObjLeft As Single, ObjTop As Single, ObjWidth As Single, ObjHeight As Single, ObjAspect As Single)
    Dim tmp As String
    
    Select Case ObjType
        Case mline
        tmp = "Line"
        Case mArc
        tmp = "Arc"
        Case mRectangle
            If ObjAspect = 0 Then
            tmp = "Rectangle"
            Else
            tmp = "Square"
            End If
        Case mEllipse
            If ObjAspect = 0 Then
            tmp = "Ellipse"
            Else
            tmp = "Circle"
            End If
        Case mText
        tmp = "Text"
        Case mImage
        tmp = "Image"
    End Select
    
    StatusBar1.Panels(3).Text = tmp & "   位置. X:" & ObjLeft & "  Y:" & ObjTop & _
    "  大小 W:" & ObjWidth & "  H:" & ObjHeight & " "

End Sub

Private Sub ObjDraw1_ObjSelected(ObjType As ObjectDraw.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)
    Dim tmp As String
    
    If ObjType <> -1 Then
    doNothing = True
        If ObjFillColor > -1 Then bFillColor = ObjFillColor
        OpColor(0).BackColor = bFillColor
        If ObjFillStyle > -1 Then CboFill.ListIndex = ObjFillStyle
        If ObjAngle > -1 Then Slider1.Value = ObjAngle
        Label1(0).Caption = "旋转: " & Slider1.Value & "°"
        If ObjBorderColor > -1 Then bBorderColor = ObjBorderColor
        OpColor(1).BackColor = bBorderColor
        If ObjType <> mText Then VScroll1.Value = ObjBorderWidth
        TxtBorder.Text = VScroll1.Value
        If ObjFontName <> "" Then CboFontName.Text = ObjFontName
        If ObjFontSize > 0 Then CboFontSize.Text = ObjFontSize
        If ObjType = mPolygon Or ObjType = mStar Then
            If ObjPointQty > 0 And ObjPointQty <= 30 Then
            VScroll2.Value = ObjPointQty
            TxtPoint.Text = ObjPointQty
            End If
        ElseIf ObjType = mRoundRectangle Then
        VScroll3.Value = ObjPointQty
        TxtRound.Text = ObjPointQty
        End If
        TxtPoint.Text = VScroll2.Value
        mBold = CBool(Int(ObjFontBold))
        Toolbar1.Buttons(19).Value = Abs(Int(ObjFontBold))
        mItalic = CBool(Int(ObjFontItalic))
        Toolbar1.Buttons(20).Value = Abs(Int(ObjFontItalic))
        mUnderline = CBool(Int(ObjFontUnderline))
        Toolbar1.Buttons(21).Value = Abs(Int(ObjFontUnderline))
        mStrikethru = CBool(Int(ObjFontStrikethru))
        Toolbar1.Buttons(22).Value = Abs(Int(ObjFontStrikethru))
    
        If ObjTextAlign > -1 Then
        mTxtAlign = ObjTextAlign
        Select Case mTxtAlign
            Case vbLeftJustify
            Toolbar1.Buttons(15).Value = tbrPressed
            Case vbRightJustify
            Toolbar1.Buttons(17).Value = tbrPressed
            Case vbCenter
            Toolbar1.Buttons(16).Value = tbrPressed
        End Select
        
        End If
    doNothing = False
    
    Select Case ObjType
        Case mline
        tmp = "Line"
        Case mArc
        tmp = "Arc"
        Case mRectangle
            If ObjAspect = 0 Then
            tmp = "Rectangle"
            Else
            tmp = "Square"
            End If
        Case mEllipse
            If ObjAspect = 0 Then
            tmp = "Ellipse"
            Else
            tmp = "Circle"
            End If
        Case mText
        tmp = "Text"
        Case mImage
        tmp = "Image"
        Case mPolygon
        tmp = "Polygon"
        Case mStar
        tmp = "Star"
    End Select
    StatusBar1.Panels(3).Text = tmp & "   位置. X:" & ObjLeft & "  Y:" & ObjTop & _
    "  大小 W:" & ObjWidth & "  H:" & ObjHeight & " "
    Else
    StatusBar1.Panels(3).Text = ""
    End If
    UpdToolBar

End Sub


Private Sub ObjDraw1_Prompt2Save()
    Modified = True
End Sub

Private Sub ObjDraw1_UndoRedo(LastUndo As Boolean, LastRedo As Boolean)
    SmnuEdit(0).Enabled = Not LastUndo
    SmnuEdit(1).Enabled = Not LastRedo
    Toolbar1.Buttons(10).Enabled = Not LastUndo
    Toolbar1.Buttons(11).Enabled = Not LastRedo
End Sub

Private Sub OpColor_Click(Index As Integer)
    Dim sTmp As String
    ColorIndex = Index
    
    sTmp = Right("000000" & Hex(OpColor(Index).BackColor), 6)
    ScrCol(0).Value = Int("&H" & Right$(sTmp, 2))
    ScrCol(1).Value = Int("&H" & Mid$(sTmp, 3, 2))
    ScrCol(2).Value = Int("&H" & Left$(sTmp, 2))
End Sub

Private Sub OpColor_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
    Dim sTmp As String
    sTmp = Right("000000" & Hex(OpColor(Index).BackColor), 6)
    LblColor.Caption = "十六进制码:" & sTmp & vbCrLf & " 红:" & Int("&H" & Right$(sTmp, 2)) & _
    " - 绿:" & Int("&H" & Mid$(sTmp, 3, 2)) & " - 蓝:" & Int("&H" & Left$(sTmp, 2))
End Sub

Private Sub PicProperty1_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
    LblColor.Caption = ""
End Sub

Private Sub ScrCol_Change(Index As Integer)
    Dim tColor As Long
    
    TxtColor(Index).Text = ScrCol(Index).Value
    
    tColor = RGB(ScrCol(0).Value, ScrCol(1).Value, ScrCol(2).Value)
    
    OpColor(ColorIndex).BackColor = tColor
    bFillColor = OpColor(0).BackColor
    bBorderColor = OpColor(1).BackColor