mdlfunction.bas

朋友给的

Attribute VB_Name = "mdlFunction"
Option Explicit

'==============
'全局常量
'==============
Public Const APPLICATION_TITLE = "员工考勤管理系统"               '应用程序标题
Public Const DATABASE_FILE_NAME = "InOut.mdb"               'Access数据库名称"
Public Const APPLICATIONNAME As String = "SOFTWARE\员工考勤管理系统"   '应用程序键值
Public Const KEY_FIRSTCHAR = "a"
Public Const TAG_SELECT = "Select"
Public Const TAG_FATHER = "Father"
'===============
'全局变量
'===============
Public intErrLogFileHandle As Integer

Public gGroup               As String
Public gCurUser             As String

Function ErrMessage(Optional frmName As Form, Optional ctlName As Control)
'===========================
'提示错误信息,有待进一步完善
'===========================
    Screen.MousePointer = 0
    Dim strErr As String
    Dim i As Integer
    
    If gCnn.Errors.count <> 0 Then
        For i = 0 To gCnn.Errors.count - 1
            Select Case gCnn.Errors(i).NativeError
            Case 2627
                strErr = strErr & vbCrLf & "这条记录重复." & vbCrLf
            Case 3621
                strErr = strErr & vbCrLf & "操作已被终止..." & vbCrLf
            Case 3206
                strErr = strErr & vbCrLf & "备份文件不存在." & vbCrLf
            Case 547
                strErr = strErr & vbCrLf & "不能删除，数据库中尚存在与该条记录相关的数据."
            Case 3013
                strErr = strErr & vbCrLf & "备份、恢复的操作被终止." & vbCrLf
            Case -105121349
                strErr = strErr & vbCrLf & "关键字(如代号)重复,请重新输入."
            Case 37
                strErr = strErr & vbCrLf & "操作失败."
            Case Else
                strErr = strErr & vbCrLf & gCnn.Errors(i).Description & vbCrLf

            End Select
        Next i
        If strErr = "" Then
            MsgBox "应用程序生下列错误：" & vbCrLf & "错误描述：" & Err.Description & "." _
                , vbCritical, "发生错误"
        Else
            MsgBox strErr, vbInformation, "发生错误"
        End If
        gCnn.Errors.Clear
    Else
        If Err.Number = 0 Then
            Exit Function
        End If
        Select Case Err.Number
        Case -2147217900
                MsgBox "数据库正在被别人使用，请稍候进行此操做！"
                Exit Function
        Case 70
            MsgBox "数据库正在被别人使用，请稍候进行此操做！"
            Exit Function
        Case -2147467259
            MsgBox "关键字(如代号)重复,请重新输入."
        Case Else
            MsgBox "应用程序发生下列错误：" & vbCrLf & "错误号：" & Err.Number & vbCrLf & "错误描述：" & Err.Description & "." _
                , vbCritical, "发生错误"
        End Select
    End If
    Exit Function
End Function

Public Function UpdateData(strsql As String, Optional DestinationID As String, Optional strType As String = "MM", Optional SourceID As String) As Boolean
'=====================================
'更新数据库,一定使用SQL语句,调用本函数
'=====================================
    On Error GoTo Err_Handle
    
    Dim strS As String
    gCnn.Execute strsql
    Dim rstSQL As ADODB.Recordset
    Set rstSQL = New ADODB.Recordset
    With rstSQL
        .Open "select * from syssql", gCnn, adOpenKeyset, adLockOptimistic, adCmdText
        .AddNew
        .Fields("sqls") = strsql
        .Fields("执行时间") = Format(Date + Time, "yyyy-mm-dd hh:mm:ss")
        .Fields("执行人") = "???"
        .Update
    End With
    rstSQL.Close
    
    UpdateData = True
    Exit Function
Err_Handle:
    UpdateData = False
    ErrMessage
End Function

