modmain.bas

VB税控的源代码 主要用于地方税务局的税控引用 有完整的控件和代码

    
    Set fo = Nothing
    
    ''' 记录文件总数
    sFile = vsFilePath & "\index.dat"
    Open sFile For Output As #iFileNum
    Print #iFileNum, CStr(iCount)
    Close #iFileNum
    
    ''' 开始复制数据
    MsgBox "上报数据共需要空白软盘共：" & CStr(iCount) & _
            "张，请插入第 1 张软盘！", vbInformation, "提示信息"
            
    For i = 1 To iCount
    
        If i <> 1 Then
            MsgBox "请插入第：" & CStr(i) & " 张软盘！", vbInformation, "提示信息"
        End If

        Do Until bReady
            
            ''' 确认用户的软盘
            frmDataReport.MousePointer = 11
            bReady = fs.Drives("A").IsReady
            frmDataReport.MousePointer = 0
            If bReady = False Then
                iRtn = MsgBox("请插入第：" & CStr(i) & " 张软盘！", vbOKCancel, "提示信息")
                If iRtn = vbCancel Then bCancel = True
            End If
            
            ''' 确认空白软盘
            If bReady Then
                If fs.Drives("a:").FreeSpace < 1300000 Then
                    bReady = False
                    iRtn = MsgBox("请插入空白的软盘！", vbInformation + vbOKCancel, "提示信息")
                    If iRtn = vbCancel Then bCancel = True
                    
                End If
            End If
                   
            ''' 取消复制
            If bCancel Then
                iRtn = MsgBox("是否放弃复制数据？", vbYesNo + vbQuestion, "提示信息")
                If iRtn = vbYes Then
                    MsgBox "本次移交生成的文件在“" & vsFilePath & "”下，" & vbCrLf & _
                    "index.dat文件和archive001.dat在第一张盘，其他文件独自在一张盘上。", vbInformation, "题是信息"
                    Exit Function
                End If
            End If
        Loop
        
        ''' 获得文件名
        sFile = vsFilePath & "\Archive" & Right("000" & CStr(i), 3) & ".dat"
        frmDataReport.MousePointer = vbHourglass
        fs.CopyFile sFile, "a:\", True
        frmDataReport.MousePointer = vbDefault
        
        ''' 第一张盘则复制索引文件
        If i = 1 Then
            sFile = vsFilePath & "\index.dat"
            fs.CopyFile sFile, "A:\"
        End If
        bReady = False
    Next
    
    MsgBox "数据上报完成！", vbInformation, "提示信息"
    
    ''' 复制成功
    CopyToDriverA = True
    
End Function

'=======================================================================
'描 述：建立目录，已经有该目录则重新建立。
'输 入：vsf - 工作对象；vsPath - 要建立的目录。
'输 出：True - 成功；False - 失败；
'调用关系：被调用 -外部函数
'         调  用 -无
'========================================================================
'========================================================================

Public Function CreateFolder(ByVal vsPath As String, Optional ByVal vsPathCA As String)
'    Dim fs As New FileSystemObject
 On Error GoTo Err
    
    If fs.FolderExists(vsPath) Then
        fs.DeleteFolder vsPath, True
    End If
    
    fs.CreateFolder (vsPath)
    
    If vsPathCA <> "" Then
        If fs.FolderExists(vsPathCA) Then
            fs.DeleteFolder vsPathCA, True
        End If
        
        fs.CreateFolder (vsPathCA)
    End If
    
    Exit Function
Err:
    MsgBox CStr(Err.Description), vbOKOnly, "A"
End Function


'保存日期
Public Function SaveFileInfo()
On Error Resume Next
    Dim oReg As CRigestry
    Dim sDate As String
    Dim oEncry As encrypt
    Dim sErr As String
    Dim bSave As Boolean

    Set oReg = New CRigestry
    Set oEncry = New encrypt

    sDate = sGetFileDate
    sDate = oEncry.encrypt_str(sDate, "12345678", sErr)
    If sErr <> "" Then Exit Function
    If oReg.SaveSetting("checkdate", "skey", sDate) = False Then Exit Function
    
