modmain.bas

地方税务局税控开票系统

Attribute VB_Name = "modMain"
Public gConn As ADODB.Connection
Public gConnServer As ADODB.Connection
Public grecCheque As ADODB.Recordset
Public gsEditStatus As String                '''"A"为新增，"E"为修改
Public gsCode As String                      '''企业代码
Public gbViewCheque As Boolean               '''"true"为游览发票,“false”开发票
Public gsChequeQuery As String               '''查询条件
Public gsQueryDetail As String               '''查询结算项目的条件
Public gsQueryRange As String                '''b为本项目中查询,a为全部查询,""为不是查询
Public gsBlankOutNote As String             '''作废的原因

Public gsChequeType As String                '''开票类型，“E”为不动产，“B”为建筑业，“C”为通用
Public gbAddItem As Boolean                   '''在开不动产发票时，“TRUE”为建项目，“FALSE”为建用户信息
Public gbChequeOut As Boolean                '''true为导出发票

Public gsEditUser As String                   '''对用户进行设置，“E”为修改用户，“A”为增加用户
Public gsEndTaxCode As String                 '''记录完税凭证号码
Public gsTemp As String                      '''查询删除的数据，“_temp”表明查询删除数据,空为否
Public gbMinus As Boolean                    '''"true"为负数
Public gbChequeLine As Boolean               '''true为在线开票
Public mobjData As Object
Public gsOpenCode As String                  '''在线开票密码
Public gsOpencodeN As String                 '''在线开票的新密码

Public gsUserID As String                     '''用户ID
Public gsUserName As String                   '''用户名字
Public gsUnitName As String                   '''企业名称
Public gsUnitAddress As String                '''企业地址
Public gsUnitBound As String                  '''企业税务登记号
Public gsUnitPhone As String                  '''企业电话
Public gsUnitCode As String                   '''企业编码
Public gsRegedit As String                    '''“R”已经注册，“”还没有注册

Public Const gsconTabel As String = ""
Public Const gsconServerName As String = "172.18.0.1"
Public gsEstateCode As String                 '''新添加的合同号
Public gsOpenTime As String                   '''开票时间

Public fs As New FileSystemObject
Public gsSendType As String                    '''数据上报的方式，“P”为软盘上报，“N”网络上报

'帮助函数
Public Declare Function htmlhelp Lib "hhctrl.ocx" Alias "HtmlHelpA" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Long) As Long

Public Declare Function EncryptFiles Lib "GDHZDSSK.dll" (ByVal SourceFile As String, ByVal CryptFile As String) As Long
Public Declare Function SignFiles Lib "GDHZDSSK.dll" (ByVal SourceFile As String, ByVal CryptFile As String) As Long
Public Declare Function DecryptFiles Lib "GDHZDSSK.dll" (ByVal SourceFile As String, ByVal CryptFile As String) As Long
Public Declare Function VerifyFiles Lib "GDHZDSSK.dll" (ByVal SourceFile As String, ByVal CryptFile As String) As Long
Public Declare Function GetErrorMsg Lib "GDHZDSSK.dll" (ByVal ErrCode As Long, ByVal ErrMsg As String) As Long

Sub Main()
On Error GoTo Err
    If bConnection = False Then Exit Sub           '''进行数据库连接
'    If bFileChange = True Then
'        MsgBox "您的信息有误,请与供应商联系!", _
'             vbOKOnly + vbInformation, "提示信息"
'        Exit Sub
'    End If
'
    If bCheckUnitInfo = False Then                 '''还没有录入企业信息
'        MsgBox "您还没有导入数据不能使用在线开票，请确认！", vbOKOnly + vbInformation, "提示信息"
'        Exit Sub
        frmSystel.Show vbModal                     '''企业信息
        If bCheckUnitInfo = False Then
            Exit Sub
        End If
    End If
    
    frmLogin.Show vbModal                          '''进入系统
    Exit Sub
Err:
    MsgBox Err.Description, vbOKOnly, "提示信息"
End Sub

'检查数据库是否已经更改,如果更改则锁住系统
Private Function bFileChange() As Boolean
On Error GoTo Err
    Dim oReg As New CRigestry
    Dim sLastDate As String
    Dim sNowDate As String
    Dim objEncry As New encrypt
    Dim fs As New FileSystemObject
    Dim sErr As String
