thismonthsalaryform.frm

VB6.0+Excel+Access,开发的功能强大的员工工资管理系统

VERSION 5.00
Begin VB.Form ThisMonthSalaryForm 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "当月工资细表"
   ClientHeight    =   8115
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   11280
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   8115
   ScaleWidth      =   11280
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消"
      Height          =   495
      Left            =   9360
      TabIndex        =   3
      Top             =   1680
      Width           =   1455
   End
   Begin VB.CommandButton cmdGenerate 
      Caption         =   "生成报表"
      Height          =   495
      Left            =   9360
      TabIndex        =   2
      Top             =   240
      Width           =   1455
   End
   Begin VB.CommandButton cmdPrint 
      Caption         =   "打印报表"
      Height          =   495
      Left            =   9360
      TabIndex        =   1
      Top             =   960
      Width           =   1455
   End
   Begin VB.OLE OLE1 
      AutoActivate    =   0  'Manual
      Height          =   7695
      Left            =   240
      SizeMode        =   2  'AutoSize
      TabIndex        =   0
      Top             =   120
      UpdateOptions   =   1  'Frozen
      Width           =   9015
   End
End
Attribute VB_Name = "ThisMonthSalaryForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'月表的名字
Dim mMonth As String

'Excel报表的行数
Dim mIndex As Integer

'职工ID, SQL语句, 职工统计工资
Dim mEIDs() As String, SQL As String, mSum() As Double

'Excel报表对象
Dim mSheet As Worksheet

'如有必要取消报表生成
Dim mCancelGenerate As Boolean

Private Sub cmdCancel_Click()
    Me.Hide
End Sub

'生成报表
Private Sub cmdGenerate_Click()
    '打开错误处理陷阱
    Dim intErrFileNo As Integer  '自由文件号
    Set gX = GetObject("", "Excel.Application")
    On Error GoTo ErrGoto
    '----------------------------------------------------
    mCancelGenerate = False
    
    '生成职工ID数组
    SQL = "SELECT 职工ID FROM 职工"
    OpenRS (SQL)
    gRst.MoveFirst
    Dim counts As Integer
    gRst.MoveLast
    counts = gRst.RecordCount
    gRst.MoveFirst
    ReDim mEIDs(counts)
    ReDim mSum(counts)
    Dim i As Integer
    i = 0
    While Not gRst.EOF
        i = i + 1
        mEIDs(i) = gRst("职工ID")
        gRst.MoveNext
    Wend
    CloseRS
    
    '新建Excel表格
    gX.Workbooks.Close
    gX.Workbooks.Add
    gX.Visible = True
    Set mSheet = gX.ActiveSheet
    
    '写入细表
    mIndex = 0
    mIndex = mIndex + 1
    mSheet.Cells(mIndex, 1) = mMonth & "细表"
    For i = 1 To counts
        If Not mCancelGenerate Then
            '写入单个职工信息
            writeXL mEIDs(i), i
            mIndex = mIndex + 1
        End If
    Next
    
    '设置显示格式
    mSheet.Columns("A:F").ColumnWidth = 10
    
    '存储文档
    gX.ActiveWorkbook.SaveAs App.Path & "\" & mMonth & "细表.xls"
    
    'OLE显示
    OLE1.CreateLink App.Path & "\" & mMonth & "细表.xls"
    '----------------------------------------------------
    Exit Sub
    '-----------------------------
ErrGoto:
    '把错误信息保存在文件里
    intErrFileNo = FreeFile()
    Open "YFSystem.ini" For Append As intErrFileNo
    Print #intErrFileNo, Chr(34) + Format(Now, "YYYY-MM-DD HH:MM:SS") + Chr(34), Chr(34) + "信息" + Chr(34), Chr(34) + Err.Description + Chr(34), Chr(34) + "cmdGenerate_Click(ThisMonthSalaryForm)" + Chr(34), Chr(34) + App.Title + Chr(34)
    Close #intErrFileNo
End Sub

Private Sub cmdPrint_Click()
    On Error Resume Next
    gX.Workbooks.Open App.Path & "\" & mMonth & "细表.xls"
    Set mSheet = gX.ActiveSheet
    mSheet.PrintOut
    gX.Workbooks.Close
End Sub

Private Sub Form_Load()
    mMonth = Format(Date - 30, "YYYYMM")
    mIndex = 0
    mCancelGenerate = False
