payform.frm

一个很不错的工资管理系统,功能全且代码简单易懂

VERSION 5.00
Begin VB.Form PayForm 
   Caption         =   "工资发放"
   ClientHeight    =   6795
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   12975
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   6795
   ScaleWidth      =   12975
   WindowState     =   2  'Maximized
   Begin VB.ComboBox cmbName 
      Height          =   315
      Left            =   4680
      TabIndex        =   11
      Top             =   120
      Width           =   2535
   End
   Begin VB.CommandButton cmdGenerate 
      Caption         =   "生成月表"
      Height          =   495
      Left            =   10800
      TabIndex        =   9
      Top             =   960
      Width           =   1695
   End
   Begin VB.CommandButton cmdTest 
      Caption         =   "查询是否已经发放"
      Height          =   495
      Left            =   10800
      TabIndex        =   8
      Top             =   1560
      Width           =   1695
   End
   Begin VB.ComboBox cmbMonth 
      Height          =   315
      Left            =   8640
      TabIndex        =   7
      Top             =   120
      Width           =   1935
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消"
      Height          =   495
      Left            =   10800
      TabIndex        =   5
      Top             =   3360
      Width           =   1695
   End
   Begin VB.CommandButton cmdPrint 
      Caption         =   "打印工资表"
      Height          =   495
      Left            =   10800
      TabIndex        =   4
      Top             =   2760
      Width           =   1695
   End
   Begin VB.CommandButton cmdPay 
      Caption         =   "发放工资"
      Height          =   495
      Left            =   10800
      TabIndex        =   3
      Top             =   2160
      Width           =   1695
   End
   Begin VB.ComboBox cmbEmployee 
      Height          =   315
      Left            =   1320
      TabIndex        =   1
      Top             =   120
      Visible         =   0   'False
      Width           =   2175
   End
   Begin VB.Label Label3 
      Caption         =   "员工姓名"
      Height          =   255
      Left            =   3720
      TabIndex        =   10
      Top             =   120
      Width           =   975
   End
   Begin VB.Label label2 
      Caption         =   "月份"
      Height          =   255
      Left            =   7800
      TabIndex        =   6
      Top             =   120
      Width           =   615
   End
   Begin VB.OLE OLE1 
      Height          =   5895
      Left            =   480
      TabIndex        =   2
      Top             =   720
      Width           =   9975
   End
   Begin VB.Label Label1 
      Caption         =   "员工ID"
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Visible         =   0   'False
      Width           =   975
   End
End
Attribute VB_Name = "PayForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'月表的名称
'动态生成
'在cmbMonth中用户可以填入2003-6, 2003-06, 2003-06-01等格式
'而月表的名称都会变为200306
Public mTableName As String
'员工工资总额
'计算得到
Public mSum As Double

'当单击cmbEmployee框,保证与cmbName的一致性
Private Sub cmbEmployee_Click()
    cmbName.Text = cmbName.List(cmbEmployee.ListIndex)
    cmbEmployee.Text = cmbEmployee.List(cmbEmployee.ListIndex)
End Sub

'当cmbMonth框发生改变,保证月表名称一致
Private Sub cmbMonth_Change()
    mTableName = Format(CDate(cmbMonth.Text), "YYYYMM")
    cmbMonth.Text = mTableName
End Sub

'当单击cmbEmployee框,保证与cmbName的一致性
Private Sub cmbName_Click()
    cmbEmployee.Text = cmbEmployee.List(cmbName.ListIndex)
    cmbName.Text = cmbName.List(cmbName.ListIndex)
End Sub

'退出窗体
Private Sub cmdCancel_Click()
    Me.Hide
End Sub

