mnotes.bas

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

'    mServers(0) = "本地"
'    cnt = 1
'    Dim vBooks As Variant
'    vBooks = mSession.AddressBooks
'    If IsEmpty(vBooks) Then
'        Servers = mServers
'        Exit Function
'    End If
'    'ReDim mServers(LBound(vBooks) To UBound(vBooks))
'    On Error GoTo ErrHandler
'    Dim view As NotesView, doc As NotesDocument
'    For i = LBound(vBooks) To UBound(vBooks)
''        If vBooks(i).Server = "" Then
''            mServers(i) = "本地"
''        Else
''            Set clsName = mSession.CreateName(vBooks(i).Server)
''            mServers(i) = clsName.Common & "/" & clsName.Organization
''        End If
'        If vBooks(i).IsPublicAddressBook Then
''            If Not vBooks(i).IsOpen Then vBooks(i).Open
'            Set view = vBooks(i).GetView("Servers")
'            If Not (view Is Nothing) Then
'                Set doc = view.GetFirstDocument
'                Do Until (doc Is Nothing)
'                    ReDim Preserve mServers(cnt)
'                    mServers(cnt) = _
'                            getNotesName(doc.GetItemValue("ServerName")(0))
'                    cnt = cnt + 1
'                    Set doc = view.GetNextDocument(doc)
'                Loop
'            End If
'        End If
'    Next i
'ErrHandler:
'    Servers = mServers
End Function

Public Function EditEnvironment(Optional Changed As Boolean = False) _
            As Boolean
'该函数用来读取保存在ini中的设置，包括服务器，系统配置库和工作流库
    EditEnvironment = False
    If Not mIsInit Then Init
    'Set cmd = New ADODB.Command      '命令集
    Set rs = New ADODB.Recordset
    Dim v() As String
    Dim fs As New FileSystemObject
    Dim flag As Boolean
    Dim gb2312 As String
    On Error GoTo ErrHandler
        ReDim v(0 To 5)

    If fs.FileExists(MNotes.getPath) Then '判断配置文件是否存在
    v = ReadConfig(MNotes.getPath)
    End If
    v = frmLogin.Display(v)
    If UBound(v) = 0 Then Exit Function
    If ConnectToServer(v) Then
        Call SaveConfig(v, MNotes.getPath)
    End If
    gb2312 = "set names 'gb2312';" 'mysql乱码问题
    cn.Execute (gb2312)
'***************************************************************************
'    Dim sql1, sql2 As String
'    sql1 = "select * from modelinfo"
'    sql2 = "UPDATE modelinfo set modelname = '测试' WHERE id = 1"
'
'    Set rs = cn.Execute(sql1)
'    If rs.RecordCount <> 0 Then
'        Do While Not rs.EOF
'            MsgBox rs("modelname")
'            rs.MoveNext
'        Loop
'    Else
'        MsgBox "数据库没有数据！"
'    End If
'    cn.Execute (sql2)
'****************************************************************************
    ReDim mPeople(0)
    ReDim mWFNames(0)
    ReDim mWFDBNames(0)
    ReDim mDBPath(0)
    People '在系统配置库中读取人员
    getDBNames '读取数据库名称
   ' mSession.SetEnvironmentVar "WorkFlowServer", mWFServer & "|" & mSysServer
    'mSession.SetEnvironmentVar "SystemDBName", mSysDBName
    'mSession.SetEnvironmentVar "WorkFlowDBName", mWFDBName
    EditEnvironment = True
    'cn.Close
    Exit Function
ErrHandler:
    MsgBox "打开数据库出错，请确认数据库路径是否正确！"
    Err.Raise Err.Number
    EditEnvironment = False
End Function

Public Function getDirectory(server As String) As Object
'    If Not mIsInit Then Init
'    Dim strServer As String, db As NotesDatabase
'    Dim v() As String, cnt As Long
'    ReDim v(0)
'    On Error GoTo ErrHandler
'    strServer = server
'    If server = "本地" Then strServer = ""
'    Dim clsdir As NotesDbDirectory
'    Set clsdir = mSession.GetDbDirectory(strServer)
'    Set db = clsdir.GetFirstDatabase(1247)
'    Do While Not (db Is Nothing)
'        DoEvents
'        cnt = UBound(v)
'        v(cnt) = db.FilePath & "|" & db.Title
'        cnt = cnt + 1
'        ReDim Preserve v(0 To cnt)
'        Set db = clsdir.GetNextDatabase
'    Loop
'    Dim cls As New CDirectory
'    cls.Create "", v
'ErrHandler:
'    Set getDirectory = cls
End Function

