frmmain.frm

工资发放条输出程序

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   3300
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5625
   ForeColor       =   &H00000000&
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3300
   ScaleWidth      =   5625
   StartUpPosition =   2  'CenterScreen
   Begin MSComDlg.CommonDialog dlgCommonDialog 
      Left            =   2520
      Top             =   1320
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton cmdExit 
      Cancel          =   -1  'True
      Caption         =   "退出"
      Height          =   375
      Left            =   4680
      TabIndex        =   5
      Top             =   720
      Width           =   855
   End
   Begin VB.CommandButton cmdExport 
      Caption         =   "输出(&E)..."
      Height          =   375
      Left            =   4680
      TabIndex        =   4
      Top             =   240
      Width           =   855
   End
   Begin VB.Frame fraLogin 
      Caption         =   "帐套信息"
      Height          =   1455
      Left            =   120
      TabIndex        =   3
      Top             =   1320
      Width           =   4455
      Begin VB.ComboBox cboTypes 
         Height          =   315
         Left            =   960
         Style           =   2  'Dropdown List
         TabIndex        =   14
         Top             =   960
         Width           =   1935
      End
      Begin VB.CommandButton cmdLogin 
         Caption         =   "登录(&L)..."
         Height          =   375
         Left            =   3120
         TabIndex        =   12
         Top             =   960
         Width           =   1215
      End
      Begin VB.Label Label4 
         Alignment       =   1  'Right Justify
         Caption         =   "工资类别:"
         Height          =   255
         Left            =   120
         TabIndex        =   13
         Top             =   960
         Width           =   735
      End
      Begin VB.Label lblMonth 
         ForeColor       =   &H8000000D&
         Height          =   255
         Left            =   3600
         TabIndex        =   11
         Top             =   600
         Width           =   735
      End
      Begin VB.Label lblYear 
         ForeColor       =   &H8000000D&
         Height          =   255
         Left            =   960
         TabIndex        =   10
         Top             =   600
         Width           =   735
      End
      Begin VB.Label lblAccName 
         ForeColor       =   &H8000000D&
         Height          =   255
         Left            =   960
         TabIndex        =   9
         Top             =   240
         Width           =   3255
      End
      Begin VB.Label Label3 
         Alignment       =   1  'Right Justify
         Caption         =   "月份:"
         Height          =   255
         Left            =   2760
         TabIndex        =   8
         Top             =   600
         Width           =   735
      End
      Begin VB.Label Label2 
         Alignment       =   1  'Right Justify
         Caption         =   "年份:"
         Height          =   255
         Left            =   120
         TabIndex        =   7
         Top             =   600
         Width           =   735
      End
      Begin VB.Label Label1 
         Alignment       =   1  'Right Justify
         Caption         =   "帐套:"
         Height          =   255
         Left            =   120
         TabIndex        =   6
         Top             =   240
         Width           =   735
      End
   End
   Begin VB.Frame frmFilePath 
      Caption         =   "输出路径"
      Height          =   1095
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   4455
      Begin VB.CommandButton cmdFilePath 
         Height          =   375
         Left            =   3960
         Picture         =   "frmMain.frx":030A
         Style           =   1  'Graphical
         TabIndex        =   2
         Top             =   360
         Width           =   375
      End
      Begin VB.TextBox txtFilePath 
         Height          =   375
         Left            =   240
         TabIndex        =   1
         Top             =   360
         Width           =   3615
      End
   End
   Begin VB.Label lblMsg 
      Alignment       =   2  'Center
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   9.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00800080&
      Height          =   255
      Left            =   120
      TabIndex        =   15
      Top             =   3000
      Width           =   5415
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim mstrType As String          '工资类别
Dim mstrFileName As String      '输出文件名称

Const mstrMsg = "(c) 2000 烟台用友软件有限公司  作者:孙勇"

Private Sub cmdExit_Click()
    
    '保存存放路径
    SaveSetting "Agile Software", "gzzh", "path", txtFilePath
    
    '退出应用程序
    Call ShutDown

End Sub


Private Sub cmdExport_Click()
    
    '检查存放路径是否合法
    If Trim(txtFilePath) = "" Or Dir(txtFilePath) = "" Then
        MsgBox "输出路径不存在或为空!", vbInformation + vbOKOnly, "提示"
        txtFilePath.SetFocus
        Exit Sub
    End If
    
    '检查是否进行系统登录
    If Not (gblnLogin And gblnOpenDB) Then
        MsgBox "请进行系统登录!", vbInformation + vbOKOnly, "提示"
        cmdLogin.SetFocus
        Exit Sub
    End If
        
    '检查是否选择工资类别
    If cboTypes = "" Then
        MsgBox "请选择工资类别!", vbInformation + vbOKOnly, "提示"
        cboTypes.SetFocus
        Exit Sub
    End If
    
    '获得工资类别和输出文件名称
    mstrType = Left(cboTypes.Text, 3)
    mstrFileName = "GZFFT" & Right(lblYear, 2) & Right("0" + lblMonth, 2) & ".xls"
    
    '进行输出
    Call ExportToExcel
    
