frmdatareport.frm

地方税务局税控开票系统

    If bCompressFiles(sFilePath, gsSendType) = False Then Exit Function      '''进行文件的压缩
'    sUnitCode = Left(gsUnitCode, 8)
'    If bCreateCaFile(sCAFile, sUnitCode) = False Then Exit Function          '''进入CA认证
'    If bCompressFiles(sCAFile, gsSendType) = False Then Exit Function      '''进行CA文件的压缩
    
    If bSendData = False Then Exit Function                                  '''进行数据上报
    
    StrSQL = "update " + gsconTabel + sTable + " set datareport ='Y'  " + _
                 "where chequecode in ('" + sChequeCode + "')"
    gConn.Execute (StrSQL)                                                   '''标识为已经上报
    
    StrSQL = "update " + gsconTabel + msTableItem + " set datareport ='Y'  " + _
                     "where datareport='' or datareport is null"             '''标识项目已经上报
    gConn.Execute (StrSQL)
    
    
    SaveFileInfo                                                             '''保存日期
    MsgBox "数据上报成功，请确认！", vbOKOnly + vbInformation, "提示信息"
    
    Me.MousePointer = 0
    bGetReportData = True
    Set oFtp = Nothing
    Exit Function
err:
'    MsgBox "数据上报失败,请确认!", vbOKOnly + vbInformation, "提示信息"
End Function

Private Function bCreateCaFile(ByVal vsFile As String, ByVal vsCaFile As String) As Boolean
On Error GoTo err
    Dim lCrypt As Long
    
    bCreateCaFile = True
    lCrypt = EncryptFiles(vsFile + "\archive001.dat", vsCaFile + ".des")
    lCrypt = SignFiles(vsFile + "\archive001.dat", vsCaFile + ".sgn")
    
    If lCrypt = 0 Then
        MsgBox "生成加密文件时错误，请检查是否已经安装好了CA证书？", vbOKOnly + vbCritical, "提示信息"
        bCreateCaFile = False
        Exit Function
    End If
    
    Exit Function
err:
    bCreateCaFile = False
    MsgBox "生成加密文件时错误，请检查是否已经安装好了CA证书？", vbOKOnly + vbCritical, "提示信息"
End Function

'获取没有上报的数据,并生成上报文件
Private Function bGetCommonData() As Boolean
On Error GoTo err
    Dim StrSQL As String
    Dim recData As ADODB.Recordset
    Dim sTable As String
    Dim sChequeCode As String
    Dim objFile As New FileSystemObject
    Dim sFilePath As String
    Dim sDate As String
    Dim i As Integer
    Dim recCommon As ADODB.Recordset
    
    Me.MousePointer = 11
    bGetCommonData = False
    sDate = Format(Now, "yyyy-mm") + "-01"
    
    sTable = " commonchequeinfo"
    StrSQL = "select * from " + gsconTabel + sTable + " where (datareport <>'Y' " + _
                               "or datareport is null or datareport='') "
    
    StrSQL = StrSQL + " and chequedate < '" + sDate + "'"
    Set recData = New ADODB.Recordset
    If recData.State = 1 Then recData.Close
    recData.Open StrSQL, gConn, adOpenStatic, adLockReadOnly
    
    If recData.RecordCount = 0 Then
        MsgBox "您没有上报数据,请确认!", vbOKOnly + vbInformation, "提示信息"
        Exit Function
    End If
    
    Set recCommon = New ADODB.Recordset
    StrSQL = "select * from " + gsconTabel + sTable + " where 1=2"
    recCommon.CursorLocation = adUseClient
    recCommon.Open StrSQL, mcnnCommon, adOpenStatic, adLockBatchOptimistic
    
'    mcnnCommon.BeginTrans
    Do Until recData.EOF
        recCommon.AddNew
        For i = 0 To recData.Fields.Count - 1
            If Not IsNull(recData.Fields(i).Value) Then
                If recData.Fields(i).Name = "dealtax" And Trim(recData.Fields(i).Value) = "" Then
                    recCommon.Fields(i).Value = 0
                Else
                    recCommon.Fields(i).Value = recData.Fields(i).Value
                End If
            End If
        Next
        
        sChequeCode = IIf(sChequeCode = "", recData.Fields("chequecode"), _
                        sChequeCode + "','" + recData.Fields("chequecode"))  '''获取上报数据的发票号码
        recCommon.UpdateBatch
        recData.MoveNext
    Loop
'    mcnnCommon.CommitTrans
    
    If bGetDetailData(sChequeCode) = False Then Exit Function                '''生成发票详细数据的上报数据
    If bGetItemInfo = False Then Exit Function                               '''上报项目信息
    
    StrSQL = "update " + gsconTabel + sTable + " set datareport ='Y'  " + _
                 "where chequecode in ('" + sChequeCode + "')"
    gConn.Execute (StrSQL)                                                   '''标识为已经上报
    
    StrSQL = "update " + gsconTabel + msTableItem + " set datareport ='Y'  " + _
                     "where datareport='' or datareport is null"             '''标识项目已经上报
    gConn.Execute (StrSQL)
    
    
    SaveFileInfo                                                             '''保存日期
    MsgBox "数据上报成功，请确认！", vbOKOnly + vbInformation, "提示信息"
    
    Me.MousePointer = 0
    bGetCommonData = True
    Set oFtp = Nothing
    Exit Function
