VB开发的ERP系统

    '调 入 网 格(Fixed)
    GridCode = "Pm_RepSalary"
    Call BzWgcsh(CxbbGrid, GridCode, GridInf(), GridBoolean(), GridInt(), GridStr())
    Me.CxbbGrid.RowHidden(0) = True
    Me.CxbbGrid.RowHidden(1) = True
    Me.CxbbGrid.RowHidden(2) = True
    Qslz = GridInf(1)
    Sjhgd = GridInf(2)
    Sfxshjwg = GridInf(7)
    Szzls = CxbbGrid.Cols - 1
    iBeginCol = Val(GridInf(1))
    
    Exit Sub
ErrCtrl:
    MsgBox "初始化错误!", vbOKOnly + vbCritical
    Set Dyymctbl = Nothing
    Unload Me
End Sub

Private Sub Form_Unload(Cancel As Integer)                                  '窗体卸载
        
    '卸载打印页面设置窗体
    Unload Dyymctbl
    Set Dyymctbl = Nothing
    Security_Log "Pm_RepAttend", Xtczybm, 2, False  '用户退出时写上机日志
    
End Sub
Private Function SaveGridFormat() As Boolean '保存格式
    On Error GoTo ErrCtrl
    
    Dim i As Integer
    Dim s As String
    Dim sTable As String
    Dim sField As String
    Dim bBeginTrans As Boolean
    With Me.CxbbGrid
        For i = IIf(iSumEndCol = -1, 0, iSumEndCol) To .Cols - 1
            If GetTableField(Trim(.TextMatrix(1, i)), sTable, sField, ".") = 1 Then
                s = s + " UPDATE PM_ReportItem SET FieldOrder=" & i - iSumEndCol & " ,FieldWidth=" & .ColWidth(i) & " ,FieldIsShow=" & IIf(.ColHidden(i), 0, 1) _
                    & " WHERE TableName='" & sTable & "' AND FieldName='" & sField & "' AND RCode='" & Me.sRCode & "' AND PmSort='" & sPmSort & "' " & Chr(10)
            End If
        Next i
        If Trim(s) <> "" Then
            Cw_DataEnvi.DataConnect.BeginTrans
                bBeginTrans = True
                Cw_DataEnvi.DataConnect.Execute (s)
            Cw_DataEnvi.DataConnect.CommitTrans
            bBeginTrans = False
            SaveGridFormat = True
            MsgBox "格式保存成功!", vnokonly + vbInformation
        End If
    End With
    Exit Function

ErrCtrl:
    If bBeginTrans = True Then
        Cw_DataEnvi.DataConnect.RollbackTrans
    End If
    MsgBox "保存格式失败!", vbOKOnly + vbCritical
End Function
Private Sub CxbbGrid_BeforeMoveColumn(ByVal Col As Long, Position As Long)           '网格列发生移动时自动交换网格索引信息
    '分组汇总列不允许移动
    If Col <= iSumEndCol Then
        Position = Col
        Exit Sub
    End If
    '不允许列超过分组汇总列
    If Position <= iSumEndCol Then
        Position = iSumEndCol + 1
        Exit Sub
    End If
    
End Sub

Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)                '网格格式调整(Fixed)
    Select Case Button.Key
    Case "bcgs"                                          '保存表格格式
        SaveGridFormat
    Case "hfmrgs"                                        '恢复默认格式
        Call Hfmrgs(CxbbGrid, GridCode, GridStr())
    Case "szxsxm"                                        '设置显示项目
        Dim frm As New Salary_ShowItem_Frm
        Set frm.vs = Me.CxbbGrid
        frm.iBeginCol = iSumEndCol + 1
        frm.Show 1
        Set frm = Nothing
    End Select
End Sub

Private Sub SzToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Dim frm As Form
    Select Case Button.Key
    Case "ymsz"                                          '页面设置
        Dyymctbl.Show 1
    Case "yl"                                            '预 览
        PrintGrid Me.CxbbGrid, iBeginCol, iSumEndCol, Me.sRCode, Dyymctbl, Me.Lab_Period.Caption, False
    Case "dy"                                            '打 印
        PrintGrid Me.CxbbGrid, iBeginCol, iSumEndCol, Me.sRCode, Dyymctbl, Me.Lab_Period.Caption, True
    Case "cx"                                            '查 询
        Select Case UCase(Me.sPTableName)
            Case UCase("PM_AttendRecord")
                Set frm = New Query_RepAttend_Frm
            Case UCase("PM_PayRoll")
                Set frm = New Query_RepSalary_Frm
        End Select
        With frm
            .sPTableName = Me.sPTableName
            Set .frmParent = Me
            .sRCode = Me.sRCode
            .Show 1
        End With
        
    Case "Locate"
        Set frm = New Locate_Frm
        With frm
            Set .frm = Me
            .Show 1
        End With
    Case "Refresh"      '刷新数据
        ShowRecord sSqlWhere, sSqlFrom
    Case "Detail"
        Call InitDetail
    Case "Total"
        Call InitTotal
    Case "bz"                                            '帮 助
        Call F1bz
    Case "fh"                                            '退 出
        Unload Me
    End Select
    
    Set frm = Nothing
