VB开发的ERP系统

Private Sub CxbbGrid_BeforeMoveColumn(ByVal Col As Long, Position As Long)           '网格列发生移动时自动交换网格索引信息
 
    
End Sub

Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)                '网格格式调整(Fixed)
    Dim iSumEndCol As Integer
    Select Case Button.Key
       Case "szxsxm"                                        '设置显示项目
        Dim frm As New Qr_ShowItemsFrm
        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)
    
    Select Case Button.Key
    Case "ymsz"                                          '页面设置
        Dyymctbl.Show 1
    Case "yl"                                            '预 览
        bbyl (True)
    Case "dy"                                            '打 印
        bbyl (False)
    Case "cx"                                            '查 询
        Qr_RsBscCndFrm.Show 1
    Case "edit"
        CxbbGrid_DblClick
    Case "Order" '排序
        Dim frm As New Order_Frm
        With frm
            .Show 1
            If .bOrder = True Then
                If Trim(.str_SQLOrderBy) = "" Then
                    sSqlOrder = " Order by Rs_BasicInfo.EmpNo "
                Else
                    sSqlOrder = .str_SQLOrderBy
                End If
                ShowRecord Me.sSqlWhere
            End If
        End With
        Set frm = Nothing
    Case "Locate"
        With Locate_Frm
            Set .frm = Me
            .Show 1
        End With
    Case "Refresh"      '刷新
        ShowRecord sSqlWhere
    Case "bz"                                            '帮 助
        Call F1bz
    Case "fh"                                            '退 出
        Unload Me
    End Select
    
    
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) <> 1 Then
            MsgBox "无法找到工号和姓名列,定位失败!", vbOKOnly + vbCritical
            Exit Function
        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
                            '.Cell(flexcpBackColor, .Row, .FixedCols, .Row, .Cols - 1) = &HFFC0C0
                            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

Public Function ShowRecord(sWhere As String)                                    '生成查询结果(Define)
    '显示数据
Dim sExec As String
Dim j As Integer
    On Error GoTo ErrCtrl
    
    
    Dim rs As New ADODB.Recordset
    Dim s As String
    Dim i As Long
    
    If Trim(sSqlWhere) = "" Or Trim(sSqlFrom) = "" Then
        Exit Function
    End If
    Me.MousePointer = 11
    sExec = " select Rs_BasicInfo.EmpID  as Rs_BasicInfo#EmpID " & Chr(10)
    
    ReDim sFieldValue(0)
    sFieldValue(0).FieldValueName = ""

    
    s = "select rtrim(TableName) as TableName " & Chr(10) _
        & ",rtrim(FieldName) as FieldName " & Chr(10) _
        & ",Width as FieldWidth " & Chr(10) _
        & ",FieldLength as FieldLength " & Chr(10) _
        & ",FieldDotL as FieldDotL " & Chr(10) _
        & ",YnShow as FieldIsShow " & Chr(10) _
        & ",FieldType as FieldType " & Chr(10) _
        & ",rtrim(ChName) as FieldNameC " & Chr(10) _
        & ",rtrim(CorTable) as CorTable " & Chr(10) _
        & ",rtrim(IndexCode) as IndexCode " & Chr(10) _
        & ",rtrim(IndexName) as IndexName " & Chr(10) _
        & "from  Rs_Items  " & Chr(10) _
        & "where (SID=1 or Rs=1) and FieldName<>'Pic' " _
        & "Order by Tab "


    '填充报表的其他字段信息
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    With rs
        Do While Not .EOF()
            If sFieldValue(0).FieldName <> "" Then
                ReDim Preserve sFieldValue(UBound(sFieldValue) + 1)
            End If
            sFieldValue(UBound(sFieldValue)).FieldNameC = Trim(!FieldNameC)
            sFieldValue(UBound(sFieldValue)).FieldType = Trim(!FieldType)
            sFieldValue(UBound(sFieldValue)).FieldName = Trim(!TableName) & "." & Trim(!FieldName)
            sFieldValue(UBound(sFieldValue)).FieldWidth = Val(!FieldWidth & "")
            sFieldValue(UBound(sFieldValue)).FieldIsShow = !FieldIsShow
            sFieldValue(UBound(sFieldValue)).FieldLengthInt = !FieldLength - !FieldDotL
            sFieldValue(UBound(sFieldValue)).FieldLengthFra = !FieldDotL
            If Trim(!CorTable) <> "" Then
                sFieldValue(UBound(sFieldValue)).FieldValueName = Trim(!TableName) & "#" & Trim(!FieldName) & "#N"
                sExec = sExec & ", " & sFieldValue(UBound(sFieldValue)).FieldValueName & " =" _
                 & "(select " & Trim(!IndexName) & " from " & Trim(!CorTable) & " a where a." & Trim(!IndexCode) & "=" & Trim(!TableName) & "." & Trim(!FieldName) & ")" & Chr(10)
            Else
                sFieldValue(UBound(sFieldValue)).FieldValueName = Trim(!TableName) & "#" & Trim(!FieldName)
                sExec = sExec & ", " & sFieldValue(UBound(sFieldValue)).FieldName & " as " & sFieldValue(UBound(sFieldValue)).FieldValueName
            End If
            
            .MoveNext
        Loop
    End With
    rs.Close
        
    With Me.CxbbGrid
        '初始化网格
        .Redraw = False
        .Cols = Qslz
        .Cols = UBound(sFieldValue) + 1 + Qslz + 1
        .FixedCols = Qslz + 1
        .Rows = .FixedRows
        
        For i = Qslz + 1 To .Cols - 1
            .ColWidth(i) = (sFieldValue(i - Qslz - 1).FieldLengthInt + sFieldValue(i - Qslz - 1).FieldLengthFra) * 105
            .TextMatrix(.FixedRows - 1, i) = sFieldValue(i - Qslz - 1).FieldNameC
            .ColHidden(i) = IIf(sFieldValue(i - Qslz - 1).FieldIsShow, False, True)
            If sFieldValue(i - Qslz - 1).FieldType = DATA_NUMERIC Then
                .ColAlignment(i) = flexAlignRightCenter
                .ColFormat(i) = IIf(sFieldValue(i - Qslz - 1).FieldLengthFra = 0, "#,##0", "#,##0." & String(sFieldValue(i - Qslz - 1).FieldLengthFra, "0"))
            Else
                .ColAlignment(i) = flexAlignLeftCenter
                .ColFormat(i) = ""
            End If
            If UCase(sFieldValue(i - Qslz - 1).FieldName) = UCase("Rs_BasicInfo.YnStop") Then
                .ColDataType(i) = flexDTBoolean
            End If
            .FixedAlignment(i) = flexAlignCenterCenter
        Next i
        .ColWidth(Qslz) = 1000
        .ColAlignment(Qslz) = flexAlignRightCenter
        .ColFormat(Qslz) = ""
        .FixedAlignment(Qslz) = flexAlignCenterCenter
        .TextMatrix(.FixedRows - 1, Qslz) = "编号"
        
        sExec = sExec & Me.sSqlFrom & Me.sSqlWhere & sSqlOrder
