cdraws.cls

vb开发的连接mysql的工作流设置程序,图形化工作流自定义工具,原先是连接到Domino上的工作流自定义工具,现修改至mysql上,后台管理员设置工作流,前台读取数据库调用.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CDraws"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private WithEvents m_frmCanvas As PictureBox
Attribute m_frmCanvas.VB_VarHelpID = -1
Private mfrm As Form
Private m_Col As Collection
Private m_clsAction As IDraw
Private mBegin As IDraw
Private IsMouseDown As Boolean
Private m_iAddType As Integer
Private m_LX As Single
Private m_LY As Single
Private mGlobal As CGlobal
Public Event Action(Sender As Object)
Public Sub Run()
    Dim s As String
    s = TestErrors()
    If s <> "" Then
        MsgBox s
    Else
        MsgBox "没有检测到错误"
    End If
End Sub

Public Sub Create(frm As Object, PaintObj As Object)
    Set mfrm = frm
    Set m_frmCanvas = PaintObj
    mfrm.Caption = mGlobal.GName
End Sub
Public Property Get ActiveDraw() As IDraw
    Set ActiveDraw = m_clsAction
End Property

Public Sub BeginAdd(ByVal Addtype As Integer)
    m_iAddType = Addtype
End Sub

Public Sub Paint()
    Dim a As IDraw
    Dim col As Collection
    Set col = New Collection
    'm_frmCanvas.Cls
    For Each a In m_Col
        If a.ModeName = 1 Then
            a.Paint
        Else
            col.Add a
            'a.Paint
        End If
    Next
    For Each a In col
        a.Paint
    Next
    If Not (m_clsAction Is Nothing) Then
        m_clsAction.Paint
        m_clsAction.SetFocus
    End If
    RaiseEvent Action(m_clsAction)
End Sub

Private Sub Class_Initialize()
    Set m_Col = New Collection
    Set mGlobal = New CGlobal
    mGlobal.GName = "(无标题)"
End Sub

Private Sub Class_Terminate()
    Set m_Col = Nothing
    Set mGlobal = Nothing
End Sub

Private Sub m_frmCanvas_DblClick()
    If Not (Me.ActiveDraw Is Nothing) Then
        Me.ActiveDraw.ShowProperties
    End If
End Sub

Private Sub m_frmCanvas_KeyUp(KeyCode As Integer, Shift As Integer)
    Debug.Print KeyCode
    If KeyCode = 46 Then
        If Not (m_clsAction Is Nothing) Then
            m_clsAction.Delete
            Set m_clsAction = Nothing
            Paint
        End If
    End If
End Sub

Private Sub m_frmCanvas_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then
        IsMouseDown = True
    End If
    If Not (m_clsAction Is Nothing) Then
        If m_clsAction.InMe(x, y) Then
            m_LX = x - m_clsAction.Left: m_LY = y - m_clsAction.Top
            m_clsAction.SetFocus
            RaiseEvent Action(m_clsAction)
            Exit Sub
        Else
            m_clsAction.LostFocus
        End If
    End If
    Dim a As IDraw
    Dim ch As Boolean
    ch = False
    For Each a In m_Col
        If Not (a.IsDelete) Then
            If a.InMe(x, y) Then
                a.SetFocus
                a.Paint
                Set m_clsAction = a
                ch = True
                Exit For
            End If
        End If
    Next
    If ch = False Then Set m_clsAction = Nothing
    If Not (m_clsAction Is Nothing) Then
        m_LX = x - m_clsAction.Left: m_LY = y - m_clsAction.Top
        RaiseEvent Action(m_clsAction)
    Else
        RaiseEvent Action(Nothing)
    End If
End Sub

Private Sub m_frmCanvas_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If (IsMouseDown = True) And (Not (m_clsAction Is Nothing)) Then
        If (m_clsAction Is Nothing) Then Exit Sub
        If m_clsAction.CanMove Then
            m_clsAction.MoveTo x - m_LX, y - m_LY
            'Paint
            'm_frmCanvas.Cls
            m_clsAction.Paint
        End If
        RaiseEvent Action(m_clsAction)
    End If
'    防止屏幕闪的备用方法
'    待日后实现。
'    Dim a As IDraw
'    For Each a In m_Col
'        If a.ModeName <> 1 Then
'            If Not (a.IsDelete) Then
'                If a.InMe(x, y) Then
'                    a.Paint
'                End If
'            End If
'        End If
'    Next
End Sub

