mnotes.bas

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

       If Trim(GObj.ArchiveTime) = "" Then
            ArchiveTime = "0"
       Else
            ArchiveTime = GObj.ArchiveTime
       End If
       insert = "insert into FWP_PigeonholeControl(FWP_BasicInfo_WFNameID,WFArchiveActivation,WFArchiveTime,WFArchiveDB,WFArchiveDBName,WFArchiveDocManage,WFArchiveDocACL) " & _
                 "values('" & strId & "'," & GObj.ArchiveActivation & "," & ArchiveTime & ",'" & GObj.ArchiveDB & "','" & GObj.ArchiveDBName & "'," & CStr(GObj.ArchiveManage) & "," & CStr(GObj.ArchiveACL) & ")"
        Debug.Print insert
        cn.Execute (insert)
        Dim ArchiveDocAdmin() As String
        ReDim ArchiveDocAdmin(0 To UBound(GObj.ArchiveAdministrators))
        ArchiveDocAdmin = GObj.ArchiveAdministrators
        If UBound(ArchiveDocAdmin) > 0 Then
            For i = (LBound(ArchiveDocAdmin) + 1) To UBound(ArchiveDocAdmin)
                 insert = "insert into fwp_pigeonholecontrol_wfarchivedocadmin(FWP_BasicInfo_WFNameID,wfarchivedocadmin) " & _
                 "values('" & strId & "','" & ArchiveDocAdmin(i) & "')"
                 Debug.Print insert
                 cn.Execute (insert)
            Next i
        End If
       '**********************************insert FWP_PigeonholeControl end************************************
        '**********************************insert FWP_HighProperty ************************************
        Dim mReCall As String, mChange As String, mAgent As String
        If GObj.AllowReCall Then
            mReCall = "1"
        Else
            mReCall = "0"
        End If
        If GObj.AllowChange Then
            mChange = "1"
        Else
            mChange = "0"
        End If
        If GObj.AllowAgent Then
            mAgent = "1"
        Else
            mAgent = "0"
        End If
        insert = "insert into fwp_highproperty(FWP_BasicInfo_WFNameID,WFRecall,WFChange,WFAgent) " & _
                 "values(" & strId & "," & mReCall & "," & mChange & "," & mAgent & ")"
                  Debug.Print insert
        cn.Execute (insert)
                
        '**********************************insert FWP_HighProperty end*********************************
        insert = "insert into fwp_drawinfo(FWP_BasicInfo_WFNameID)" & _
                 "values(" & strId & ")"
                 Debug.Print insert
        cn.Execute (insert)
        Dim ia As IDraw, EndX, EndY, Count As Long
        Dim EndName, WFCount As Long
        Count = 0
        WFCount = 0
        For Each ia In Objs
            If Not (ia.IsDelete Or ia.isHide) Then
                Select Case ia.ModeName
                Case 1  '线
                    col.Add ia
                    Count = Count + 1
                Case 2  '中间节点
                    Dim NodeRouterType As Integer, fnpid As String
                    If ia.NextNodes.Count > 1 Then
                        NodeRouterType = 1
                    Else
                        NodeRouterType = 0
                    End If
                    WFCount = WFCount + 1
                    ia.Properties.CreateDocument strId, NodeRouterType, cn
                Case 3  '开始节点
                     strSearch = "select * from fwp_drawinfo where FWP_BasicInfo_WFNameID = " & strId
                     fwp.Open strSearch, cn, 1, 2
                     fwp("StartNodeX") = Begin.Properties.NodeX / Screen.TwipsPerPixelX
                     fwp("StartNodeY") = Begin.Properties.NodeY / Screen.TwipsPerPixelY
                     fwp("StartNodeName") = Begin.Properties.NodeName
                     fwp.Update
                     fwp.Close
                Case 4  '结束节点
                    EndX = ia.Left / Screen.TwipsPerPixelX
                    EndY = ia.Top / Screen.TwipsPerPixelY
                    EndName = ia.Properties.NodeName

                Case Else
                End Select
            End If
        Next ia
        CreateRoute strId, col, Count
        strSearch = "select * from fwp_drawinfo where FWP_BasicInfo_WFNameID = " & strId
        fwp.Open strSearch, cn, 1, 2
        fwp("EndNodeX") = EndX
        fwp("EndNodeY") = EndY
        fwp("EndNodeName") = EndName
        fwp("WFCount") = WFCount
        fwp.Update
        fwp.Close
        MsgBox "恭喜，流程保存成功！", , "流程保存"
        ReDim mWFNames(0)
        Set fwp = Nothing
        Exit Sub
    Else
        MsgBox "系统配置库中无模块记录,请联系管理员!", vbOKOnly + vbInformation, "系统提示"
        Exit Sub
    End If