Public Sub ShowWorkFlows(ANodes As Nodes)
    '************************************
    If Not mIsInit Then Init
    Dim ns As Nodes, n As Node
    Dim flowColl As ADODB.Recordset '流程全局
    Dim modelname As ADODB.Recordset '模块名称
    Set ns = ANodes
    ns.Clear
    On Error GoTo ErrHandler
    Dim col As Collection
    Set col = New Collection
   ' Dim dt As NotesDateTime
    'Set dt = mSession.CreateDateTime("2002/01/01")
    Dim strSearch, strSearch1 As String '检索出所有可用流程全局属性
    strSearch = "Select * from fwp_basicinfo where WFStatus = 'E'"
    Set flowColl = cn.Execute(strSearch)
    Dim strName As String, strDB As String
    Dim i As Long, modelid As String
    Dim j As Integer
    i = 1
    If flowColl.RecordCount > 0 Then
      Do While Not flowColl.EOF
            Debug.Assert i <> 88
        modelid = flowColl("modelinfo_id")
        strSearch1 = "Select * from modelinfo where id =" & modelid
        Set modelname = cn.Execute(strSearch1)
        strDB = modelname("modelname")
        modelname.Close
        strName = flowColl("WFName")
        Set n = col.Item(strDB) '由集合中取出模块名称,没有则创建
        ns.Add n, tvwChild, strName, strName, 3
        Debug.Print strDB & ".add(" & n.Text & "," & strName & "," & strName
        i = i + 1
       flowColl.MoveNext
       Loop
        flowColl.Close
    'Else
    '    MsgBox "流程库无可用流程！", vbOKOnly + vbInformation, "系统提示"
    End If
    Exit Sub
ErrHandler:
    Set n = ns.Add(, , , strDB, 2, 1) '增加父节点
    col.Add n, n.Text '将模块名称放到集合中
    Resume Next
End Sub
Public Function getGroups() As String()
'    If Not (mGroupPeople Is Nothing) Then
'        Set getGroups = mGroupPeople
'        Exit Function
'    End If
'    Set mGroupPeople = New Collection
'    Groups
'    Set getGroups = mGroupPeople
    Groups
    getGroups = mGroup
End Function
'取得通讯录中的所有群组
Private Sub Groups()
'    If Not mIsInit Then Init
'    If UBound(mGroup) > 0 Then
'        Exit Sub
'    End If
'    Dim db As NotesDatabase
'    Dim i As Long
'    i = 0
'    ReDim mGroup(0) '初始化数组防止下标越界
'    Set mGroupCol = New Collection
'    Set db = mSession.getDatabase(SysServer, "names.nsf", False)
'    If db Is Nothing Then
'        MsgBox "不能读取公用通讯录！"
'        Exit Sub
'    End If
'    Dim view As NotesView
'    Set view = db.GetView("Groups")
'    Dim doc As NotesDocument
'    Set doc = view.GetFirstDocument
'    Dim v, strName As String
'    Do While Not (doc Is Nothing)
'        If doc.GetItemValue("GroupType")(0) = 0 Then
'            ReDim Preserve mGroup(0 To i)
'            strName = doc.GetItemValue("ListName")(0)
'            If strName <> "LocalDomainServers" And _
'                strName <> "OtherDomainServers" Then
'                mGroup(i) = strName & "[群组]"
'                v = doc.GetItemValue("Members")
'                mGroupCol.Add v, mGroup(i)
'                i = i + 1
'            End If
'        End If
'        Set doc = view.GetNextDocument(doc)
'    Loop
End Sub

Public Function getDatabase(ADBName As String) As Object
'    If Not mIsInit Then Init
'    On Error GoTo ErrHandler
'    Dim strDBPath As String
'    strDBPath = getDBPath(ADBName)
'    Set getDatabase = mSession.getDatabase(WFServer, strDBPath)
'ErrHandler:
    
End Function
Public Function DelWorkflow(WFName As String) As Boolean
    If Not mIsInit Then Init
    On Error GoTo ErrHandler
    Dim strSearch As String
    Dim fwp As New ADODB.Recordset
    Dim fwpid As String
    strSearch = "select * from fwp_basicinfo where WFName = '" & WFName & "'"
    'strSearch = "DELETE from fnp_autoagent"
    '先根据工作流名称找到工作流编号，根据编号找到对应的多条节点，循环删除节点属性，后删除对应的全局属性
    'Set fwp = cn.Execute(strSearch)
    fwp.Open strSearch, cn, 1, 2
    If fwp.RecordCount > 0 Then
        Do While Not fwp.EOF
        If fwp("WFStatus") = "E" Then
            fwp("WFStatus") = "U"
            fwp.Update
        End If
            fwp.MoveNext
        Loop
    End If
    fwp.Close
    Set fwp = Nothing
    DelWorkflow = True
    Exit Function
