+

VB开发的ERP系统

        Me.PB_Proc.Value = 0
        Me.PB_Proc.Max = rs.RecordCount + 1
        
        bRefreshData = True '   声明正在刷新数据
        For i = .FixedRows To .Rows - 1
            '相应其他事件
            DoEvents
            '设置进度条
            Me.PB_Proc.Value = Me.PB_Proc.Value + 1
            .RowHeight(i) = GridInf(2)
            .Cell(flexcpBackColor, i, .FixedCols, i, .Cols - 1) = vbWhite
            .TextMatrix(i, 0) = rs.Fields("PM_PayRoll#EmpID")
            For j = iBeginCol To .Cols - 1
                .TextMatrix(i, j) = rs.Fields(Trim(sFields(j - iBeginCol).FieldValueName)) & ""
                If IsNumeric(.TextMatrix(i, j)) And Val(.TextMatrix(i, j)) = 0 Then
                    .TextMatrix(i, j) = ""
                End If
            Next j
            rs.MoveNext
        Next i
        rs.Close
        Me.PB_Proc.Visible = False
        bRefreshData = False '   声明刷新数据完成
        .Redraw = True
    End With
    
    '刷新控制数组
     GridInf(1) = iBeginCol                         '起始列值
     With Me.WglrGrid
        ReDim GridBoolean(.Cols - 1, 1 To 6)
        ReDim GridInt(.Cols - 1, 1 To 7)
        ReDim GridStr(.Cols - 1, 1 To 5)
        For i = 0 To iFixedCols - 1
            GridBoolean(i, 1) = False '网格列是否可编辑
            GridBoolean(i, 2) = False  '网格列是否提供帮助
            GridBoolean(i, 3) = False '网格列是否列表框录入
            GridBoolean(i, 4) = False '网格列是否合计
            GridBoolean(i, 5) = False '网格内容为零是否清空
            GridBoolean(i, 6) = False '网格列是否为布尔型
            GridInt(i, 1) = 0 '字段数据类型
            GridInt(i, 2) = 100 '字段录入长度
            GridInt(i, 3) = 100 '字段整数位长度
            GridInt(i, 4) = 100 '字段小数位长度
            GridInt(i, 5) = 0 '字段不允许为空或为零
            GridInt(i, 6) = 0 '帮助类型
            GridInt(i, 7) = 0 '帮助返回值(0-显示返回编码 1-显示返回名称)
            GridStr(i, 1) = IIf(i - iBeginCol + 1 > 0, Format(i - iBeginCol + 1 > 0, "000"), Format(0, "000")) '网格列索引值
            GridStr(i, 2) = ""  '字段为空提示信息
            GridStr(i, 3) = ""     '通用帮助编码
            GridStr(i, 4) = ""    '连接字段(通用帮助)
            GridStr(i, 5) = ""   '列表框编码
        Next i
        
        For i = .FixedCols To .Cols - 1
            GridBoolean(i, 1) = True '网格列是否可编辑
            GridBoolean(i, 2) = False  '网格列是否提供帮助
            GridBoolean(i, 3) = False '网格列是否列表框录入
            GridBoolean(i, 4) = False '网格列是否合计
            GridBoolean(i, 5) = True '网格内容为零是否清空
            GridBoolean(i, 6) = False '网格列是否为布尔型
            GridInt(i, 1) = 5 '字段数据类型
            GridInt(i, 2) = 0 '字段录入长度
            GridInt(i, 3) = sFields(i - iBeginCol).FieldLengthInt '字段整数位长度
            GridInt(i, 4) = sFields(i - iBeginCol).FieldLengthFra '字段小数位长度
            GridInt(i, 5) = 0 '字段不允许为空或为零
            GridInt(i, 6) = 0 '帮助类型
            GridInt(i, 7) = 0 '帮助返回值(0-显示返回编码 1-显示返回名称)
            GridStr(i, 1) = IIf(i - iBeginCol + 1 > 0, Format(i - iBeginCol + 1 > 0, "000"), Format(0, "000")) '网格列索引值
            GridStr(i, 2) = ""  '字段为空提示信息
            GridStr(i, 3) = ""     '通用帮助编码
            GridStr(i, 4) = ""    '连接字段(通用帮助)
            GridStr(i, 5) = ""   '列表框编码
        Next i
    End With
    Set rs = Nothing
    Me.MousePointer = 0
    Exit Function