'ErrHandler:
'    MsgBox "保存流程出错！"
End Sub
Private Sub CreateRoute(fwpid As String, Objs As Collection, Count As Long)
    Dim ia As CLine, ic As IDraw
    Dim c As IDraw
    Dim i As Long
    Dim strsql As String, j As Long
    Dim NLinkStartNode() As String, NLinkStartX() As Double, NLinkStartY() As Double
    Dim NLinkEndNode() As String, NLinkEndX() As Double, NLinkEndY() As Double
    ReDim NLinkStartNode(0 To Count)
    ReDim NLinkStartX(0 To Count)
    ReDim NLinkStartY(0 To Count)
    ReDim NLinkEndNode(0 To Count)
    ReDim NLinkEndX(0 To Count)
    ReDim NLinkEndY(0 To Count)
    Dim fwp As New ADODB.Recordset
    j = 0
    For Each ia In Objs
         Set ic = ia.PrevNode '当前节点
         Set c = ia.NextNode '下一节点
      
    If c.ModeName = 2 And ic.ModeName = 3 Then
        '开始点
         strsql = "select * from FWP_HighProperty where FWP_BasicInfo_WFNameID = " & fwpid
        Debug.Print strsql
        fwp.Open strsql, cn, 1, 2
        fwp("WFFirstNodeDocID") = c.Properties.fnpid
        fwp.Update
        fwp.Close
    End If
    If c.ModeName = 2 And ic.ModeName = 2 Then
        '中间点
       strsql = "insert into fnp_flowway_noderouterdocid(FNP_BasicInfo_NodeNameID,NodeRouterDocID,NodeRouterNodeName) " & _
                "values(" & ic.Properties.fnpid & ",'" & c.Properties.fnpid & "','" & c.Properties.NodeName & "')"
                Debug.Print strsql
        cn.Execute (strsql)
    End If
    If c.ModeName = 4 And ic.ModeName = 2 Then
        '结束点
        Dim wfEnd As String, wfendname As String
        
        strsql = "UPDATE FNP_BasicInfo set NodeType = 2 where NodeNameID = " & ic.Properties.fnpid
        cn.Execute (strsql)
         strsql = "insert into fnp_flowway_noderouterdocid(FNP_BasicInfo_NodeNameID,NodeRouterDocID,NodeRouterNodeName) " & _
                  "values(" & ic.Properties.fnpid & ",'WFEND','流程结束')"
         Debug.Print strsql
         cn.Execute (strsql)
    End If
        NLinkStartNode(j) = ic.Properties.NodeName
        NLinkStartX(j) = ic.Left / Screen.TwipsPerPixelX
        NLinkStartY(j) = ic.Top / Screen.TwipsPerPixelY
        NLinkEndNode(j) = c.Properties.NodeName
        NLinkEndX(j) = c.Left / Screen.TwipsPerPixelX
        NLinkEndY(j) = c.Top / Screen.TwipsPerPixelY
        j = j + 1
 Next ia
    strsql = "select * from fwp_drawinfonode"
    If UBound(MMain.TrueStrings(NLinkStartNode)) > 0 Then
        For i = (LBound(NLinkStartNode)) To (UBound(NLinkStartNode) - 1)
        strsql = "insert into fwp_drawinfonode(FWP_BasicInfo_WFNameID,NLinkStartNode,NLinkStartX," & _
                 "NLinkStartY,NLinkEndNode,NLinkEndX,NLinkEndY) " & _
                 "values(" & fwpid & ",'" & NLinkStartNode(i) & "'," & NLinkStartX(i) & _
                 "," & NLinkStartY(i) & ",'" & NLinkEndNode(i) & "'," & NLinkEndX(i) & "," & NLinkEndY(i) & ")"
         Debug.Print strsql
         cn.Execute (strsql)
        Next i
    End If
    Set fwp = Nothing
End Sub

Public Function getForms(DBName As String) As String()
    If Not mIsInit Then Init
    Dim modelid   As String
    Dim sForms() As String
    Dim VForms As Variant
    Dim formscoll As ADODB.Recordset
    On Error GoTo ErrHandler
    ReDim sForms(0)
    Dim i As Long, strSearch As String
    strSearch = "select id from modelinfo where modelname = '" & DBName & "'"
    Set formscoll = cn.Execute(strSearch)
    If formscoll.RecordCount > 0 Then
        modelid = formscoll("id")
    End If
    formscoll.Close
    If modelid <> "" Then
        strSearch = "select tablename from modelinfo_tablename where modelinfo_id = '" & modelid & "'"
        Set formscoll = cn.Execute(strSearch)
        Do While Not formscoll.EOF
            ReDim Preserve sForms(0 To i)
            sForms(i) = formscoll("tablename")
            Debug.Print (sForms(i))
            formscoll.MoveNext
            i = i + 1
        Loop
    formscoll.Close
    End If
   ' strPath = getDBPath(DBName)
    'Dim db As NotesDatabase
    Dim strForms As String, j As Long
    
'    'Set db = mSession.getDatabase(WFServer, strPath, False)
''    If Not db.IsOpen Then db.Open
'    VForms = db.Forms
'    Dim v As Variant
'    Dim k As Long
'    k = 0
'    For i = 0 To UBound(VForms)
'        v = VForms(i).Aliases
'        For j = LBound(v) To UBound(v)
'            If Left$(v(j), 4) = "[WF]" Then
'                ReDim Preserve sForms(0 To k)
'                sForms(k) = VForms(i).name
'                k = k + 1
'            End If
'        Next j
'    Next