'生成月表
'之所以使用On Error Resume Next
'是为了避免出现数据的不完整问题
Private Sub cmdGenerate_Click()
    On Error Resume Next
    '----------------------------------------------------
    Dim SQL As String
    
    '打开数据连接
    OpenDBFile
    '生成月表
    mTableName = Format(CDate(cmbMonth.Text), "YYYYMM")
    MakeUpTable
    CloseDBFile
    
    '初始化月表中的数据
    SQL = "SELECT 职工ID FROM 职工"
    OpenRS (SQL)
    gRst.MoveFirst
    While Not gRst.EOF
        SQL = "INSERT INTO " & mTableName & "(职工ID, 工资取毕, 工资) VALUES(""" & gRst("职工ID") & """, NO, 0)"
        gCon.Execute SQL
        gRst.MoveNext
    Wend
    CloseRS
End Sub

'发放工资
Private Sub cmdPay_Click()
    '打开错误处理陷阱
    Dim intErrFileNo As Integer  '自由文件号
    On Error GoTo ErrGoto
    '----------------------------------------------------
    '打开数据连接
    OpenDBFile
    '执行修改数据库
    gCon.Execute "UPDATE " & mTableName & " SET 工资取毕=1, 工资=" & mSum & " WHERE 职工ID = """ & cmbEmployee.Text & """"
    '显示结果
    MsgBox cmbEmployee.Text & "的工资已经发放完毕"
    '关闭连接
    CloseDBFile
    '----------------------------------------------------
    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) + "cmdPay_Click(PayForm)" + Chr(34), Chr(34) + App.Title + Chr(34)
    MsgBox "发放中出现错误:" & Err.Description
    Close #intErrFileNo
End Sub

'打印报表
Private Sub cmdPrint_Click()
   '打开错误处理陷阱
   Dim intErrFileNo As Integer  '自由文件号
   On Error GoTo ErrGoto
   '----------------------------------------------------
    Dim sheet As Worksheet
    Set sheet = gX.ActiveSheet
    sheet.PrintOut
   '----------------------------------------------------
   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) + "cmdPrint_Click(PayForm)" + Chr(34), Chr(34) + App.Title + Chr(34)
    Print #intErrFileNo, Err.Description
   Close #intErrFileNo
End Sub

'查询并显示本月工资
Private Sub cmdTest_Click()
    '打开错误处理陷阱
    Dim intErrFileNo As Integer  '自由文件号
    Dim sheet As Worksheet
    Dim SQL As String, i As Integer
    On Error GoTo ErrGoto
    '----------------------------------------------------

    If cmbEmployee.Text <> "" And cmbMonth.Text <> "" Then
        '查询工资领取情况
        SQL = "select 工资取毕 from " & Format(CDate(cmbMonth.Text), "YYYYMM") & " where 职工ID = """ & cmbEmployee.Text & """"
        '打开数据集
        OpenRS (SQL)
        gRst.MoveFirst
        If gRst("工资取毕") = True Then
            MsgBox "员工:" & cmbEmployee.Text & "已经取过" & cmbMonth.Text & "的工资"
        Else
            MsgBox "员工:" & cmbEmployee.Text & "还没有取过" & cmbMonth.Text & "的工资"
        End If
        CloseRS
        
        '职位相关的工资和今天
        SQL = "SELECT * FROM 职工,职位 where 职工.职位 = 职位.职位 and 职工.职工ID = """ & cmbEmployee.Text & """"
        OpenRS (SQL)
        gRst.MoveFirst
        
        '打开Excel对象,准备输入信息
        Set gX = GetObject("", "Excel.Application")
        gX.Workbooks.Add
        OLE1.Visible = True
        
        '设置Worksheet对象
        Set sheet = gX.ActiveSheet
        
        '报表题目
        sheet.Cells(1, 1) = cmbMonth.Text & "月工资表"
        
        '职工的基本信息
        sheet.Cells(2, 1) = "员工编号:"
        sheet.Cells(2, 2) = cmbEmployee.Text
        sheet.Cells(2, 3) = "员工职位:"
        sheet.Cells(2, 4) = gRst("职工.职位")
        sheet.Cells(2, 5) = "员工姓名:"
        sheet.Cells(2, 6) = gRst("姓名")
        
        '职工的一般工资信息
        sheet.Cells(3, 1) = "基本工资"
        sheet.Cells(3, 2) = gRst("基本工资")
        sheet.Cells(3, 3) = "津贴"
        sheet.Cells(3, 4) = gRst("津贴")
        mSum = sheet.Cells(3, 2) + sheet.Cells(3, 4)
        CloseRS
        
        '搜索当月属于该员工的特殊项
        '每个月按30天算
        SQL = "SELECT * FROM 特殊项 WHERE 职工ID = """ & cmbEmployee.Text & """ AND 特殊项日期 >= #" & cmbMonth.Text & "# and 特殊项日期 < #" & CStr(CDate(cmbMonth.Text) + 30) & "#"
        OpenRS (SQL)
        
        i = 3
        If Not (gRst.BOF Or gRst.EOF) Then
            gRst.MoveFirst
            While Not gRst.EOF
                i = i + 1
                sheet.Cells(i, 1) = "特殊项名称"
                sheet.Cells(i, 2) = gRst("特殊项名称")
                sheet.Cells(i, 3) = "特殊项金额"
                sheet.Cells(i, 4) = gRst("特殊项金额")
                sheet.Cells(i, 5) = "特殊项日期"
                sheet.Cells(i, 6) = CStr(gRst("特殊项日期"))
                mSum = mSum + sheet.Cells(i, 4)
                gRst.MoveNext
            Wend
        End If
        i = i + 1
        sheet.Cells(i, 1) = "工资总额"
        sheet.Cells(i, 2) = mSum
        CloseRS
        '显示格式设置
        mTableName = Format(CDate(cmbMonth.Text), "YYYYMM")
        sheet.Columns("A:F").ColumnWidth = 10
        gX.ActiveWorkbook.SaveAs App.Path & "\" & cmbEmployee.Text & mTableName & ".xls"
        OLE1.CreateLink App.Path & "\" & cmbEmployee.Text & mTableName & ".xls"
    End If
    '----------------------------------------------------
    Exit Sub
    '-----------------------------
ErrGoto:
    '把错误信息保存在文件里
    intErrFileNo = FreeFile()
    Open App.Path & "\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) + "cmdTest_Click(PayForm)" + Chr(34), Chr(34) + App.Title + Chr(34)
    MsgBox Err.Description
    Close #intErrFileNo
End Sub

'初始化窗体
Private Sub Form_Load()
    gX.Visible = False
    '打开错误处理陷阱
    Dim intErrFileNo As Integer  '自由文件号
    On Error GoTo ErrGoto
    '----------------------------------------------------
    Dim SQL As String
    '查找职工ID和姓名
    SQL = "SELECT 职工ID,姓名 FROM 职工"
    
    '打开数据集
    OpenRS (SQL)
    
    gRst.MoveFirst
    cmbEmployee.Clear
    cmbName.Clear
    '添加数据到两个ComboBox
    While Not gRst.EOF
        cmbEmployee.AddItem gRst("职工ID")
        cmbName.AddItem gRst("姓名")
        gRst.MoveNext
    Wend
    
    '关闭数据集
    CloseRS
    
    '查找已有的表名
    SQL = "SELECT 月份 FROM 月份"
    OpenRS (SQL)
    cmbMonth.Clear
    gRst.MoveFirst
    
    '添加到cmbMonth组合框中
    While Not gRst.EOF
        cmbMonth.AddItem CStr(gRst("月份"))
        gRst.MoveNext
    Wend
    
    '关闭数据集
    CloseRS
    '----------------------------------------------------
    Exit Sub
    '-----------------------------
ErrGoto:
    '把错误信息保存在文件里
    intErrFileNo = FreeFile()
    Open App.Path & "\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) + "Form_Load(PayForm)" + Chr(34), Chr(34) + App.Title + Chr(34)
    Close #intErrFileNo
End Sub

'生成月表
'在使用该函数之前
'确认已经打开连接
'使用之后
'确认关闭连接
Sub MakeUpTable()
    Dim SQL As String
    On Error Resume Next
    '储存月表信息
    SQL = "INSERT INTO 月份(表名,月份) VALUES( """ & mTableName & """, #" & cmbMonth.Text & "#)"
    gCon.Execute SQL
    '建立月表
    SQL = "CREATE TABLE " & mTableName & "( 职工ID TEXT(50) PRIMARY KEY NOT NULL, 工资取毕 BIT NOT NULL, 工资 CURRENCY) "
    gCon.Execute SQL
End Sub