ErrCtrl:
    If rs.State = 1 Then
        rs.Close
    End If
    Set rs = Nothing
    Me.WglrGrid.Redraw = True
    Me.MousePointer = 0
End Function

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.WglrGrid
        If .Rows = .FixedRows Then
            Exit Function
        End If
        '取得工号和姓名列
        If GetCol(sFields, iCol(0), iCol(1), Val(GridInf(1))) <> 1 Then
            MsgBox "无法找到工号和姓名列,定位失败!", vbOKOnly + vbCritical
            GoTo ErrCtrl
        End If
        bFound = False
        .Cell(flexcpBackColor, .Row, .FixedCols, .Row, .Cols - 1) = vbWhite
        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
                        .Cell(flexcpBackColor, .Row, .FixedCols, .Row, .Cols - 1) = &HFFC0C0
                        Exit For
                    Else
                        .Cell(flexcpBackColor, i, .FixedCols, i, .Cols - 1) = vbWhite
                    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
                            .Cell(flexcpBackColor, .Row, .FixedCols, .Row, .Cols - 1) = &HFFC0C0
                            Exit For
                        Else
                            .Cell(flexcpBackColor, i, .FixedCols, i, .Cols - 1) = vbWhite
                        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

Public Function ComputeSalary() '计算工资
    On Error GoTo ErrCtrl
    
    Dim s As String
    Dim sSortID As String
    Dim st As String
    Dim rs As New ADODB.Recordset
    
    '取得会计期间
    s = "select Top 1 KjYear,Period FROM GY_Kjrlb WHERE PMjzbz= 0 ORDER BY KjYear,Period  "
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    With rs
        If Not .EOF() Then
            iPeriod = !Period
            iYear = !KjYear
        Else
            MsgBox "当前会计日期未知", vbOKOnly + vbCritical
            Exit Function
        End If
        .Close
    End With
    Set rs = Nothing
    
    Me.MousePointer = 11
    sSortID = GetComboKey(Me.ImgCmb_Sort, 0)
    st = Replace(Me.sSqlWhere & " AND PM_PayRoll.SortID='" & sSortID & "'", "'", "''")
    s = "PM_SP_ComputeSalary " & "'" & sSortID & "'," & iYear & "," & iPeriod & ",'" & st & "'"
    Cw_DataEnvi.DataConnect.Execute (s)
    DoEvents
    Me.MousePointer = 0
    
    '刷新数据
    ShowRecord sSortID
    
    MsgBox "计算完成!", vbOKOnly + vbInformation
    Exit Function
    
ErrCtrl:
    Me.MousePointer = 0
    If rs.State = 1 Then
        rs.Close
    End If
    Set rs = Nothing
    MsgBox "计算出现错误!", vbOKOnly + vbCritical
End Function

Private Sub ImgCmb_Sort_Click()
    Call Tlb_Action_ButtonClick(Me.Tlb_Action.Buttons("Refresh"))
End Sub