ErrHandler:
    getForms = sForms
End Function

Public Function getForm(DBName As String, FormName As String, _
        Optional ByVal Alias As Boolean) As String
    If Not mIsInit Then Init
    On Error GoTo ErrHandler
    Dim i As Long, strPath As String
    Dim strForm As String, VForms As Variant
    'strPath = getDBPath(DBName)
  '  Dim db As NotesDatabase, clsForm As NotesForm
  '  Set db = mSession.getDatabase(WFServer, strPath, False)
  '  Set clsForm = db.getForm(FormName)
'    If Not Alias Then
'        getForm = clsForm.name
'        Exit Function
'    End If
'    VForms = clsForm.Aliases
'    For i = LBound(VForms) To UBound(VForms)
'        If Left$(VForms(i), 4) = "[WF]" Then
'            getForm = VForms(i)
'            Exit Function
'        End If
'    Next i
ErrHandler:
End Function

Public Function getAgents(DBName As String) As String()
    If Not mIsInit Then Init
    Static sDBName  As String
    Static sAgents() As String
    Dim VAgents As Variant
    On Error GoTo ErrHandler
    ReDim sAgents(0)
    Dim i As Long, strPath As String
    strPath = getDBPath(DBName)
    '06-04-24Dim db As NotesDatabase
    Dim strForms As String, j As Long
    '06-04-24Set db = mSession.getDatabase(WFServer, strPath, False)
'    If Not db.IsOpen Then db.Open
    'VAgents = db.Agents
    Dim v As Variant
    Dim k As Long
    k = 0
    For i = 0 To UBound(VAgents)
        v = Split(VAgents(i).name, "|")
        For j = LBound(v) To UBound(v)
            v(j) = Trim(v(j))
            If Left$(v(j), 6) = "[AUTO]" Then
                ReDim Preserve sAgents(0 To k)
                sAgents(k) = v(j)
                k = k + 1
            End If
        Next j
    Next
ErrHandler:
    getAgents = sAgents
End Function

Public Function Login() As Boolean
    Dim b As Boolean, cnt As Integer '    b = False

    cnt = 1
    On Error GoTo ErrHandler
    If Not mIsInit Then Init
    Login = True
    Exit Function
ErrHandler:
    cnt = cnt + 1
    If cnt < 4 Then
        b = True
        Resume
    Else
        Login = False
        Exit Function
    End If
End Function

Public Function getDBNames() As String()
    If Not mIsInit Then Login
    If UBound(mWFDBNames) > 0 Then
        getDBNames = mWFDBNames
        Exit Function
    End If
    Dim ModelColl As ADODB.Recordset
    Dim strdbName, strSearch As String
    Dim cnt As Long
    cnt = 0
    strSearch = "select id,modelname from modelinfo where isflwo = 1"
    Set ModelColl = cn.Execute(strSearch)
     If ModelColl.RecordCount <> 0 Then
        Do While Not ModelColl.EOF
            ReDim Preserve mWFDBNames(0 To cnt)
            mWFDBNames(cnt) = ModelColl("modelname")
            Debug.Print (mWFDBNames(cnt))
            ModelColl.MoveNext
            cnt = cnt + 1
        Loop
    ModelColl.Close

    Else
        MsgBox "不能读取系统配置库", vbOKOnly + vbInformation, "系统提示"
    End If
    getDBNames = mWFDBNames
End Function

Public Function getDBPath(ADBName As String) As String
    If Not mIsInit Then Init
    Dim i As Long, strPath As String
    For i = 1 To UBound(mWFDBNames)
        If mWFDBNames(i) = ADBName Then
            strPath = mDBPath(0)
            Exit For
        End If
    Next i
    getDBPath = strPath
End Function

Public Function IsInited() As Boolean
    IsInited = mIsInit
End Function

Public Function getDepartment() As CDepartment
'    If Not mIsInit Then Init
'    If Not (mDepartment Is Nothing) Then
'        Set getDepartment = mDepartment
'    End If
'    'Dim dept As New CDepartments
'    Set mDepartment = New CDepartments
'    Dim db As NotesDatabase
'    Dim i As Long
'    i = 0
'    Set db = mSession.getDatabase(SysServer, mSysDBName, False)
'    If db Is Nothing Then
'        MsgBox "不能读取系统配置库"
'        Set getDepartment = mDepartment
'        Exit Function
'    End If
'    Dim docCol As NotesDocumentCollection
'    Dim strSearch As String
'    strSearch = "SELECT (Form=""fConfig_dep"") &(deplevel=0)"
'    Set docCol = db.Search(strSearch, Nothing, 0)
'    For i = 1 To docCol.Count
'        mDepartment.createDepartment docCol.GetNthDocument(i)
'    Next i
'    Set getDepartment = mDepartment
End Function

Public Function Servers() As String()
'    If Not mIsInit Then Init
'    If UBound(mServers) > 0 Then
'        Servers = mServers
'        Exit Function
'    End If
'    Dim db As NotesDatabase
'    Dim i As Long, cnt As Long
'    i = 0
'    ReDim mServers(0) '初始化数组防止下标越界