mnotes.bas

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

Attribute VB_Name = "MNotes"
Option Explicit

'与数据库 相连的模块，用于生成工作流文档，以及获得相关数据。2006-4-24
'
'

'2006-4-24*******************************************************************
Private cn As ADODB.Connection       ' 数据库连接变量
Private cmd As ADODB.Command      '命令集
Private rs As ADODB.Recordset         '记录集
Private strConnect As String                       '  连接字符串
Private sql As String
'****************************************************************************

'06-04-24Private mSession As NotesSession
Private NodeId() As String
Private mIsInit As Boolean
Private mServers() As String
Private mPeople() As String '
Private mDepartment As CDepartment
Private mGroup() As String
Private mRoles() As String
Private mGroupCol As Collection
Private mGroupPeople As Collection
Private mWFNames() As String '
Private mWFDBName As String '
Private mSysDBName As String '
Private mWFServer As String '
Private mSysServer As String
Private mNLink(0 To 19) As String
Private mWFDBNames() As String '从数据库配置库中读出的可用的数据库名称
Private mDBPath() As String '从数据库配置库中读出的可用的数据库路径
Private mUser As String '当前用户
Public Function Init() As Boolean
    ReDim mPeople(0)
    ReDim mDept(0)
    ReDim mGroup(0)
    ReDim mWFNames(0)
    ReDim mWFDBNames(0)
    ReDim mRoles(0)
    ReDim mDBPath(0)
    ReDim mServers(0)
    Set mGroupCol = New Collection
    Set mDepartment = Nothing
    'mNLink 变量在保存流程到数据库中时用到。
    mNLink(0) = "NLinkComparison"
    mNLink(1) = "NLinkEndNode"
    mNLink(2) = "NLinkEndX"
    mNLink(3) = "NLinkEndY"
    mNLink(4) = "NLinkFieldContentList"
    mNLink(5) = "NLinkFieldTitle"
    mNLink(6) = "NLinkFieldTitleList"
    mNLink(7) = "NLinkFieldValue"
    mNLink(8) = "NLinkFieldValuePanDuan"
    mNLink(9) = "NLinkFieldValuePanDuan1"
    mNLink(10) = "NLinkInputValue"
    mNLink(11) = "NLinkIsCondition"
    mNLink(12) = "NLinkIsField"
    mNLink(13) = "NLinkKeyItemList"
    mNLink(14) = "NLinkLuoJiPanDuan"
    mNLink(15) = "NLinkLuoJiPanDuan1"
    mNLink(16) = "NLinkStartNode"
    mNLink(17) = "NLinkStartX"
    mNLink(18) = "NLinkStartY"
    mNLink(19) = "NLinkType"
    On Error GoTo ErrHandler
    '***************************
    If cn Is Nothing Then
        Set cn = New ADODB.Connection
    End If
    '*********************************
    'mSession.Initialize
    mIsInit = True
    If EditEnvironment = True Then
    Init = True
    End If
    Exit Function
ErrHandler:
    If Err.Description <> "" Then
        MsgBox Err.Description
    End If
    Err.Clear
    Init = False
    mIsInit = False
End Function

Public Sub Term()
    Set cn = Nothing
    mIsInit = False
End Sub

Public Function People() As String()
    If Not mIsInit Then Init
    If UBound(mPeople) > 0 Then
        People = mPeople
        Exit Function
    End If
    Dim sqlPeople As String
    Dim peopleColl As ADODB.Recordset
    Dim i As Long
    Dim strName, Id, name As String
    i = 0
    ReDim mPeople(0) '初始化数组防止下标越界
    sqlPeople = "select code,name,organize_structure_id from employee_basicinfo"
    Set peopleColl = cn.Execute(sqlPeople)
    If peopleColl.RecordCount <> 0 Then
        Do While Not peopleColl.EOF
            ReDim Preserve mPeople(0 To i)
            Id = peopleColl("code")
            name = peopleColl("name")
            strName = name & "(" & Id & ")"
            mPeople(i) = strName
            Debug.Print (mPeople(i))
            'MsgBox peopleColl("modelname")
            i = i + 1
            peopleColl.MoveNext
        Loop
    peopleColl.Close
    Else
        MsgBox "不能读取系统配置库", vbOKOnly + vbInformation, "系统提示"
        '应终止程序
        Exit Function
    End If
    People = mPeople
