modmain.bas

工资发放条输出程序

Attribute VB_Name = "modMain"
Option Explicit

'API 声明
Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long

'全局变量
Global gwsMainWS     As Workspace
Global gdbCurrentDB  As Database

Global gblnLogin As Boolean
Global gblnOpenDB As Boolean

'全局输出变量
Global gstrFileName As String
Global gstrFilePath As String

'帐套参数
Global gstrDBName As String
Global gstrAccName As String
Global gstrAccPassword As String
Global gingMonth As Integer
Global gstrYear As String


'------------------------------------------------------------
'系统启动过程
'------------------------------------------------------------
Sub Main()
    
    gblnLogin = False
    gblnOpenDB = False
    
    frmMain.Show

End Sub
'------------------------------------------------------------
'这个子过程打开帐套
'------------------------------------------------------------
Function OpenCurrentDB() As Boolean
    On Error GoTo OpenCurrentDBErr
    
    Dim strConnect As String
    
    strConnect = ";pwd=" & gstrAccPassword
        
    '打开帐套
    Set gwsMainWS = DBEngine.Workspaces(0)
    Set gdbCurrentDB = gwsMainWS.OpenDatabase(gstrDBName, False, True, strConnect)
        
    OpenCurrentDB = True
    
OpenCurrentDBExit:
    Exit Function
    
OpenCurrentDBErr:
    OpenCurrentDB = False
    Resume OpenCurrentDBExit
    
End Function

'------------------------------------------------------------
'这个子过程做一些清除工作并关闭程序
'------------------------------------------------------------
Sub ShutDown()
  On Error Resume Next

  If gblnOpenDB Then gdbCurrentDB.Close
  If Not gobjExcel Is Nothing Then gobjExcel.Quit
    
  End

End Sub

'------------------------------------------------------------
'这个子过程进行系统登录
'------------------------------------------------------------
Function Login() As Boolean
    On Error GoTo LoginErr
    
    Dim objLogin As Object
    Set objLogin = CreateObject("UFLogin.Login")
    
    '系统登录
    With objLogin
        .ProcessId = GetCurrentProcessId
        If .Login("DP") Then
            
            '获得登录信息
            gstrDBName = .UfDbName
            gstrAccName = .cacc_id & " " & .CaccName
            gstrAccPassword = .SysPassword
            gingMonth = .iMonth
            gstrYear = .ciyear
            
            '关闭登录
            .ShutDown
            Login = True
        Else
            Login = False
        End If
    End With
    
    Set objLogin = Nothing
    
    Exit Function

LoginErr:
    If Not objLogin Is Nothing Then Set objLogin = Nothing
    Login = False
    
End Function

'------------------------------------------------------------
'这个函数从 path\file 字符串中去掉文件名
'------------------------------------------------------------
Function StripFileName(rsFileName As String) As String
  On Error Resume Next
  Dim i As Integer

  For i = Len(rsFileName) To 1 Step -1
    If Mid(rsFileName, i, 1) = "\" Then
      Exit For
    End If
  Next

  StripFileName = Mid(rsFileName, 1, i)

End Function