End Sub
Public Function Locate(sPerson As String) As Integer '根据工号或姓名定位人员,成功返回1,没有找到返回0,错误返回-1
    On Error GoTo ErrCtrl
    
    Dim i As Long, j As Long
    Dim iCol(1) As Integer
    Dim bFound As Boolean
    
    sPerson = UCase(Trim(sPerson))
    With Me.CxbbGrid
        If .Rows = .FixedRows Then
            Exit Function
        End If
        
        If GetCol(sFieldValue, iCol(0), iCol(1), Val(GridInf(1))) <> 1 Then
            MsgBox "无法找到工号和姓名列,定位失败!", vbOKOnly + vbCritical
            GoTo ErrCtrl
        End If
        bFound = False
        For j = 0 To 1
            If iCol(j) >= 0 And bFound = False Then
                 '从当前行的下一行找到末尾
                For i = .Row + 1 To .Rows - 1
                    If UCase(Trim(.TextMatrix(i, iCol(j)))) = sPerson Then
                        bFound = True
                        .Row = i
                        .TopRow = i
                        Exit For
                    End If
                Next i
                '如果没有找到,从数据开始行找到当前行
                If bFound = False Then
                    For i = .FixedRows To .Row
                        If UCase(Trim(.TextMatrix(i, iCol(j)))) = sPerson Then
                            bFound = True
                            .Row = i
                            .TopRow = i
                            Exit For
                        End If
                    Next i
                End If
            End If
        Next j
        If bFound = False Then
            Locate = 0
        Else
            Locate = 1
        End If
    End With
    Exit Function

ErrCtrl:
    Locate = -1
End Function
Private Sub InitDetail()    '显示或隐藏明细列
    On Error Resume Next
    
    Dim i As Integer
    Dim j As Integer
    Dim s As String
    With Me.CxbbGrid
        .Redraw = False
        For j = Qslz To IIf(iSumEndCol = -1, 0, iSumEndCol)
            If Me.SzToolbar.Buttons("Detail").Value = tbrUnpressed Then
                For i = .FixedRows To .Rows - 2
                    If Len(Trim(.TextMatrix(i, j))) >= 3 Then
                        s = Right(Trim(.TextMatrix(i, j)), 3)
                    Else
                        s = .TextMatrix(i, j)
                    End If
                    If s <> "小计:" And s <> "合计:" Then
                        .RowHidden(i) = True
                    End If
                Next i
            Else
                For i = .FixedRows To .Rows - 2
                    If Len(Trim(.TextMatrix(i, j))) >= 3 Then
                        s = Right(Trim(.TextMatrix(i, j)), 3)
                    Else
                        s = .TextMatrix(i, j)
                    End If
                    If s <> "小计:" And s <> "合计:" Then
                        .RowHidden(i) = False
                    End If
                Next i
            End If
        Next j
        .Redraw = True
    End With
End Sub
Private Sub InitTotal() '显示或隐藏合计列
    On Error Resume Next
    
    Dim i As Integer
    Dim j As Integer
    Dim s As String
    
    With Me.CxbbGrid
        .Redraw = False
        For j = Qslz To IIf(iSumEndCol = -1, 0, iSumEndCol)
            If .FixedRows = .Rows Then Exit Sub
            If Me.SzToolbar.Buttons("Total").Value = tbrUnpressed Then
                For i = .FixedRows To .Rows - 1
                    If Len(Trim(.TextMatrix(i, j))) >= 3 Then
                        s = Right(Trim(.TextMatrix(i, j)), 3)
                    Else
                        s = ""
                    End If
                    If s = "小计:" Or s = "合计:" Then
                        .RowHidden(i) = True
                    End If
                Next i
            Else
                For i = .FixedRows To .Rows - 1
                    If Len(Trim(.TextMatrix(i, j))) >= 3 Then
                        s = Right(Trim(.TextMatrix(i, j)), 3)
                    Else
                        s = ""
                    End If
                    If s = "小计:" Or s = "合计:" Then
                        .RowHidden(i) = False
                    End If
              Next i
            End If
        Next j
        .Redraw = True
    End With
End Sub
Public Function ShowRecord(sWhere As String, sFrom As String)                                    '生成查询结果(Define)
    On Error GoTo ErrCtrl
    
    Dim rs As New ADODB.Recordset
    Dim s As String
    Dim sTable As String
    Dim sField As String
    Dim Ssql As String
    Dim i As Long
    
    If Trim(sWhere) = "" Or Trim(sFrom) = "" Then
        GoTo ErrCtrl
    End If
    Me.MousePointer = 11
    sExec = " SELECT 1 "
    
    ReDim sFieldValue(0)
    sFieldValue(0).FieldName = ""
    If Trim(Me.sGroupField) = "" Then '没有分组字段
        s = "SELECT rtrim(a.TableName) AS TableName " & Chr(10) _
            & ",rtrim(a.FieldName) AS FieldName " & Chr(10) _
            & ",rtrim(a.FieldWidth) AS FieldWidth " & Chr(10) _
            & ",rtrim(b.FieldLength) AS FieldLength " & Chr(10) _