End Function

Public Function WFNames() As String()
    'If Not mIsInit Then Init
    'If UBound(mWFNames) > 0 Then
    '    WFNames = mWFNames
    '    Exit Function
    'End If
    'On Error GoTo ErrHandler
    'Dim db As NotesDatabase
    'Set db = mSession.getDatabase(WFServer, mWFDBName, False)
    'If db Is Nothing Then
    '    MsgBox "不能读取流程数据库"
   '     WFNames = mWFNames
    '    Exit Function
    'End If
    'Dim dt As NotesDateTime
    'Set dt = mSession.CreateDateTime("2002/01/01")
    'Dim strSearch As String
    'strSearch = "Select Form=" & Chr$(34) & "WholeDoc" & Chr$(34) & _
    '    "&WFStatus=" & Chr$(34) & "E" & Chr$(34)
    'Dim docCol As NotesDocumentCollection
    'Set docCol = db.Search(strSearch, dt, 0)
    'Dim i As Long, doc As NotesDocument
    'ReDim mWFNames(0 To docCol.Count)
    'For i = 1 To docCol.Count
    '    Set doc = docCol.GetNthDocument(i)
    '    mWFNames(i) = doc.GetItemValue("WFName")(0)
    'Next i
    'WFNames = mWFNames
    Exit Function
ErrHandler:
    MsgBox "不能读取流程数据库"
    WFNames = mWFNames
End Function