End Sub

Private Sub cmdFilePath_Click()
    On Error GoTo FilePathErr
    
    '显示对话框
    With dlgCommonDialog
        .Filter = "Excel 97 Files(*.xls)|*.xls"
        .DialogTitle = "工资发放表存放路径"
        .CancelError = True
        .Flags = &H800
        .filename = "GZFFT.XLS"
        .ShowOpen
        
        '获得路径
        txtFilePath = StripFileName(.filename)
    End With

    Exit Sub

FilePathErr:
  If Err <> 32755 And Err <> 3049 Then   '检查取消的公共对话框
    MsgBox Err.Description, vbCritical + vbOKOnly, "错误"
  End If
  
End Sub

Private Sub cmdLogin_Click()
    Dim i As Integer
    
    '登录
    Call DispMsg("正在登录...")
    gblnLogin = Login()
    
    If gblnLogin Then
        
        '显示帐套信息
        lblAccName = gstrAccName
        lblYear = gstrYear
        lblMonth = gingMonth
        
        '打开帐套
        Screen.MousePointer = vbHourglass
        Call DispMsg("正在创建数据环境...")
        gblnOpenDB = OpenCurrentDB()
        Screen.MousePointer = vbDefault
        
       
        If gblnOpenDB Then
            
            '添加工资类别
            Call DispMsg("正在获取工资类别...")
            GetRowsType
            
            cboTypes.Clear
            If Not IsEmpty(gvarType) Then
                For i = 0 To UBound(gvarType, 2)
                    cboTypes.AddItem gvarType(0, i) + gvarType(1, i)
                Next
            End If
            
        Else
        
            MsgBox "帐套打开失败!", vbCritical + vbOKOnly, "错误"
        End If
    Else
        MsgBox "登录过程被取消!", vbCritical + vbOKOnly, "错误"
    End If
    
    Call DispMsg(mstrMsg)
    
End Sub

Private Sub Form_Load()
    
    txtFilePath = GetSetting("Agile Software", "gzzh", "path", App.Path)
    Me.Caption = "工资发放条输出工具 V1.0A - 财政专用"
    Call DispMsg(mstrMsg)
    
End Sub

'------------------------------------------------------------
'显示状态信息
'------------------------------------------------------------
Private Sub DispMsg(strMsg As String)

   lblMsg = strMsg
    
End Sub

'------------------------------------------------------------
'输出工资发放表到Excel文件中
'------------------------------------------------------------
Private Sub ExportToExcel()
    
    On Error GoTo ExportToExcelErr
    
    Dim i As Integer
    
    '装载参数
    DispMsg ("正在装载参数...")
    
    GetRowsDept (mstrType)      '部门
    If IsEmpty(gvarDept) Then
        MsgBox "装载部门参数出错!", vbCritical + vbOKOnly, "错误"
        Exit Sub
    End If
    
    GetRowsItemTitle (mstrType) '工资发放条项目标题
    If IsEmpty(gvarItemTitle) Then
        MsgBox "装载工资发放条项目出错!", vbCritical + vbOKOnly, "错误"
        Exit Sub
    End If
    
    GetRowsItem (mstrType)      '工资项目
    If IsEmpty(gvarItem) Then
        MsgBox "装载工资项目出错!", vbCritical + vbOKOnly, "错误"
        Exit Sub
    End If
    
        
    '添加工作簿
    DispMsg ("正在建立 Excel 工作簿...")
    Set gobjExcel = CreateObject("Excel.Application")
    
    gobjExcel.Visible = False
    gobjExcel.Workbooks.Add
    
    '按部门添加表页和设置名称
    DispMsg ("正在建立部门表页...")
    Call AddSheets
    
    '按部门输出工资发放表明细
    For i = 0 To UBound(gvarDept, 2)
        
        DispMsg ("正在输出工资发放条 - " & gvarDept(1, i) & "...")
        DoEvents
        Call ExportList(mstrType, Val(lblYear), Val(lblMonth), i)
    
    Next i
    
    '保存工作簿
    DispMsg ("正在保存 Excel 工作簿...")
    gobjExcel.ActiveWorkbook.SaveAs txtFilePath & mstrFileName
       

    '退出Excel
    gobjExcel.Quit
    Set gobjExcel = Nothing
    
    DispMsg (mstrMsg)
    MsgBox "工资条已输出完毕!", vbInformation + vbOKOnly, "提示"
    
    Exit Sub
    
ExportToExcelErr:
    If Not gobjExcel Is Nothing Then Set gobjExcel = Nothing
    MsgBox Err.Description, vbCritical + vbOKOnly, "错误"
    
End Sub