'-----------------------------------------------
        Ed_EmpArInfoFrm.QuerySql = sExec
'-----------------------------------------------
        
        Set rs = Cw_DataEnvi.DataConnect.Execute(sExec)
        .Rows = .FixedRows + rs.RecordCount

        '初始化进度条
        Me.PB_Proc.Min = .FixedRows
        Me.PB_Proc.Max = .Rows + 1
        Me.PB_Proc.Value = Me.PB_Proc.Min
        Me.PB_Proc.Visible = True
        '填充数据
        For i = .FixedRows To .Rows - 1
            .RowHeight(i) = Sjhgd
            Me.PB_Proc.Value = i
            For j = Qslz + 1 To .Cols - 1
                If sFieldValue(j - Qslz - 1).FieldType = DATA_DATE Then
                    .TextMatrix(i, j) = Format(Trim(rs.Fields(Trim(sFieldValue(j - Qslz - 1).FieldValueName)) & ""), "yyyy-mm-dd")
                Else
                    .TextMatrix(i, j) = Trim(rs.Fields(Trim(sFieldValue(j - Qslz - 1).FieldValueName)) & "")
                End If
            Next j
            .TextMatrix(i, 0) = rs.Fields("Rs_BasicInfo#EmpID")
            .TextMatrix(i, Qslz) = i - .FixedRows + 1
            rs.MoveNext
        Next i
        rs.Close
        Me.PB_Proc.Visible = False
        .Redraw = True
    End With
    Set rs = Nothing
    Me.MousePointer = 0
    Exit Function
    
ErrCtrl:
    If rs.State = 1 Then
        rs.Close
    End If
    Set rs = Nothing
    Me.PB_Proc.Visible = False
    Me.CxbbGrid.Redraw = True
    Me.MousePointer = 0
    
End Function

Private Sub bbyl(bbylte As Boolean)                    '报表打印预览
    
    Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
    Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
    Bbxbtgs = 1                                         '报 表 小 标 题 行 数
    Bbbwhgs = 0                                          '报 表 表 尾 行 数
    ReDim Bbxbt(1 To Bbxbtgs)
    ReDim bbxbtzzxs(1 To Bbxbtgs)
    If Bbbwhgs <> 0 Then
        ReDim Bbbwh(1 To Bbbwhgs)
        ReDim Bbbwhzzxs(1 To Bbbwhgs)
    End If
    Bbzbt = ReportTitle
    
    bbxbtzzxs(1) = 0                                     '报表行组织形式(0-居左 1-居中 2-居右)
    Call Scyxsjb(CxbbGrid)                               '生成报表数据
    Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
    If Not bbylte Then
        Unload DY_Tybbyldy
    End If
    
End Sub