Public Function FillImageCombo(ImgCmb As ImageCombo, strsql As String) As Long
'===================================================================================
'用SQL语句填充ImageCombo框，第一个为KEY值，第二个为TEXT值
'                           第三个字段开始保存为TAG值,Field1+Chr(6)+Field2+chr(6)+.....+Fieldn+chr(6)
'===================================================================================
    On Error GoTo Err_Handle
    Dim rstx As ADODB.Recordset
    Dim i As Long
    ImgCmb.ComboItems.Clear
    Set rstx = New ADODB.Recordset
    rstx.CursorType = adOpenStatic
    rstx.LockType = adLockReadOnly
    rstx.CursorLocation = adUseClient   '加上这一句
    rstx.Open strsql, gCnn, , , adCmdText
    
    If rstx.RecordCount > 0 Then
        While Not rstx.EOF
            ImgCmb.ComboItems.Add , KEY_FIRSTCHAR & rstx(1) & "", rstx(1) & ""
            For i = 2 To rstx.Fields.count - 1
                ImgCmb.ComboItems(ImgCmb.ComboItems.count).Tag = ImgCmb.ComboItems(ImgCmb.ComboItems.count).Tag & rstx.Fields(i) & Chr(6)
            Next i
            rstx.MoveNext
        Wend
        ImgCmb.Text = "" '.ComboItems(1).Selected = True
    Else
    End If
    rstx.Close
    FillImageCombo = 0
    Exit Function
Err_Handle:
    FillImageCombo = Err.Number
End Function

Function GetParValue(ParName As String) As String
'================
'得到设置的参数值
'================
    Dim rst1 As New ADODB.Recordset, sql As String
    With rst1
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        sql = "select VALUE from [PARAMETERS] where [PARATYPE] =  " & ParName & ""
        .CursorLocation = adUseClient   '加上这一句
        .Open sql, gCnn, , , adCmdText

        If .RecordCount <> 0 Then
            .MoveFirst
            GetParValue = .Fields(0)
        Else
            GetParValue = ""
        End If
        .Close
    End With
End Function

Function SetParValue(ParName As String, ParValue As String)
'==========
'设置参数值
'==========
    Dim rst1 As New ADODB.Recordset, sql As String
    With rst1
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        sql = "select parvalue from syspar where parname='" & ParName & "'"
        .CursorLocation = adUseClient   '加上这一句
        .Open sql, gCnn, , , adCmdText

        If .RecordCount <> 0 Then
            gCnn.Execute "update syspar set [parvalue]='" & ParValue & "' where [parname]='" & ParName & "'"
        Else
            gCnn.Execute "insert into  syspar ([parvalue],[parname]) values ('" & ParValue & "','" & ParName & "')"
        End If
        .Close
    End With
End Function

Sub CopyTreeViewNode(nSource As MSComctlLib.Node, tvDest As TreeView, nDest As MSComctlLib.Node, Optional bOnlyChecked As Boolean = False, Optional iDeepth As Integer = -1)
'---------------------------------
'把 nSource 的子结点都复制到 nDest
'ideepth    -1  所有
'           >0  n层子接点
'---------------------------------
    Dim nF As MSComctlLib.Node, nN As MSComctlLib.Node, nNew As MSComctlLib.Node
    Dim i As Long
    If iDeepth = 0 Then Exit Sub
    If nSource.Children > 0 Then Set nF = nSource.Child
    
    For i = 1 To nSource.Children
        Set nN = nF.Next
        If (nF.Checked = True And bOnlyChecked = True) Or bOnlyChecked = False Then
            Set nNew = tvDest.Nodes.Add(nDest.Key, tvwChild, nF.Key, nF.Text, nF.Image, nF.SelectedImage)
            If nSource.Children > 0 Then
                CopyTreeViewNode nF, tvDest, nNew, bOnlyChecked, IIf(iDeepth = -1, -1, iDeepth - 1)
            End If
        End If
        Set nF = nN
    Next i
End Sub

Sub FillGrid(msfResult As MSFlexGrid, sql As String, Optional cn As ADODB.Connection = Nothing, Optional ShowFields As Integer = 0, Optional BlankRows As Long = 0)
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
'填网格
'前 ShowFields 个字段显示，其它宽度为0
'空行为 BlankRows 行
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    Dim iCnt As Long, i As Long, a As Boolean
    Dim rstx As New ADODB.Recordset
    
    On Error Resume Next
    
    If sql = "" Then
        Exit Sub
    End If
