oaminmodu.bas

一个OA办公自动化管理系统

Attribute VB_Name = "OAMinModu"
Option Explicit
Public CNLinkString As String, GMainDBCNClient As New ADODB.Connection, GMainDBCNServer As New ADODB.Connection, GMainDBCN As New ADODB.Connection
Public LocalLinkString As String, GMainDBCNLocal As New ADODB.Connection
Public PubOAKey As String, PubOAParentKey As String
Public GLanguageID As String, EmailStyle As Integer, intMax As Integer
Public LoginName As String, LinkServerName As String
Public PubOAEmailID As String, strAccountName As String, intIsOA As Integer, FLowBillNo As String, strAccountID As String
Public strBillType As Integer, strBillNo As String
Public strInvInfo As String
'Public Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
Declare Function getComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Sub Main()

   ' LocalLinkString = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source= " & App.Path & "\sysGALAXY.mdb"
   ' MsgBox "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=D:\Galaxy\sysGALAXY.mdb"
    GLanguageID = "1"
    
    FrmFLash.Show
    frmSelectAccount.Show 1
    '
    'Err_Main:
    '    Exit Sub
    '
    ''    IEBOX.Navigate App.Path & "\PubOAWelcome.vbd"
    'MoneyMain
    ''    IEBOX.Visible = True
    
End Sub
    
Public Function LocalComputerName() As String
    Dim i As Integer, s$
    On Error GoTo Err_getComputerName
    i = 1
    s$ = String$(20, 0)
    Dim dl&
    Dim sz&
    sz& = 20
    dl& = getComputerName(s$, sz)
    LocalComputerName = ""
    
    If dl& = 0 Then Exit Function
    
    For i = 1 To 20
        If Mid(s$, i, 1) <> Chr(0) Then
            LocalComputerName = LocalComputerName & Mid(s$, i, 1)
        Else
            Exit For
        End If
    Next
    
    Exit Function
    
Err_getComputerName:
    MisMsg "LocalComputerName Error :" & Err.Description
    LocalComputerName = ""
    Exit Function
End Function


Public Function GetCNClient() As ADODB.Connection
    
    On Error GoTo Err_GetCNClient
    If GMainDBCNClient.State = 0 Then
       GMainDBCNClient.CursorLocation = adUseClient
       GMainDBCNClient.Open CNLinkString
    End If
    Set GetCNClient = GMainDBCNClient
    
Exit_GetCNClient:
    Exit Function
Err_GetCNClient:
    MisMsg "GetCNClient Error: 数据库不能连接!" & Err.Description
    End
End Function
Public Function GetCNServer() As ADODB.Connection
    
    On Error GoTo Err_GetCNServer
    If GMainDBCNServer.State = 0 Then
       GMainDBCNServer.CursorLocation = adUseServer
       GMainDBCNServer.Open CNLinkString
    End If
    Set GetCNServer = GMainDBCNServer
    
Exit_GetCNServer:
    Exit Function
Err_GetCNServer:
    MisMsg "GetCNServer Error: 数据库不能连接!" & Err.Description
    End
End Function

Public Function GetCNMain() As ADODB.Connection
    
    On Error GoTo Err_GetCNMain
    If GMainDBCN.State = 0 Then
       GMainDBCN.CursorLocation = adUseClient
       'GMainDBCN.Open "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source= " & App.Path & "\AccountName.mdb"
       GMainDBCN.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source= " & App.Path & "\AccountName.mdb"
    End If
    Set GetCNMain = GMainDBCN
Exit_GetCNMain:
    Exit Function
Err_GetCNMain:
    MisMsg "GetCNMain Error: 数据库不能连接!" & Err.Description
    End
End Function
Public Function GetCNLocal() As ADODB.Connection
    
    On Error GoTo Err_GetCNLocal
    If GMainDBCNLocal.State = 0 Then
       GMainDBCNLocal.CursorLocation = adUseClient
       GMainDBCNLocal.Open LocalLinkString
    End If
    Set GetCNLocal = GMainDBCNLocal
Exit_GetCNLocal:
    Exit Function