End Function


'保存日期
Public Function bGetRegedit() As Boolean
On Error GoTo Err
    Dim oReg As CRigestry
    Dim sInfo As String
    Dim oEncry As encrypt
    Dim sErr As String
    Dim sPatha As String
    Dim sUnit As String
    
    Set oReg = New CRigestry
    Set oEncry = New encrypt

    bGetRegedit = False
'    sDate = oEncry.encrypt_str(sDate, "12345678", sErr)
    sUnit = Mid(gsUnitCode, 1, 11)
    sInfo = oReg.GetSetting(sUnit, "unitcode", sErr)
    sPath = Trim(oReg.GetSetting(sUnit, "unitvalue", sErr))
    sInfo = oEncry.unencrypt_str(sInfo, "12345678", sErr)
    If sErr <> "" Then Exit Function
    If Trim(sInfo) <> sUnit Then Exit Function
    If sPath <> App.Path Then Exit Function
    If bGetRegPath(App.Path) = False Then Exit Function
    
    
    bGetRegedit = True
    Exit Function
Err:

End Function

'获取连接数据库的字符串
Private Function bGetRegPath(vsPath As String) As Boolean
On Error Resume Next
    Dim sFile As String
    Dim oFile As FileSystemObject
    Dim sConnection As String
    Dim iLen As Integer
    
    
''    sFile = "c:\windows\system\archive001.ddf"
    Set oFile = New FileSystemObject
    If oFile.FileExists("C:\windows\system\archive001.DDF") Then
        sFile = "C:\windows\system\archive001.DDF"
    ElseIf oFile.FileExists("C:\winnt\system\archive001.DDF") Then
        sFile = "C:\winnt\system\archive001.DDF"
    ElseIf oFile.FileExists("d:\windows\system\archive001.DDF") Then
        sFile = "d:\windows\system\archive001.DDF"
    ElseIf oFile.FileExists("d:\winnt\system\archive001.DDF") Then
        sFile = "d:\winnt\system\archive001.DDF"
    Else
        sFile = App.Path + "\archive001.DDF"
    End If
    
    If oFile.FileExists(sFile) = False Then Exit Function
    
    If Len(gsUnitCode) > 11 Then
        iLen = 11
    Else
        iLen = Len(gsUnitCode)
    End If
    
    bGetRegPath = True
    Open sFile For Input As #1                              '''打开一个文件
On Error GoTo Err

    Do While Not EOF(1)                                     '''通过循环把所要恢复的取出
        Line Input #1, sConnection                          '''把数据从备份的文件取出
        
        If Mid(sConnection, 1, iLen) = Mid(gsUnitCode, 1, iLen) Then
            If vsPath = Mid(sConnection, Len(gsUnitCode) + 1) Then
                Close #1
                Exit Function
            End If
        End If
    
    Loop
    
    Close #1
    bGetRegPath = False
    Exit Function
Err:
    bGetRegPath = False
    Close #1
End Function


'获取发票号码
Public Function sGetChequeCode(vsChequeType As String, vsUserid As String) As String
On Error GoTo Err
    Dim StrSQL As String
    Dim recInfo As ADODB.Recordset
    
    Set recInfo = New ADODB.Recordset
    StrSQL = "select startcode,taxcode from " + gsconTabel + "chequecode where userid ='" + vsUserid + "' and chequetype ='" + vsChequeType + "'"
    If recInfo.State = 1 Then recInfo.Close
    recInfo.CursorLocation = adUseClient
    recInfo.Open StrSQL, gConn, adOpenStatic, adLockOptimistic
    
    If recInfo.RecordCount > 0 Then
        sGetChequeCode = recInfo.Fields(0)
        gsEndTaxCode = IIf(IsNull(recInfo.Fields(1)), "", recInfo.Fields(1))
    End If
    
    Exit Function
Err:
'    MsgBox "读取企业信息错误，请确认！", vbOKOnly + vbInformation, "提示信息"
End Function