'    rstx.Open "", cn, adOpenStatic, adLockReadOnly
    If cn Is Nothing Then
        Set cn = gCnn
    End If
    '打开记录集
'    rstx.CursorType = adOpenStatic
'    rstx.LockType = adLockReadOnly
'    rstx.CursorLocation = adUseClient   '加上这一句
'    rstx.Open sql, cn, , , adCmdText
    rstx.Open sql, cn, adOpenStatic, adLockReadOnly

    If rstx.EOF Then
        Exit Sub
    End If
    If ShowFields = 0 Then ShowFields = rstx.Fields.count
    '填表头
    With msfResult
        .Rows = 1
        .Row = 0
        .Cols = rstx.Fields.count
        For i = 0 To rstx.Fields.count - 1
            .Col = i
            .Text = rstx.Fields(i).name
            .CellAlignment = flexAlignCenterCenter
            If i >= ShowFields Then .ColWidth(i) = 0
        Next i
    End With
    '填字段
    iCnt = 1
    a = False
    If rstx.RecordCount <> 0 Then
        With rstx
        .MoveFirst
        While Not .EOF
            msfResult.Rows = iCnt + 1
            For i = 0 To rstx.Fields.count - 1
                'msfResult.TextArray(msfResult.Cols * iCnt + i) = NulltoStr(.Fields(i))
                msfResult.TextMatrix(iCnt, i) = Trim(.Fields(i) & "")
            Next i
            .MoveNext
            iCnt = iCnt + 1
            If iCnt = BlankRows Then AdjustGridWidth msfResult: a = True
        Wend
        End With
    End If
    '设置行号
    msfResult.Tag = msfResult.Rows - 1

    If a = False And msfResult.Rows < 1000 Then AdjustGridWidth msfResult

    '填空行
    msfResult.Rows = msfResult.Rows + BlankRows
    '2004-01-18赵朔
    '防止joker位显示出来！去一列！
    If LCase(msfResult.TextMatrix(0, msfResult.Cols - 1)) = "joker" Then
        msfResult.Cols = msfResult.Cols - 1
    End If

    For i = 0 To msfResult.Rows - 1
        If msfResult.RowHeight(i) <= 250 Then
            msfResult.RowHeight(i) = msfResult.RowHeight(i) * 1.2
        End If
    Next i
    '选中最后一行
    'SelRow msfResult, msfResult.Tag + 1
End Sub

Public Function FillGridWithRs(msfObject As MSFlexGrid, rsObject As ADODB.Recordset) As Long
    Dim c As Long
    
    If rsObject.State <> adStateOpen Then
        FillGridWithRs = 0
        Exit Function
    End If
    
    With msfObject
        .Rows = 1
        .Cols = rsObject.Fields.count
        For c = 0 To .Cols - 1
            .ColAlignment(c) = 4
            .TextMatrix(0, c) = rsObject.Fields(c).name
        Next c
        
        Do While Not rsObject.EOF
            .Rows = .Rows + 1
            For c = 0 To .Cols - 1
                .TextMatrix(.Rows - 1, c) = rsObject(c) & ""
            Next c
            rsObject.MoveNext
        Loop
        
        FillGridWithRs = .Rows - 1
    End With
    '2004-01-18赵朔
    '防止joker位显示出来！去一列！
    If LCase(msfObject.TextMatrix(0, msfObject.Cols - 1)) = "joker" Then
        msfObject.Cols = msfObject.Cols - 1
    End If
End Function

Public Sub SetTextMax(frm As Form, cn As ADODB.Connection, strsql As String)
'================================================
'函数说明:并初始化各变量
'返回值:没有返回值
'================================================
    Dim rstMain As New ADODB.Recordset
    
    rstMain.Open strsql, cn, adOpenStatic, adLockReadOnly
    
    Dim i As Long