Private Sub Tlb_Action_ButtonClick(ByVal Button As MSComctlLib.Button)             '用户点击工具条
    On Error GoTo ErrCtrl
    
    Dim frm As Form
    '屏蔽文本框,下拉组合框有效性判断
    If Not Fun_Drfrmyxxpd Then
        Exit Sub
    End If
    Valilock = True
     
    '屏蔽网格失去焦点产生的有效性判断
     
    Changelock = True
     
    Select Case Button.Key
        Case "ymsz"                                          '页面设置
            Dyymctbl.Show 1
        Case "yl"                                            '预 览
            If Fun_Drfrmyxxpd Then
                Call bbyl(True)
            End If
        Case "dy"                                            '打 印
            If Fun_Drfrmyxxpd Then
                Call bbyl(False)
            End If
        Case "bz"                                            '帮 助
            Call F1bz
        Case "fh"                                            '退 出
            '如果正在刷新数据,则不允许退出
            If bRefreshData = True Then
                Exit Sub
            End If
            Unload Me
        
        Case "Refresh" '刷新
            With Me.ImgCmb_Sort
                If .SelectedItem Is Nothing Then
                    Exit Sub
                End If
                If .SelectedItem.Key = "" Then
                    Exit Sub
                End If
                ShowRecord GetComboKey(Me.ImgCmb_Sort, 0)
            End With
        Case "Query" '查询
            Set frm = New Query_Frm
            Dim coll As New Collection
            With frm
                Set .collTableName = coll
                .Show 1
                If .bChecked = False Then
                    Exit Sub
                End If
                If Trim(.sSqlWhere) = "" Then
                    Me.sSqlWhere = "WHERE  PM_PayRoll.DeptCode in (Select DeptCode FROM PM_OpeDept WHERE Czybm='" & Xtczybm & "') " & Chr(10) _
                        & " AND PM_PayRoll.SortID in (Select SortID FROM PM_OpeSort WHERE Czybm ='" & Xtczybm & "') " & Chr(10)
                Else
                    Me.sSqlWhere = "WHERE   PM_PayRoll.DeptCode in (Select DeptCode FROM PM_OpeDept WHERE Czybm='" & Xtczybm & "') " & Chr(10) _
                        & " AND PM_PayRoll.SortID in (Select SortID FROM PM_OpeSort WHERE Czybm ='" & Xtczybm & "') " & Chr(10) _
                        & " AND " & frm.sSqlWhere
                End If
            End With
            Call Tlb_Action_ButtonClick(Me.Tlb_Action.Buttons("Refresh"))
        Case "Compute" '计算工资
            If Trim(Me.ImgCmb_Sort.Text) = "" Then
                GoTo ErrCtrl
            End If
            ComputeSalary
        Case "Locate" '定位
            If Trim(Me.ImgCmb_Sort.Text) = "" Then
                GoTo ErrCtrl
            End If
            Set frm = New Locate_Frm
            With frm
                Set .frm = Me
                .Show 1
            End With
        Case "Item" '选择项目
            Set frm = New Salary_ShowItem_Frm
            Set frm.vs = Me.WglrGrid
            frm.iBeginCol = GridInf(1)
            frm.Show 1
            Set frm = Nothing
    End Select
    
    Set frm = Nothing
    '解 锁
    Valilock = False
    Changelock = False
    Exit Sub

ErrCtrl:
    Set frm = Nothing
    '解 锁
    Valilock = False
    Changelock = False
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)        '支持热键操作
  
    If Shift = 2 Then
        Select Case UCase(Chr(KeyCode))
            Case "P"                   'Ctrl+P 打印
                If Tlb_Action.Buttons("dy").Enabled Then
                    Call bbyl(False)
                End If
        End Select
    End If
    
End Sub

Private Sub Wbkcl()                                                 '文本框录入之前处理(根据实际情况)
 
    Dim xswbrr As String
    With WglrGrid
        Zdlrqnr = Trim(.Text)
        xswbrr = Trim(.Text)
    
        If GridBoolean(.Col, 3) Then   '列表框录入
    
            '填充列表框程序
            Call FillCombo(YdCombo, GridStr(.Col, 5), xswbrr, 0)
        Else
            Wbkbhlock = True
       
            '====以下为用户自定义
            Ydtext.Text = xswbrr
            '====以上为用户自定义
         
            Wbkbhlock = False
            Ydtext.SelStart = Len(Ydtext.Text)
        End If
    End With
    
End Sub

Private Function sjzdyxxpd(Dqpdwgh As Long, Dqpdwgl As Long)        '录入数据字段有效性判断,同时进行字段录入事后处理
    
    Dim Str_JudgeText As String            '临时有效性判断字段内容
    Dim Coljsq As Long                     '临时列计数器
    Dim RecTemp As New ADODB.Recordset     '临时使用动态集
    Dim Dbl_Qcye As Double                 '临时期初余额
 
    With WglrGrid
    
        '非录入状态有效性为合法
        If Yxxpdlock Or .Row < .FixedRows Then
           sjzdyxxpd = True
           Exit Function
        End If
 
        Str_JudgeText = Trim(.TextMatrix(Dqpdwgh, Dqpdwgl))
        Select Case GridStr(Dqpdwgl, 1)
         
            '以下为自定义部分[
                '1.放置字段有效性判断程序
                    'Case "004"
                    
                '2.放置字段事后处理程序
                
            '以上为自定义部分]
            
        End Select
     
        '字段录入正确后为零字段清空