modexport.bas

工资发放条输出程序

                    strCol1 = ConverCol(y + 1)
                    strCol2 = strCol1
                    
                    '工资项目输出
                    Select Case gvarItemTitle(1, y)
                        Case "人员编号"
                            gobjExcel.Range(strCol1 & strRow1).FormulaR1C1 = "人员编号"
                        Case "姓名"
                            gobjExcel.Range(strCol1 & strRow1).FormulaR1C1 = "姓名"
                        Case Else
                            gobjExcel.Range(strCol1 & strRow1).FormulaR1C1 = gvarItemTitle(0, y)
                    End Select
                    
                    '工资数据输出
                    Select Case gvarItemTitle(1, y)
                        Case "人员编号"
                            gobjExcel.Range(strCol2 & strRow2).FormulaR1C1 = !cPsn_Num
                        
                        Case "姓名"
                            gobjExcel.Range(strCol2 & strRow2).FormulaR1C1 = !cPsn_Name
                        Case Else
                            gobjExcel.Range(strCol2 & strRow2).FormulaR1C1 = IIf(StripExpr(gvarItemTitle(1, y)) = 0, "", StripExpr(gvarItemTitle(1, y)))
                    End Select
                    
                    DoEvents
                Next y
                
                '格式化
                Call FormatSheet(strCol1, strRow1, strCol2, strRow2)
                
                '移动记录
                .MoveNext
                
            Next x
            
            Screen.MousePointer = vbDefault
        
        End If
    End With
        
    rstTemp.Close
    Set rstTemp = Nothing
    
    Exit Sub
    
ExportListErr:
    Screen.MousePointer = vbDefault
    If Not rstTemp Is Nothing Then Set rstTemp = Nothing
    MsgBox Err.Description, vbCritical + vbOKOnly, "错误"
    

End Sub



'------------------------------------------------------------
'格式化表格:列宽/表格线
'------------------------------------------------------------
Sub FormatSheet(strCol1 As String, strRow1 As String, strCol2 As String, strRow2 As String)
    
        With gobjExcel
            '调整适合列宽
            .Columns("A:" & strCol2).EntireColumn.AutoFit
        
            '设置表格线
            .Range("A" & strRow1 & ":" & strCol2 & strRow2).Select
            .Selection.Borders(5).LineStyle = -4142
            .Selection.Borders(6).LineStyle = -4142
        
            With .Selection.Borders(7)
                .LineStyle = 1
                .Weight = 2
                .ColorIndex = -4105
            End With
            With .Selection.Borders(8)
                .LineStyle = 1
                .Weight = 2
                .ColorIndex = -4105
            End With
            With .Selection.Borders(9)
                .LineStyle = 1
                .Weight = 2
                .ColorIndex = -4105
            End With
            With .Selection.Borders(10)
                .LineStyle = 1
                .Weight = 2
                .ColorIndex = -4105
            End With
            With .Selection.Borders(11)
                .LineStyle = 1
                .Weight = 2
                .ColorIndex = -4105
            End With
            With .Selection.Borders(12)
                .LineStyle = 1
                .Weight = 2
                .ColorIndex = -4105
            End With
    End With


End Sub

'------------------------------------------------------------
'将指定的列数转换成表示列数的字符串
'------------------------------------------------------------
Function ConverCol(Col As Long) As String

    Dim str0 As String
    Dim str1 As String
    Dim str2 As String

    str0 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    
    '计算列1
    If (Col - 1) \ 26 > 0 Then
        str1 = Mid(str0, (Col - 1) \ 26, 1)
    Else
        str1 = ""
    End If

    '计算列2
    If Col Mod 26 > 0 Then
        str2 = Mid(str0, Col Mod 26, 1)
    Else
        str2 = "Z"
    End If
    
    '返回转换结果
    ConverCol = Trim(str1) + Trim(str2)
    
End Function

'------------------------------------------------------------
'分解工资发放条公式求出字段值
'------------------------------------------------------------
Function StripExpr(strExpression As Variant) As Double
    Dim Optr() As String        '操作符
    Dim Opnd() As Double        '操作数或运算结果
    
    Dim w As String             '标志位
    Dim strExp As String        '公式
    Dim strFieldName As String  '字段名称
    Dim dobFieldValue As Double '字段值
    
    Dim i As Long               '位置计数器
    Dim x As Long               '操作符计数器
    Dim y As Long               '操作数计数器
    
    '公式=需计算公式+结束符"#"
    strExp = strExpression & "#"

'分解公式:操作符() + 操作数()
    Do
        
        i = i + 1
        w = Mid(strExp, i, 1)
        
        '标志位="+" 或则 "-"
        If w = "+" Or w = "-" Then
            
            '弹入操作符
            x = x + 1
            ReDim Preserve Optr(x)
            Optr(x) = w
            
            '获得字段名称
            strFieldName = GetItemField(Left(strExp, i - 1))
            '获得字段值
            dobFieldValue = IIf(IsNull(rstTemp.Fields(strFieldName)), 0, rstTemp.Fields(strFieldName))
            
            '弹入操作数
            y = y + 1
            ReDim Preserve Opnd(y)
            Opnd(y) = dobFieldValue
            
            '分解公式字符串
            strExp = Mid(strExp, i + 1, Len(strExp))
            i = 0
            
        End If
        
        '标志位="#"表示结束
        If w = "#" Then
            
            '弹入操作符
            x = x + 1
            ReDim Preserve Optr(x)
            Optr(x) = w
            
            '获得字段名称
            strFieldName = GetItemField(Left(strExp, i - 1))
            '获得字段值
            dobFieldValue = IIf(IsNull(rstTemp.Fields(strFieldName)), 0, rstTemp.Fields(strFieldName))
            
            '弹入操作数
            y = y + 1
            ReDim Preserve Opnd(y)
            Opnd(y) = dobFieldValue
            
        End If
    
    Loop Until w = "#"
    
'计算公式
    For i = 1 To UBound(Optr())
        
        '结束符
        If Optr(i) = "#" Then Exit For
        
        '求和并弹入运算结果
        If Optr(i) = "+" Then Opnd(i + 1) = Opnd(i) + Opnd(i + 1)
        
        '相减并弹入运算结果
        If Optr(i) = "-" Then Opnd(i + 1) = Opnd(i) - Opnd(i + 1)
    
    Next i

    '返回公式解
    StripExpr = Opnd(y)
        
End Function

'------------------------------------------------------------
'按工资项目标题获得工资项目字段名
'------------------------------------------------------------
Function GetItemField(strItemTitle As Variant) As String
    Dim i As Integer
    
    Select Case strItemTitle
        Case "应发合计"     '系统默认项目
            GetItemField = "F_1"
        
        Case "扣款合计"     '系统默认项目
            GetItemField = "F_2"
        
        Case "实发合计"     '系统默认项目
            GetItemField = "F_3"
        
        Case Else           '其他项目
            '根据工资项目确定字段名称: "F_"+编号
            For i = 0 To UBound(gvarItem, 2)
                If gvarItem(0, i) = strItemTitle Then
                    GetItemField = "F_" & Trim(gvarItem(1, i))
                    Exit For
                End If
            Next i
    End Select
        
End Function