Public Function LoadWorkFlow(GObj As CGlobal, Begin As Object, _
            Objs As Collection, Optional strWFName As String = "") As Boolean
            '读取具体流程信息
    LoadWorkFlow = False
    If Not mIsInit Then Init
    Dim fwpcoll As ADODB.Recordset '流程全局
    If strWFName = "" Then Exit Function
    'Dim db As NotesDatabase
    'Set db = mSession.getDatabase(WFServer, mWFDBName, False)
    'If db Is Nothing Then
    '    MsgBox "不能读取流程数据库"
    '    Exit Function
    'End If
    Dim wfid As String
    On Error GoTo ErrHandler
   ' Dim dt As NotesDateTime
    'Set dt = mSession.CreateDateTime("2002/01/01")
    
    Dim strSearch As String
    strSearch = "Select WFNameID from fwp_basicinfo where WFStatus = 'E' and WFname = '" & strWFName & "'"
    Debug.Print strSearch
    Set fwpcoll = cn.Execute(strSearch)
    If fwpcoll.RecordCount > 0 Then
    wfid = fwpcoll("WFNameID")
    Set Objs = New Collection
    Else
    MsgBox "该流程信息不完整，请联系管理员！"
    Exit Function
    End If
    fwpcoll.Close
    GObj.LoadDocument wfid, cn
    '生成开始、结束节点
    Dim ia As IDraw
    Set Begin = New CBegin
    Set ia = Begin
    '读开始节点
    strSearch = "select * from fwp_drawinfo where FWP_BasicInfo_WFNameID = " & wfid
    Set fwpcoll = cn.Execute(strSearch)
    If fwpcoll.RecordCount > 0 Then
        ia.Properties.NodeName = fwpcoll("StartNodeName")
        ia.Properties.NodeX = fwpcoll("StartNodeX") * Screen.TwipsPerPixelX
        ia.Properties.NodeY = fwpcoll("StartNodeY") * Screen.TwipsPerPixelY
        Objs.Add ia, "工作流原点"
        Set ia = New CEnd
        ia.Properties.NodeName = fwpcoll("EndNodeName")
        ia.Properties.NodeX = fwpcoll("EndNodeX") * Screen.TwipsPerPixelX
        ia.Properties.NodeY = fwpcoll("EndNodeY") * Screen.TwipsPerPixelY
        Objs.Add ia, fwpcoll("EndNodeName")
    End If
    fwpcoll.Close
    '生成并读取节点属性**************************************************
     Dim fnpcoll As ADODB.Recordset
    strSearch = "Select * from fnp_basicinfo where FWP_BasicInfo_WFNameID = " & wfid
    Debug.Print strSearch
    Set fnpcoll = cn.Execute(strSearch)
    If fnpcoll.RecordCount > 0 Then
    Dim fnpid As String
    Do While Not fnpcoll.EOF
        Set ia = New CMidle
        fnpid = fnpcoll("NodeNameID")
        ia.Properties.LoadDocument fnpid, cn
        ia.AutoAgents = GObj.AutoAgents '所有可用的自动代理
        ia.Properties.Notification = GObj.Notification
        Objs.Add ia, ia.Properties.NodeName
        fnpcoll.MoveNext
            'cnt = cnt + 1
    Loop
    Else
        MsgBox "节点为空!"
        Exit Function
    End If
   '
    '*******************************************************************
    '以上于2002-11-27基本完成，以下开始生成路由关系
    '由于路由关系是使用的是节点名所以要保证节点名称唯一
    Dim iSource As IDraw, iDert As IDraw, ib As IDraw
    'Dim vSource(), vDert(), vSX(), vSY(), vDX(), vDY()
    Dim strNode As String
    Dim sglx As Single, sglY As Single
    On Error GoTo ErrHandler
    strSearch = "select * from fwp_drawinfonode where FWP_BasicInfo_WFNameID = " & wfid
    Set fwpcoll = cn.Execute(strSearch)
    If fwpcoll.RecordCount > 0 Then
   ' ReDim vSource(0 To fwpcoll.RecordCount)
  '  ReDim vSX(0 To fwpcoll.RecordCount)
  '  ReDim vSY(0 To fwpcoll.RecordCount)
  '  ReDim vDert(0 To fwpcoll.RecordCount)
  '  ReDim vDX(0 To fwpcoll.RecordCount)
   ' ReDim vDY(0 To fwpcoll.RecordCount)
   ' Dim i As Long
   ' i = 0
    Do While Not fwpcoll.EOF
        Set ia = New CLine
        strNode = fwpcoll("NLinkStartNode")
        sglx = fwpcoll("NLinkStartX")
        sglY = fwpcoll("NLinkStartY")
        Set iSource = Objs.Item(strNode)
        strNode = fwpcoll("NLinkEndNode")
        sglx = fwpcoll("NLinkEndX")
        sglY = fwpcoll("NLinkEndY")
        Set iDert = Objs.Item(strNode)
        ia.AddR iSource, 1
        ia.AddR iDert, 2
        ia.Properties.Notification = GObj.Notification
        Objs.Add ia
        fwpcoll.MoveNext
       ' i = i + 1
    Loop
    LoadWorkFlow = True
    Exit Function
    Else
        MsgBox "无该流程画图信息!"
        Exit Function
    End If
ErrHandler:
    MsgBox "打开流程出错！"
    LoadWorkFlow = False
    Set ib = New CMidle
    ib.Properties.NodeName = strNode
    ib.AutoAgents = GObj.AutoAgents
    ib.Properties.NodeX = sglx * Screen.TwipsPerPixelX
    ib.Properties.NodeY = sglY * Screen.TwipsPerPixelY
    Objs.Add ib, ib.Caption
    Resume