'    Dim rec As New ADODB.Recordset
'    Dim Str As String
'
'
'    Str = "select chequecode,totalmoney from commonchequeinfo"
'    rec.Open Str, gConn, adOpenStatic, adLockBatchOptimistic
'
'    Do Until rec.EOF
'        sLastDate = objEncry.unencrypt_str(rec.Fields(1), "12345678", sErr)
'        sNowDate = objEncry.encrypt_str(sLastDate, rec.Fields(0), sErr)
'        rec.Fields(1) = sNowDate
'        rec.UpdateBatch
'        rec.MoveNext
'    Loop
    
    bFileChange = False
    
    If bFirstRun = True Then Exit Function                               '''第一次运行系统
    sLastDate = oReg.GetSetting("checkdate", "skey", "")                  '''获取上一次退出的时间
    If sLastDate <> "" Then
        sLastDate = objEncry.unencrypt_str(sLastDate, "12345678", sErr)   '''解密
        If sErr <> "" Then
            bFileChange = True
            Exit Function
        End If
        
        sNowDate = sGetFileDate                                           '''获取文件的修改的时间
        If sLastDate <> "0" Then                                          '''第一次运行时不检查
            If (CDbl(sNowDate) - CDbl(sLastDate)) < 3 Then
                Exit Function
            End If
        End If
    End If
    
    bFileChange = True
    Exit Function
Err:

    MsgBox "您的信息有误,请与供应商联系!", vbOKOnly + vbInformation, "提示信息"
End Function

'检查是否是第一次运系统
Private Function bFirstRun() As Boolean
On Error GoTo Err
    Dim StrSQL As String
    Dim recInfo As ADODB.Recordset
    
    bFirstRun = False
    Set recInfo = New ADODB.Recordset
    StrSQL = "select * from unitinfo"
    If recInfo.State = 1 Then recInfo.Close
    recInfo.CursorLocation = adUseClient
    recInfo.Open StrSQL, gConn, adOpenStatic, adLockOptimistic
    
    If recInfo.RecordCount > 0 Then Exit Function
    
    bFirstRun = True
    Exit Function
Err:
    MsgBox "您的信息有误,请与供应商联系！", vbOKOnly + vbInformation, "提示信息"
End Function
'获取数据库的时间

Private Function sGetFileDate() As String
    Dim sDate As String
    Dim sPath As String
    Dim fso As New FileSystemObject
    Dim file
    
'    sPath = "d:\支票管理系统\数据库\cheque.mdb"
    sPath = "C:\Program Files\惠州市发票管理系统1.0\sinfarch\cheque.mdb"
    sPath = Replace(App.Path + "\sinfarch\cheque.mdb", "\\", "\")
    If fso.FileExists(sPath) = False Then
        sGetFileDate = Format(Now, "yyyymmddhhmm")
        Exit Function
    End If
    Set file = fso.GetFile(sPath)
    sDate = Format(file.DateLastModified, "yyyymmddhhmm")
    sGetFileDate = sDate
    Set fso = Nothing
End Function

'检查企业信息是否已经输入
Private Function bCheckUnitInfo() As Boolean
On Error GoTo Err
    Dim StrSQL As String
    Dim recInfo As ADODB.Recordset
    
    bCheckUnitInfo = False
    Set recInfo = New ADODB.Recordset
    StrSQL = "select * from " + gsconTabel + "unitinfo"
    If recInfo.State = 1 Then recInfo.Close
    recInfo.CursorLocation = adUseClient
    recInfo.Open StrSQL, gConn, adOpenStatic, adLockOptimistic
    
    gsOpenCode = ""
    If recInfo.RecordCount < 1 Then
        MsgBox "欢迎您使用税控开票管理系统2.0版,在您第一次使用本系统前" + _
              ",请您先进行系统初始化设置！", vbOKOnly + vbInformation, "提示信息"
        Exit Function
    Else
        If Not IsNull(recInfo.Fields("mail").Value) Then
            gsOpenCode = recInfo.Fields("mail").Value
        End If
    End If
    
    If gsOpenCode = "" Then gsOpenCode = "075223932"
    
    bCheckUnitInfo = True
    Exit Function
Err:
    MsgBox Err.Description, vbOKOnly, "提示信息"
    MsgBox "读取企业信息错误，请确认！", vbOKOnly + vbInformation, "提示信息"
End Function


'连接数据库
Private Function bConnection() As Boolean
On Error GoTo Err
    Dim StrSQL As String
    Dim sPath As String
    Dim objFile As FileSystemObject
    Dim sCheque As String
    
    Set objFile = New FileSystemObject
    
    bConnection = False
    sPath = sGetConnection(1)                      '''获取连接数据库的字符串