err:

    MsgBox "数据上报失败,请确认!", vbOKOnly + vbInformation, "提示信息"
End Function

'进行数据上报
Private Function bSendData() As Boolean
On Error GoTo err
    Dim sPath As String
    Dim sFtpPath As String
    Dim sNowDate As String
    Dim oFtp As clsFtpLoad
    Dim sIp As String
    
    bSendData = False
    
    If gsChequeType = "C" Then
        sIp = "150.64.16.11"
    Else
        sIp = "172.18.0.1"
    End If
    
    sPath = Replace(App.Path + "\filebak", "\\", "\")
    
    sNowDate = Format(Now, "yyyymmddhhmmss")
    Set oFtp = New clsFtpLoad
    
    If gsSendType = "P" Then
        If CopyToDriverA(sPath) = False Then Exit Function
    Else
        If gsRegedit = "R" Then
            sFtpPath = "\newinforegedit\" + gsUnitCode + "\" + sNowDate + gsChequeType    '''公司代码+日期+行业
            CreateRegFile
            sPath = msPath
            If oFtp.bConnectFtp(sIp, "Administrator", "Administrator", sPath, _
                   sFtpPath + "\archive001.ddf", sFtpPath) = False Then Exit Function
        Else
            sFtpPath = "\newinfo\" + gsUnitCode + "\" + sNowDate + gsChequeType    '''公司代码+日期+行业
            sPath = sPath + "\archive001.dat"
            If oFtp.bConnectFtp(sIp, "Administrator", "Administrator", sPath, _
                   sFtpPath + "\archive001.dat", sFtpPath) = False Then Exit Function
        End If
''        If oFtp.bConnectFtp("150.10.10.25", "Administrator", "", sPath, _
''                   sFtpPath + "\archive001.dat", sFtpPath) = False Then Exit Function
                   
        
    End If
    
    Set oFtp = Nothing
    bSendData = True
    Exit Function
err:
End Function

Private Sub CreateRegFile()
On Error GoTo err
    Dim oFile As FileSystemObject
    Dim f As Object
    
    Set oFile = New FileSystemObject
    If oFile.FolderExists("c:\windows\system") Then
        msPath = "C:\windows\system\archive001.DDF"
    ElseIf oFile.FolderExists("c:\winnt\system") Then
        msPath = "C:\winnt\system\archive001.DDF"
    ElseIf oFile.FolderExists("d:\windows\system") Then
        msPath = "d:\windows\system\archive001.DDF"
    ElseIf oFile.FolderExists("d:\winnt\system") Then
        msPath = "d:\winnt\system\archive001.DDF"
    Else
        msPath = App.Path + "\archive001.DDF"
    End If
    
    msPath = Replace(msPath, "\\", "\")
    
    Set f = oFile.OpenTextFile(msPath, ForAppending, True, TristateFalse)
    f.Write gsUnitCode + App.Path
    f.WriteBlankLines (1)
    f.Close
    
    Exit Sub
err:
    MsgBox "不能建立注册信息时，请确认！", vbOKOnly + vbCritical, "提示信息"
End Sub

'生成发票详细数据的上报数据
Private Function bGetDetailData(vsWhere As String) As Boolean
On Error GoTo err
    Dim StrSQL As String
    Dim recDetail As ADODB.Recordset
    Dim objFile As New FileSystemObject
    Dim sFilePath As String
    Dim recCommon As ADODB.Recordset
    Dim i As Integer
    
    bGetDetailData = False
    If gsChequeType = "B" Then
        StrSQL = "select * from " + gsconTabel + "builddetail where chequecode in ('" + vsWhere + "')"
    ElseIf gsChequeType = "E" Then
        StrSQL = "select * from " + gsconTabel + "estatedetail where chequecode in ('" + vsWhere + "')"
    Else
        StrSQL = "select * from " + gsconTabel + "commondetail where chequecode in ('" + vsWhere + "')"
    End If
    
    Set recDetail = New ADODB.Recordset
    If recDetail.State = 1 Then recDetail.Close
    recDetail.CursorLocation = adUseClient
    recDetail.Open StrSQL, gConn, adOpenStatic, adLockReadOnly
    
    If gsChequeType = "C" Then
        StrSQL = "select * from " + gsconTabel + "commondetail where 1=2"
        Set recCommon = New ADODB.Recordset
        recCommon.CursorLocation = adUseClient
        recCommon.Open StrSQL, mcnnCommon, adOpenStatic, adLockBatchOptimistic
        
        Do Until recDetail.EOF
            recCommon.AddNew
            For i = 0 To recDetail.Fields.Count - 1
                If Not IsNull(recDetail.Fields(i).Value) Then
                    recCommon.Fields(i).Value = recDetail.Fields(i).Value
                End If
            Next
            recCommon.UpdateBatch
            recDetail.MoveNext
        Loop
    Else
         sFilePath = Replace(App.Path + "\filebak\detaildata.dat", "\\", "\")
        If objFile.FileExists(sFilePath) = True Then
            objFile.DeleteFile sFilePath
        End If
        recDetail.Save sFilePath
    End If
    
    bGetDetailData = True
    Exit Function
err:
    MsgBox "不能生成详细上报数据,上报数据失败!", vbOKOnly + vbInformation, "提示信息"
End Function

'上报项目信息
Private Function bGetItemInfo() As Boolean
On Error GoTo err
    Dim StrSQL As String
    Dim recItem As ADODB.Recordset
    Dim objFile As New FileSystemObject
    Dim sFilePath As String
    Dim objEncry As New encrypt
    Dim sMoney As String
    Dim sErr As String
    Dim recCommon As ADODB.Recordset
    Dim i As Integer
    
    bGetItemInfo = False
    If gsChequeType = "B" Then
        msTableItem = "buildcheque "
    ElseIf gsChequeType = "E" Then
        msTableItem = "estatecheque "
    Else
        msTableItem = "commoncheque "
    End If
    
    StrSQL = "select * from " + gsconTabel + msTableItem + " where datareport ='' or datareport is null"
    Set recItem = New ADODB.Recordset
    If recItem.State = 1 Then recItem.Close
    recItem.CursorLocation = adUseClient
    recItem.Open StrSQL, gConn, adOpenStatic, adLockReadOnly
    
    If gsChequeType = "C" Then
        StrSQL = "select * from " + gsconTabel + msTableItem + " where 1=2"
        Set recCommon = New ADODB.Recordset
        recCommon.CursorLocation = adUseClient
        recCommon.Open StrSQL, mcnnCommon, adOpenStatic, adLockBatchOptimistic
        
        Do Until recItem.EOF
            recCommon.AddNew
            For i = 0 To recItem.Fields.Count - 1
                If Not IsNull(recItem.Fields(i).Value) Then
                    recCommon.Fields(i).Value = recItem.Fields(i).Value
                End If
            Next
            recCommon.UpdateBatch
            recItem.MoveNext
        Loop
        
    Else
        sFilePath = Replace(App.Path + "\filebak\iteminfo.dat", "\\", "\")
        If objFile.FileExists(sFilePath) = True Then
            objFile.DeleteFile sFilePath
        End If
        recItem.Save sFilePath
    End If
    
    sMoney = objEncry.encrypt_str("0", "12345678", sErr)
    If sErr <> "" Then Exit Function
    
    StrSQL = "update " + msTableItem + "set totalmoney ='" + sMoney + "'"
    gConn.Execute (StrSQL)       ''' 把项目中的开票金额标为0,项目中的开票金额只记录没有上报的金额
    
    bGetItemInfo = True
    Exit Function
err:
    
    MsgBox "不能生成项目信息,上报数据失败!", vbOKOnly + vbInformation, "提示信息"
End Function


Private Sub Form_Load()
    mbTransOut = False

    If gbChequeOut = True Then
        Label1.Caption = "正在导出数据，请稍候...！"
        cmdCancel.Visible = True
        frmDataReport.Caption = "导出发票信息"
    Else
        If gsRegedit = "R" Then
            Label1.Caption = "正在进行系统注册，请稍候...！"
            cmdCancel.Visible = False
            frmDataReport.Caption = "系统注册"
        Else
            Label1.Caption = "正在进行数据上报，请稍候...！"
            cmdCancel.Visible = False
            frmDataReport.Caption = "数据上报"
        End If
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If mbMoveData = True Then
        MsgBox "正在进行数据上报不能退出，请确认！", vbOKOnly + vbInformation, "提示信息"
        Cancel = -1
    End If
End Sub