End Function
Public Sub CreateWorkFlow(GObj As CGlobal, Begin As IDraw, Objs As Collection)
'根据选择的模块名称查询出相应的model_id
    If Not mIsInit Then Init
    Dim strSearch As String, updateStr As String
    Dim col As Collection, ic As CDraw
    Dim fwp As ADODB.Recordset
    Dim fnp As ADODB.Recordset
    Dim modelid As String
    Dim i As Long
   ' On Error GoTo ErrHandler
    strSearch = "select id from modelinfo where modelname = '" & GObj.ApplicationDB & "'"
    Set fwp = cn.Execute(strSearch)
    If fwp.RecordCount > 0 Then
    
        modelid = fwp("id")
        fwp.Close
        Set col = New Collection
        strSearch = "select * From fwp_basicinfo where WFName = '" & GObj.GName & "' and WFStatus = 'E'"
        '查询是否有名称相同的工作流,无则新建
        Set fwp = cn.Execute(strSearch)
        Dim strId As String, strtemp As String, itemp As Long
        If fwp.RecordCount > 0 Then
        '状态改为U，不可用
            strId = fwp("WFNameID")
            GObj.fwpid = strId
            If fwp("WFStatus") = "E" Then
                updateStr = "UPDATE fwp_basicinfo set WFStatus = 'U' WHERE WFNameID= '" & strId & "'"
                cn.Execute (updateStr)
            End If
        End If
        fwp.Close
         '插fwp_basicinfo表***********************************************
       Dim insert As String
       insert = "insert into fwp_basicinfo(WFName,modelinfo_id,WFDescription,WFStatus,WFMainForm) values('" & GObj.GName & "'," & _
       "" & modelid & ",'" & GObj.Comment & "','E','" & GObj.FormName & "')"
       Debug.Print insert
       cn.Execute (insert)
       '查询出刚插入的ID
       strSearch = "select WFNameID from fwp_basicinfo where WFName = '" & GObj.GName & "'and WFStatus = 'E'"
       Set fwp = cn.Execute(strSearch)
       If fwp.RecordCount > 0 Then
            strId = fwp("WFNameID")
       End If
       fwp.Close
       '***********************************************************************
       '*******************************insert FWP_PurviewControl*****************************************
       insert = "insert into FWP_PurviewControl(FWP_BasicInfo_WFNameID,WFAdmin,WFAdminExpanded) values('" & _
       strId & "','" & GObj.Administrator & "','" & GObj.Administrator & "')"
       Debug.Print insert
       cn.Execute (insert)
       Dim users() As String
       ReDim users(0 To UBound(GObj.users))
       users = GObj.users
       If UBound(users) > 0 Then
           For i = (LBound(users) + 1) To UBound(users)
                insert = "insert into fwp_purviewcontrol_wfinitiators(FWP_BasicInfo_WFNameID,WFInitiators) " & _
                "values('" & strId & "','" & users(i) & "')"
                cn.Execute (insert)
                insert = "insert into fwp_purviewcontrol_wfinitiatorsexpanded(FWP_BasicInfo_WFNameID,WFInitiatorsExpanded) " & _
                "values('" & strId & "','" & users(i) & "')"
                cn.Execute (insert)
           Next i
       End If
       Dim readers() As String
       ReDim readers(0 To UBound(GObj.readers))
       readers = GObj.readers
       If UBound(readers) > 0 Then
           For i = (LBound(readers) + 1) To UBound(readers)
                insert = "insert into fwp_purviewcontrol_wfreaders(FWP_BasicInfo_WFNameID,WFReaders) " & _
                "values('" & strId & "','" & readers(i) & "')"
                Debug.Print insert
                cn.Execute (insert)
                insert = "insert into fwp_purviewcontrol_wfreadersexpanded(FWP_BasicInfo_WFNameID,WFReadersExpanded) " & _
                "values('" & strId & "','" & readers(i) & "')"
                Debug.Print insert
                cn.Execute (insert)
           Next i
       End If
       '**********************************insert FWP_PurviewControl end*****************************
       '**********************************insert FWP_TimeControl************************************
       Dim WFTimeLimitNotification As String
        If GObj.Notification Then
            WFTimeLimitNotification = "1"
        Else
            WFTimeLimitNotification = "0"
        End If
       insert = "insert into fwp_timecontrol(FWP_BasicInfo_WFNameID,WFDuration,WFTimeLimitNotification,WFTimeLimit,WFTimeRepeat) " & _
                "values('" & strId & "','" & GObj.Duration & "'," & WFTimeLimitNotification & ",'" & GObj.TimeLimit & "','" & GObj.RepeatTime & "')"
                Debug.Print insert
        cn.Execute (insert)
       '**********************************insert FWP_TimeControl end********************************
       '**********************************insert FWP_PigeonholeControl************************************
       Dim ArchiveTime As String