Err_GetCNLocal:
    MisMsg "GetCNLocal Error: 数据库不能连接!" & Err.Description
    End
End Function

Public Sub GGetResTag(LanguageID As String, FrmForm As Form)
  Dim tObj As Control, i, j As Integer
  On Error GoTo Err_GGetres
  'FrmForm.Caption = LoadResString(FrmForm.Caption & LanguageID)
  FrmForm.BackColor = &HD39E9F
  For Each tObj In FrmForm.Controls
    Select Case Trim(LCase(TypeName(tObj)))
        Case "commandbutton"
           If IsNumeric(tObj.Tag) Then tObj.Caption = LoadResString(Val(tObj.Tag & LanguageID))
           tObj.BackColor = FrmForm.BackColor
        Case "treeview"
        Case "combobox"
        Case "menu"
             If IsNumeric(tObj.Tag) Then tObj.Caption = LoadResString(Val(tObj.Tag & LanguageID))
            
        Case "toolbar"
            For i = 1 To tObj.Buttons.Count
                If tObj.Buttons(i).Tag <> "-" Then
                    If IsNumeric(tObj.Tag) Then tObj.Buttons(i).Caption = LoadResString(Val(tObj.Buttons(i).Tag & LanguageID))
                End If
                For j = 1 To tObj.Buttons(i).ButtonMenus.Count
                    If IsNumeric(tObj.Tag) Then tObj.Buttons(i).ButtonMenus(j).Text = LoadResString(Val(tObj.Buttons(i).ButtonMenus(j).Tag & GLanguageID))
                Next

            Next
        Case "label"
            If IsNumeric(tObj.Tag) Then tObj.Caption = LoadResString(Val(tObj.Tag & LanguageID))
            'tObj.BackStyle = 0
        Case "optionbutton"
            If IsNumeric(tObj.Tag) Then tObj.Caption = LoadResString(Val(tObj.Tag & LanguageID))
            tObj.BackColor = FrmForm.BackColor
        Case "frame"
            If IsNumeric(tObj.Tag) Then tObj.Caption = LoadResString(Val(tObj.Tag & LanguageID))
            tObj.BackColor = FrmForm.BackColor
        Case "checkbox"
            If IsNumeric(tObj.Tag) Then tObj.Caption = LoadResString(Val(tObj.Tag & LanguageID))
            tObj.BackColor = FrmForm.BackColor
        Case "sstab"
            tObj.BackColor = FrmForm.BackColor
            For i = 0 To tObj.Tabs - 1
    
                tObj.TabCaption(i) = LoadResString(Val(tObj.TabCaption(i) & LanguageID))
            Next i
    End Select
  Next tObj
  Exit Sub
Err_GGetres:
    MisMsg "GGetRes Error:" & Err.Description
    Exit Sub
End Sub



Public Sub GGetRes(LanguageID As String, FrmForm As Form)
  Dim tObj As Control, i, j As Integer
  On Error GoTo Err_GGetres
  'FrmForm.Caption = LoadResString(FrmForm.Caption & LanguageID)
  FrmForm.BackColor = &HD39E9F
  For Each tObj In FrmForm.Controls
    Select Case Trim(LCase(TypeName(tObj)))
        Case "commandbutton"
           tObj.Caption = LoadResString(Val(tObj.Caption & LanguageID))
           tObj.BackColor = FrmForm.BackColor
        Case "treeview"
        Case "combobox"
        Case "menu"
            tObj.Caption = LoadResString(Val(tObj.Caption & LanguageID))
            
        Case "toolbar"
            For i = 1 To tObj.Buttons.Count
                If tObj.Buttons(i).Caption <> "-" Then
                    tObj.Buttons(i).Caption = LoadResString(Val(tObj.Buttons(i).Caption & LanguageID))
                End If
                For j = 1 To tObj.Buttons(i).ButtonMenus.Count
                    tObj.Buttons(i).ButtonMenus(j).Text = LoadResString(Val(tObj.Buttons(i).ButtonMenus(j).Text & GLanguageID))
                Next

            Next
        Case "label"
            tObj.Caption = LoadResString(Val(tObj.Caption & LanguageID))
            tObj.BackStyle = 0
        Case "optionbutton"
            tObj.Caption = LoadResString(Val(tObj.Caption & LanguageID))
            tObj.BackColor = FrmForm.BackColor
        Case "frame"
            tObj.Caption = LoadResString(Val(tObj.Caption & LanguageID))
            tObj.BackColor = FrmForm.BackColor
        Case "checkbox"
            tObj.Caption = LoadResString(Val(tObj.Caption & LanguageID))
            tObj.BackColor = FrmForm.BackColor
        Case "sstab"
            tObj.BackColor = FrmForm.BackColor
            For i = 0 To tObj.Tabs - 1
    
                tObj.TabCaption(i) = LoadResString(Val(tObj.TabCaption(i) & LanguageID))
            Next i
    End Select
  Next tObj
  Exit Sub