End Sub

'写入单个职工信息
Private Sub writeXL(EID As String, index As Integer)
    '打开错误处理陷阱
    Dim intErrFileNo As Integer  '自由文件号
    On Error GoTo ErrGoto
    '----------------------------------------------------
    mIndex = mIndex + 1
    SQL = "select 工资取毕 from " & mMonth & " where 职工ID = """ & EID & """"
    OpenRS (SQL)
    '用户不存在,则报错,取消生成
    If gRst.BOF Or gRst.EOF Then
        CloseRS
        MsgBox "请先到工资发放窗体生成当前月的月表!"
        mCancelGenerate = True
    Else
        gRst.MoveFirst
        '显示工资领取信息
        If gRst("工资取毕") = True Then
            mSheet.Cells(mIndex, 1) = "工资取毕"
            mSheet.Cells(mIndex, 2) = "是"
            CloseRS
        Else
            mSheet.Cells(mIndex, 1) = "工资取毕"
            mSheet.Cells(mIndex, 2) = "否"
            CloseRS
        End If
        
        '职位工资
        SQL = "SELECT * FROM 职工,职位 where 职工.职位 = 职位.职位 and 职工.职工ID = """ & EID & """"
        OpenRS (SQL)
        gRst.MoveFirst
        OLE1.Visible = True
            
        '职工信息
        mIndex = mIndex + 1
        mSheet.Cells(mIndex, 1) = "员工编号:"
        mSheet.Cells(mIndex, 2) = EID
        mSheet.Cells(mIndex, 3) = "员工职位:"
        mSheet.Cells(mIndex, 4) = gRst("职工.职位")
        mSheet.Cells(mIndex, 5) = "员工姓名:"
        mSheet.Cells(mIndex, 6) = gRst("姓名")
        
        '职位工资信息
        mIndex = mIndex + 1
        mSheet.Cells(mIndex, 1) = "基本工资"
        mSheet.Cells(mIndex, 2) = gRst("基本工资")
        mSheet.Cells(mIndex, 3) = "津贴"
        mSheet.Cells(mIndex, 4) = gRst("津贴")
        mSum(index) = mSheet.Cells(mIndex, 2) + mSheet.Cells(mIndex, 4)
        CloseRS
        
        '搜索当月属于该员工的特殊项
        '每个月按30天算
        SQL = "SELECT * FROM 特殊项 WHERE 职工ID = """ & EID & """ AND 特殊项日期 >= #" & Format(Date - 30, "YYYY-MM") & "# and 特殊项日期 < #" & Format(Date, "YYYY-MM") & "#"
        OpenRS (SQL)
        
    
        If Not (gRst.BOF Or gRst.EOF) Then
            gRst.MoveFirst
            While Not gRst.EOF
                '特殊项信息
                mIndex = mIndex + 1
                mSheet.Cells(mIndex, 1) = "特殊项名称"
                mSheet.Cells(mIndex, 2) = gRst("特殊项名称")
                mSheet.Cells(mIndex, 3) = "特殊项金额"
                mSheet.Cells(mIndex, 4) = gRst("特殊项金额")
                mSheet.Cells(mIndex, 5) = "特殊项日期"
                mSheet.Cells(mIndex, 6) = gRst("特殊项日期")
                mSum(index) = mSum(index) + mSheet.Cells(mIndex, 4)
                gRst.MoveNext
            Wend
        End If
        mIndex = mIndex + 1
        '工资总额
        mSheet.Cells(mIndex, 1) = "工资总额"
        mSheet.Cells(mIndex, 2) = mSum(index)
        gCon.Execute "Update " & mMonth & " SET 工资= " & mSum(index) & " WHERE 职工ID = """ & EID & """"
        CloseRS
    End If
    '----------------------------------------------------
    Exit Sub
    '-----------------------------
ErrGoto:
    '把错误信息保存在文件里
    intErrFileNo = FreeFile()
    Open "YFSystem.ini" For Append As intErrFileNo
    Print #intErrFileNo, Chr(34) + Format(Now, "YYYY-MM-DD HH:MM:SS") + Chr(34), Chr(34) + "信息" + Chr(34), Chr(34) + Err.Description + Chr(34), Chr(34) + "writeXL(ThisMonthSalaryForm)" + Chr(34), Chr(34) + App.Title + Chr(34)
    Close #intErrFileNo
End Sub