ErrHandler:
    DelWorkflow = False
End Function

Public Function getGroupPeople(GroupName As String)
'    Dim a, b, v, p() As String
'    On Error GoTo ErrHandler
'    v = mGroupCol(GroupName)
'    Dim i As Long, j As Long, cnt As Long, strName As String
'    ReDim p(cnt)
'    For i = LBound(v) To UBound(v)
'        ReDim Preserve p(0 To cnt)
'        strName = getNotesName(v(i))
'        If isPeople(strName) Then
'            p(cnt) = strName & "[个人]"
'            Else
'            p(cnt) = strName & "[群组]"
'        End If
'        cnt = cnt + 1
'    Next i
'    getGroupPeople = p
'    Exit Function
'ErrHandler:
    
End Function

Public Function getRoles() As String()
'    If Not mIsInit Then Init
'    If UBound(mRoles) > 0 Then
'        getRoles = mRoles
'        Exit Function
'    End If
'    Dim db As NotesDatabase
'    Dim i As Long
'    i = 0
'    ReDim mRoles(0) '初始化数组防止下标越界
'    Set db = mSession.getDatabase(SysServer, mSysDBName, False)
'    If db Is Nothing Then
'        MsgBox "不能读取系统配置库！"
'        getRoles = mRoles
'        Exit Function
'    End If
'    Dim view As NotesView
'    Set view = db.GetView("vConfig_Role")
'    Dim doc As NotesDocument
'    Set doc = view.GetFirstDocument
'    Dim v, strName As String
'    Do While Not (doc Is Nothing)
'        strName = doc.GetItemValue("rolename")(0)
'        If strName <> "" Then
'            ReDim Preserve mRoles(0 To i)
'            mRoles(i) = strName
'        End If
'        Set doc = view.GetNextDocument(doc)
'    Loop
'    getRoles = mRoles
End Function

Private Property Get WFServer()
    If mWFServer <> "本地" Then
        WFServer = mWFServer
    End If
End Property

Private Property Get SysServer()
    If mSysServer <> "本地" Then
        SysServer = mSysServer
    End If
End Property

Private Function isPeople(AName As String) As Boolean
    Dim i As Long
    isPeople = True
    For i = LBound(mPeople) To UBound(mPeople)
        If AName = mPeople(i) Then Exit Function
    Next i
    isPeople = False
End Function
Private Function ReadConfig(ConfigFile As String) As String()  '将登陆信息写到配置文件中
    Dim i As Long
    Dim j() As String
    ReDim j(0 To 5)
    Open ConfigFile For Input As #1 ' 打开文件。
    i = 0
    Do While Not EOF(1) ' 循环至文件尾。
        Line Input #1, j(i) ' 读入一行数据并将其赋予某变量。
        i = i + 1
        If i = 6 Then Exit Do '防止越界
    Loop
    Close #1 ' 关闭文件。
    ReadConfig = j
End Function
Private Sub SaveConfig(cfgInfo() As String, path As String) '将登陆信息写到配置文件中
    Open path For Output As #1
    Print #1, "IP$" + cfgInfo(0)
    Print #1, "DSN$" + cfgInfo(1)
    Print #1, "Database$" + cfgInfo(2)
    Print #1, "port$" + cfgInfo(3)
    Print #1, "User$" + cfgInfo(4)
    Print #1, "password$" + cfgInfo(5)
    Close #1
End Sub
Public Function getPath() As String
Dim path As String
    If Right$(App.path, 1) <> "\" Then   '获取文件路径
        path = App.path & "\" & "flow.ini"
    Else
        path = App.path & "flow.ini"
    End If
    getPath = path
End Function
Public Function ConnectToServer(connstr() As String) As Boolean
On Error GoTo error1
    Dim strConnect As String
    strConnect = "driver=" + connstr(1) + ";" & _
                 "server=" + connstr(0) + ";" & _
                 "database=" + connstr(2) + ";" & _
                 "port=" + connstr(3) + ";" & _
                 "uid=" + connstr(4) + ";" & _
                 "pwd=" + connstr(5)
   cn.CursorLocation = adUseClient   '游标指向服务器游标
    cn.ConnectionString = strConnect
    cn.Open  '连接数据库
    ConnectToServer = True
   Exit Function

error1:
    MsgBox "连接发生错误" & Err.Description & "错误代码" & Err.Number
    ConnectToServer = False
End Function