'    If sPath = "" Then sPath = sGetConnection(2)
    sCheque = sGetConnection(3)
    If sCheque = "" Then sCheque = "cheque"
    
    If sPath = "" Then
        sPath = App.Path + "\sinfarch\cheque.mdb"
        StrSQL = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + sPath + ";Persist Security Info=False"
'        StrSQL = "Provider=Microsoft.Jet.OLEDB.4.0;user id =Admin;database password =123932;Data Source=" + sPath + ";Persist Security Info=false"
        If objFile.FileExists(App.Path + "\sinfarch\ischeque.dll") Then
            StrSQL = "dsn=" + sCheque + ";uid=Admin;pwd=123932;database=ischeque"
            gbChequeLine = True
        Else
            gbChequeLine = False
        End If
    Else
        StrSQL = sPath
        gbChequeLine = False
    End If
    
'    gbChequeLine = False
    StrSQL = Replace(StrSQL, "\\", "\")
    Set gConn = New ADODB.Connection
    gConn.CursorLocation = adUseServer
    gConn.Open StrSQL
    
'    Dim cnn As New ADODB.Connection
'    Dim rec1 As New ADODB.Recordset
'    Dim rec2 As New ADODB.Recordset
'    Dim str As String
'    Dim i As Integer
'
'    cnn.CursorLocation = adUseServer
'    cnn.Open StrSQL
'
'    str = "select * from commondetail"
'    rec1.Open str, gConn, adOpenStatic, adLockBatchOptimistic
'
'    str = "select * from commondetail where 1=2"
'    rec2.Open str, cnn, adOpenDynamic, adLockBatchOptimistic
'
    
'    cnn.BeginTrans
'    Do Until rec1.EOF
'        rec2.AddNew
'        For i = 0 To rec1.Fields.Count - 1
'            If Not IsNull(rec1.Fields(i)) Then
'                rec2.Fields(i) = rec1.Fields(i)
'            End If
'
'        Next
'        rec2.UpdateBatch
'        rec1.MoveNext
'    Loop
'    cnn.CommitTrans

    bConnection = True
    Exit Function
Err:
    MsgBox Err.Description, vbOKOnly + vbInformation, "提示信息"
'    MsgBox "数据库连接'" + StrSQL + "'", vbOKOnly + vbInformation, "提示信息"
    bConnection = False
End Function

'获取连接数据库的字符串
Public Function sGetConnection(viIndex As Integer) As String
On Error Resume Next
    Dim sFile As String
    Dim oFile As FileSystemObject
    Dim sConnection As String
    Dim i As Integer
    
    sFile = Replace(App.Path + "\sinfarch\dbconnect.cfg", "\\", "\")
    Set oFile = New FileSystemObject
    If oFile.FileExists(sFile) = False Then Exit Function
    
    
    Open sFile For Input As #1                              '''打开一个文件
On Error GoTo Err
    i = 1
    Do While Not EOF(1)                                     '''通过循环把所要恢复的取出
        Line Input #1, sConnection                          '''把数据从备份的文件取出
        
        If viIndex = i And Trim(sConnection) <> "" Then
            sGetConnection = sConnection
            Close #1
            Exit Function
        End If
        i = i + 1
    Loop
    
    Close #1
    Exit Function
Err:
    Close #1
End Function

'由整数转化为大写
Public Function sGetTotalMoney(vdMoney As Double, vsDecimal As String) As String
On Error Resume Next
    Dim iPos As Integer             '''标点的位置
    Dim sNum As String
    Dim i As Integer                '''数据的位置
    Dim iValue As Integer           '''数据的值
    Dim sPlace As String            '''数据的位置
    Dim sValue As String            '''数据的大写
    Dim sCent As String             '''分和角的值
    Dim sTotalValue As String       '''总的转换值
    Dim iTotalLen As Integer
    Dim dMoney As Double
    Dim sMinus As String
    
    dMoney = vdMoney
    gbMinus = False
    If dMoney < 0 Then
        dMoney = Mid(dMoney, 2)
        sMinus = "负"
        gbMinus = True
    Else
        sMinus = "￥"
    End If
    
    If gsChequeType = "B" Then
        frmBuild.Label26.Caption = sMinus
    ElseIf gsChequeType = "E" Then
        frmEstate.Label26.Caption = sMinus
    End If
    
'    If gsChequeType <> "C" Then
        CancelLabelView
'    End If