'更新发票号码
Public Sub UpdateCode(vschequecode As String, vsChequeType As String, vsUserid As String, _
                                 vsUpdateType As String, Optional ByVal vsTaxCode As String)
On Error GoTo Err
    Dim StrSQL As String
    Dim sTaxCode As String
    
    If vsTaxCode <> "" Then
        sTaxCode = vsTaxCode
    End If
    
    If vsUpdateType = "Y" Then
        StrSQL = "update " + gsconTabel + "chequecode set startcode ='" + vschequecode + _
                    "',taxcode ='" + sTaxCode + "' where userid ='" + vsUserid + "' and chequetype ='" + vsChequeType + "'"
    Else
        StrSQL = "insert into " + gsconTabel + "chequecode (startcode,chequetype,userid,taxcode) values( '" + _
                   vschequecode + "','" + vsChequeType + "','" + vsUserid + "','" + sTaxCode + "')"
    End If
    
    gConn.Execute StrSQL
    
    Exit Sub
Err:

'    MsgBox "读取企业信息错误，请确认！", vbOKOnly + vbInformation, "提示信息"
End Sub

Public Function bConnectDB() As Boolean
On Error GoTo Err
    Dim StrSQL As String
    
    bConnectDB = True
    StrSQL = sGetConnection(2)
    If StrSQL = "" Then
        MsgBox "数据库连接有误，请确认！", vbOKOnly + vbCritical, "提示信息"
        bConnectDB = False
    End If
    
    Set gConnServer = New ADODB.Connection
    If gConnServer.State = 1 Then gConnServer.Close
    gConnServer.CommandTimeout = 0
    gConnServer.CursorLocation = adUseServer
    gConnServer.Open StrSQL
        
    Exit Function
Err:
    bConnectDB = False
    MsgBox "数据库连接有误，请确认！", vbOKOnly + vbCritical, "提示信息"
End Function

Public Function bConverOpenInfo(ByVal sInfo As String) As Boolean
    Dim sPwd As String
    Dim StrSQL As String
    
    bConverOpenInfo = False
    If sInfo = "p" Then
        MsgBox "开票密码错误或者没有在线开票权限，请确认！", vbOKOnly + vbInformation, "提示信息"
        Exit Function
    ElseIf sInfo = "I" Then
        MsgBox "开票失败，请检查您的开票信息是否正确和网络是否连通！", vbOKOnly + vbInformation, "提示信息"
        Exit Function
    ElseIf Len(sInfo) > 1 And Right(sInfo, 1) = "i" Then
        sPwd = Left(sInfo, Len(sInfo) - 1)
        StrSQL = "update " + gsconTabel + "unitinfo set mail ='" + sPwd + "'"
        UpdateInfo StrSQL
        MsgBox "开票失败但开票密码已经更改为" + sPwd + "，请检查您的开票信息是否正确和网络是否连通！", vbOKOnly + vbInformation, "提示信息"
        Exit Function
    ElseIf sInfo <> "" Then
        StrSQL = "update " + gsconTabel + "unitinfo set mail ='" + sInfo + "'"
        UpdateInfo StrSQL
        MsgBox "开票密码已经更改为" + sInfo + "，请确认！", vbOKOnly + vbInformation, "提示信息"
        gsOpenCode = sInfo
        
    End If
    
    bConverOpenInfo = True
End Function

Private Sub UpdateInfo(ByVal sSql As String)
On Error GoTo Err
    Dim StrSQL As String
    
    
    StrSQL = sSql
    gConn.Execute (StrSQL)
    
    
    Exit Sub
Err:
    
End Sub

''获取数据库的时间
'Private Function sGetFileDate() As String
'    Dim sDate As String
'    Dim sPath As String
'    Dim fso As New FileSystemObject
'    Dim file
'
'    Set gConn = Nothing
'    sPath = "D:\支票管理系统\数据库\cheque.mdb"
'    Set file = fso.GetFile(sPath)
'    sDate = Format(file.DateLastModified, "yyyymmddhhmm")
'
'    sGetFileDate = sDate
'    Set fso = Nothing
'
'End Function