Err_GGetres:
    MisMsg "GGetRes Error:" & Err.Description
    Exit Sub
End Sub
Public Sub MisMsg(strMsg As String)

     MsgBox strMsg, vbOKOnly + vbExclamation, LoadResString(Val("2674" & GLanguageID))

End Sub

Public Function mis_Entry(FuncID As String, EntryType As Integer) As Integer
On Error GoTo Err_mis_Entry
    Dim rstEntry As Recordset
    Set rstEntry = New Recordset
    mis_Entry = 0
    
    If LoginName = "Admin" Then
        mis_Entry = 1
        Exit Function
    End If
    
    Select Case EntryType
        Case 1
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![AllowNew]
            End If
        Case 2
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![AllowUpdate]
            End If
        Case 3
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![OnlyRead]
            End If
        Case 4
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![Check]
            End If
        Case 5
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![Post]
            End If
    
        Case 6
            rstEntry.Open "Select * from PubOAUserWork where UserID ='" & LoginName & "' and FunctionID='" & FuncID & "'", GetCNClient, adOpenForwardOnly
            If rstEntry.EOF Then
                mis_Entry = 0
            Else
                mis_Entry = rstEntry![rs]
            End If
        Case Else
                mis_Entry = 0
        
    End Select
    
    Exit Function

Err_mis_Entry:
    MisMsg "mis_Entry Error : " & Err.Description
    Exit Function
End Function



Public Function FlowPower(FuncID As String, BillNO As String, PowerID As Integer) As Integer
On Error GoTo Err_FlowPower
    Dim rstFlowPower As Recordset, rstUserWork As Recordset, NewEmailID As String, strTopic As String
    Dim strPower As String
    FlowPower = 0
    'Stop
    Set rstFlowPower = New Recordset
        rstFlowPower.Open " Select * From v_FlowSend Where  FuncID ='" & FuncID & "' and FuncPower='" & PowerID & "' and userID='" & LoginName & "' ", GetCNClient, adOpenForwardOnly
        Do Until rstFlowPower.EOF
            NewEmailID = NewID
            strTopic = LoadResString(Val(rstFlowPower![PowerExplain] & GLanguageID)) & "(" & BillNO & ")|" & LoadResString(Val(rstFlowPower![PowerIDExplain]) & GLanguageID)
            strPower = rstFlowPower![NextFuncID] + "|" + BillNO + "|" & Trim(str(rstFlowPower![NextFuncPower]))
            GetCNLocal.Execute "Insert Into PubOAData( DraftID, SendDate, Addressee,GroupId,TeamID, SendMen, CopyTo, Topic,FuncPower, KeyWord, Summary, Accessory, Style) " _
                             & " Values ('" & NewEmailID & "','" & Format(Now, "yyyy-mm-dd hh:mm:ss") & "','" & rstFlowPower![NextGroupID] + "|" + rstFlowPower![NextTeamID] & "','" & rstFlowPower![NextGroupID] & "','" & rstFlowPower![NextTeamID] & "','" & LoginName & "',' ','" & strTopic & "','" & strPower & "' ,' ',' ',' ',1)"
            
            GetCNClient.Execute "Insert Into PubOAData( DraftID, SendDate, Addressee,GroupId,TeamID, SendMen, CopyTo, Topic,FuncPower, KeyWord, Summary, Accessory, Style) " _