Private Sub m_frmCanvas_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        If m_iAddType <> 0 Then
            m_iAddType = 0
        End If
        mfrm.mnuDel.Visible = Not (m_clsAction Is Nothing)
        mfrm.PopupMenu mfrm.mnuPop
        Exit Sub
    End If
    If Not (m_clsAction Is Nothing) Then
        If m_iAddType = 1 Then
            AddMothed 1
        End If
    Else
        Select Case m_iAddType
        Case 2, 3, 4
            AddMothed m_iAddType             '添加接点
            If Not (m_clsAction Is Nothing) Then
                m_clsAction.MoveTo x - m_clsAction.Width / 2, y - m_clsAction.Height / 2
            End If
        Case Else
        End Select
        'RaiseEvent Action(m_clsAction)
    End If
    IsMouseDown = False
    m_frmCanvas.Cls
    Paint
End Sub

Private Function getId() As String
    Static Id(0 To 5) As Long
    Id(m_iAddType) = Id(m_iAddType) + 1
    getId = CStr(Id(m_iAddType))
End Function

Private Sub AddMothed(ByVal Modetype As Long)
    Dim a As IDraw
    Static clstemp As IDraw
    On Error GoTo ErrHandler
    Select Case Modetype
    Case AddRoute:
        If m_clsAction.ModeName = 1 Then
            MsgBox "不能给该对象添加联系"
            Paint
            Exit Sub
        End If
        If clstemp Is Nothing Then
            Set clstemp = m_clsAction
            Exit Sub
        Else
            If clstemp.Id <> m_clsAction.Id Then
                Set a = New CLine
                a.AddR clstemp, 1
                a.AddR m_clsAction, 2
            Else
                Exit Sub
            End If
        End If
    Case AddNode
        Set a = New CMidle
    Case AddBegin
        If Not (mBegin Is Nothing) Then
            If Not mBegin.IsDelete Then
                MsgBox "只能有一个开始端!"
            Else
                mBegin.UnDel
                Set m_clsAction = mBegin
            End If
            Exit Sub
        Else
            Set a = New CBegin
            Set mBegin = a
        End If
    Case AddEnd
        Set a = New CEnd
    Case Else
        Set clstemp = Nothing
        Exit Sub
    End Select
    Set clstemp = Nothing
    a.Create m_frmCanvas
    a.AddIn Me
    a.Id = getId
    m_Col.Add a
    If Not (m_clsAction Is Nothing) Then m_clsAction.LostFocus
    Set m_clsAction = a
    m_clsAction.SetFocus
    RaiseEvent Action(m_clsAction)
    Paint
    Exit Sub
ErrHandler:
    MsgBox Err.Source & "：" & Err.Description
    Set clstemp = Nothing
    m_iAddType = 0
End Sub

Public Sub ShowProperties()
    If Not (m_clsAction Is Nothing) Then
        m_clsAction.ShowProperties
    Else
        frmMainProperties.Display mGlobal
        mfrm.Caption = mGlobal.GName
    End If

End Sub
Public Function Caption() As String
    Caption = mGlobal.GName
End Function

Public Sub FileSave()
    Dim s As String
    s = TestErrors()
    If s <> "" Then
        MsgBox s
    Else
        MNotes.CreateWorkFlow mGlobal, mBegin, m_Col
    End If
End Sub

Public Sub FileLoad()
    MNotes.LoadWorkFlow mGlobal, mBegin, m_Col
    Dim ia As IDraw
    For Each ia In m_Col
        ia.Create m_frmCanvas
        ia.AddIn Me
        ia.MoveTo ia.Properties.NodeX, ia.Properties.NodeY
    Next ia
    mfrm.Caption = mGlobal.GName
    Set m_clsAction = Nothing
    Paint
End Sub

Private Sub m_frmCanvas_Paint()
    Paint
End Sub

Private Function TestErrors() As String
    Dim s As String
    TestErrors = ""
    MErrors.Clear
    s = "没有开始节点！"
    If (mBegin Is Nothing) Then
        MErrors.Add Me, "工作流", s
    Else
        If mBegin.IsDelete Then
            MErrors.Add Me, "工作流", s
        End If
    End If
    Dim ia As IDraw
    For Each ia In m_Col
        If Not (ia.IsDelete Or ia.isHide) Then
            ia.TestRun
        End If
    Next
    If MErrors.Count <> 0 Then
        TestErrors = MErrors.ErrorString
    End If
End Function