frmdatareport.frm

地方税务局税控开票系统

VERSION 5.00
Begin VB.Form frmDataReport 
   BorderStyle     =   5  'Sizable ToolWindow
   Caption         =   "数据上报"
   ClientHeight    =   1710
   ClientLeft      =   60
   ClientTop       =   285
   ClientWidth     =   5625
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   9
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1710
   ScaleWidth      =   5625
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消(&C)"
      Height          =   405
      Left            =   2130
      TabIndex        =   1
      Top             =   1170
      Width           =   1125
   End
   Begin VB.Label Label1 
      Caption         =   "正在进行数据上报，请稍候！"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   18
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   885
      Left            =   120
      TabIndex        =   0
      Top             =   210
      Width           =   5385
   End
End
Attribute VB_Name = "frmDataReport"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private mbMoveData As Boolean
Private msTableItem As String
Private mbTransOut As Boolean                  '''是否停止数据导出,"true"为是,"false"为否
Private mcnnCommon As ADODB.Connection
Private msPath As String

Private Sub cmdCancel_Click()
    mbTransOut = True
End Sub

Private Sub Form_Activate()
On Error GoTo err
    Dim StrSQL As String
    Dim sPath As String
    Dim sPathCA As String
    
    Me.MousePointer = 11
    mbMoveData = True
    If gbChequeOut = False Then
        DoEvents
        
        If gsChequeType = "C" Then
            StrSQL = sGetConnection(2)
            If StrSQL = "" Then
                MsgBox "数据上报有误，请重新上报！", vbOKOnly + vbCritical, "提示信息"
                mbMoveData = False
                Unload Me
            End If
            Set mcnnCommon = New ADODB.Connection
            If mcnnCommon.State = 1 Then mcnnCommon.Close
            mcnnCommon.CommandTimeout = 0
            mcnnCommon.CursorLocation = adUseServer
            mcnnCommon.Open StrSQL
            If bGetCommonData = False Then                    '''获取没有上报的数据,并生成上报文件
                MsgBox "您的数据还没有上报,请确认!", _
                    vbOKOnly + vbInformation, "提示信息"
            End If
        Else
            If gsRegedit = "R" Then
                If bSendData = False Then
                     MsgBox "您的税控系统还没有注册成功,请检查你的网络是否已经连接!", _
                        vbOKOnly + vbInformation, "提示信息"   '''进行系统注册
                
                Else
                    If bSetRegedit = False Then
                        MsgBox "您的税控系统还没有注册成功,请和供应商联系!", _
                            vbOKOnly + vbInformation, "提示信息"
                    Else
                        MsgBox "您的税控系统已经注册成功,请确认!", _
                            vbOKOnly + vbInformation, "提示信息"
                        gsRegedit = ""
                    End If
                End If
            Else
                sPath = Replace(App.Path + "\filebak", "\\", "\")
                sPathCA = Replace(App.Path + "\cafile", "\\", "\")
                CreateFolder sPath, sPathCA
                If bGetReportData = False Then                    '''获取没有上报的数据,并生成上报文件
                    MsgBox "您的数据还没有上报,请检查你的网络是否已经连接!", _
                        vbOKOnly + vbInformation, "提示信息"
                End If
            End If
        End If
        
        Me.MousePointer = 0
        mbMoveData = False
    Else
        If bCreateExcel = False Then
            MsgBox "数据导出失败,请重新进行导出!", _
               vbOKOnly + vbInformation, "提示信息"
        End If
    End If
    
    Me.MousePointer = 0
    mbMoveData = False
    Unload Me
    Exit Sub
err:
    MsgBox "数据上报有误，请重新上报！", vbOKOnly + vbCritical, "提示信息"
    mbMoveData = False
    Unload Me
End Sub

'设置注册表
Public Function bSetRegedit() As Boolean
On Error GoTo err
    Dim oReg As CRigestry
    Dim sInfo As String
    Dim sUnit As String
    Dim oEncry As encrypt
    Dim sErr As String
    Dim sPatha As String

    Set oReg = New CRigestry
    Set oEncry = New encrypt

    bSetRegedit = False
    sUnit = Mid(gsUnitCode, 1, 11)
    sInfo = oEncry.encrypt_str(sUnit, "12345678", sErr)
    If oReg.SaveSetting(sUnit, "unitcode", sInfo) = False Then Exit Function
    If oReg.SaveSetting(sUnit, "unitvalue", App.Path) = False Then Exit Function
    
    
    bSetRegedit = True
    Exit Function
err:
'    MsgBox "不能注册系统信息，请确认！", vbOKOnly + vbCritical, "提示信息"
End Function

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'目的：生成EXCEL 报表
'输入：
'输出：
'作者：苏江
'编写日期：2001-1-4
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Private Function bCreateExcel() As Boolean
On Error GoTo err
    Dim oFile As New FileSystemObject
    Dim oExcel As New Excel.Application
    Dim i As Integer
    Dim j As Long
    Dim iRtn As Integer
    Dim oCreateExcel As Object
    
    bCreateExcel = True
    If grecCheque.State = 0 Then
        bCreateExcel = False
        Exit Function
    End If
    
    sFileName = Replace(App.Path + "\sinfarch\fileExcel.xls", "\\", "\")
    
    If oFile.FileExists(Trim(sFileName)) Then                  '''决定是否建立EXCEL表格
        oFile.DeleteFile sFileName, True
    End If
    
    Set oCreateExcel = CreateObject("excel.sheet")         '''建立EXCEL表格
    oCreateExcel.SaveAs Trim(sFileName)                    '''保存文件
    
    With oExcel
        .Visible = False
        .ScreenUpdating = False
        '.Workbooks.Open FileName:=Trim(sFileName)
        .Workbooks.Open Trim(sFileName)
        
        .Range("A1").Select                       '''选择字段位置
        .ActiveCell.FormulaR1C1 = "发票状态"         '''给相应位置写入字段名
        .Range("B1").Select                         '''选择字段位置
        .ActiveCell.FormulaR1C1 = "发票号码"         '''给相应位置写入字段名
        
        .Range("C1").Select                         '''选择字段位置
        .ActiveCell.FormulaR1C1 = "收费项目"          '''给相应位置写入字段名
        
        .Range("D1").Select                         '''选择字段位置
        .ActiveCell.FormulaR1C1 = "开票金额"         '''给相应位置写入字段名
        
        .Range("E1").Select                        '''选择字段位置
        .ActiveCell.FormulaR1C1 = "开票人"         '''给相应位置写入字段名
        
        .Range("F1").Select                        '''选择字段位置
        If gsChequeType = "C" Then
            If Len(Trim(frmChequeInfo.sb.Panels("work").Text)) > 7 Then
                .ActiveCell.FormulaR1C1 = frmChequeInfo.sb.Panels("work").Text         '''给相应位置写入字段名
            Else
                .ActiveCell.FormulaR1C1 = "已缴税款"
            End If
        Else
            If Left(frmChequeInfo.trvbuild.SelectedItem.Text, 4) <> "代扣代缴" And gsChequeType = "B" Then
                .ActiveCell.FormulaR1C1 = "顾客名称"         '''给相应位置写入字段名
            Else
                .ActiveCell.FormulaR1C1 = "收款人"           '''给相应位置写入字段名
            End If
    
        End If
        
        .Range("G1").Select                        '''选择字段位置
        .ActiveCell.FormulaR1C1 = "开票日期"        '''给相应位置写入字段名
        
        .Range("H1").Select                         '''选择字段位置
        .ActiveCell.FormulaR1C1 = "备注"            '''给相应位置写入字段名
       
       
        j = 2
        For j = 2 To grecCheque.RecordCount + 1
            DoEvents
            For i = 0 To 10
                If i <> 6 And i <> 8 And i <> 9 Then
                    .Range(GetFieldsCol(i + 1, j)).Select   '''选择字段位置
                    frmChequeInfo.fgCheque.Row = j - 1
                    frmChequeInfo.fgCheque.Col = i
                    .ActiveCell.FormulaR1C1 = frmChequeInfo.fgCheque.Text              '''给相应位置写入字段名
                End If
            Next
            
            DoEvents
            If mbTransOut Then                                                          '''用户停止导出数据
                iRtn = MsgBox("是否要停止数据库导出？", vbYesNo + vbQuestion, "提示信息")
                If iRtn = vbYes Then
                    .Visible = True                                            '''保存EXCEL 数据
                    .ScreenUpdating = True
                    Exit Function                                                       '''确定是否要取消数据转换
                Else
                    mbTransOut = False
                End If
            End If
        Next
        
        .Visible = True                                            '''保存EXCEL 数据
        .ScreenUpdating = True
    End With
    Exit Function
err:
    MsgBox err.Description, vbOKOnly, "提示信息"
End Function

'**************************************************************************
'功能：生成行列
'输入:行号
'输出：vRow 为行号,vCol 为列号
'作者：苏江
'日期：2000-9-12
'**************************************************************************
Private Function GetFieldsCol(ByVal vRow As Integer, vCol As Long) As String
    Dim sCol As String
    
    If vRow = 8 Then vRow = 7
    If vRow = 11 Then vRow = 8
    
    If vRow < 27 Then
        GetFieldsCol = CStr(Chr(vRow + 64)) + CStr(vCol)
    ElseIf 26 < vRow < 53 Then
        GetFieldsCol = CStr(Chr(65)) + CStr(Chr(vRow + 38)) + CStr(vCol)
    ElseIf 52 < vRow < 79 Then
        GetFieldsCol = CStr(Chr(65) + Chr(66) + Asc(vRow + 12)) + CStr(vCol)
    ElseIf 78 < vRow < 105 Then
        GetFieldsCol = CStr(Chr(65) + Chr(66) + Chr(67) + Chr(vRow - 14)) + CStr(vCol)
    Else
        GetFieldsCol = CStr(Chr(65) + Chr(66) + Chr(67) + _
                                  Chr(68) + Chr(vRow - 40)) + CStr(vCol)
    End If

End Function


'获取没有上报的数据,并生成上报文件
Private Function bGetReportData() 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 sCAFile As String
    Dim sDate As String
    Dim sUnitCode As String
    
    Me.MousePointer = 11
    bGetReportData = False
    sDate = Format(Now, "yyyy-mm") + "-01"
    If gsChequeType = "B" Then
        sTable = " buildchequeinfo"
        StrSQL = "select * from " + gsconTabel + sTable + " where (datareport <>'Y' " + _
                               "or datareport is null or datareport='') and opencheque ='Y'"
    ElseIf gsChequeType = "E" Then
        sTable = " estatechequeinfo"
        StrSQL = "select * from " + gsconTabel + sTable + " where (datareport <>'Y' " + _
                               "or datareport is null or datareport='') and opencheque ='Y'"
    Else
        sTable = " commonchequeinfo"
        StrSQL = "select * from " + gsconTabel + sTable + " where (datareport <>'Y' " + _
                               "or datareport is null or datareport='') "
    End If
    
    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
    
    sFilePath = Replace(App.Path + "\filebak", "\\", "\")
    sCAFile = Replace(App.Path + "\cafile", "\\", "\")
    If objFile.FileExists(sFilePath + "\cheque.dat") = True Then
        objFile.DeleteFile sFilePath + "\cheque.dat"
    End If
    
    recData.Save sFilePath + "\cheque.dat"
    
    Do Until recData.EOF
        sChequeCode = IIf(sChequeCode = "", recData.Fields("chequecode"), _
                        sChequeCode + "','" + recData.Fields("chequecode"))  '''获取上报数据的发票号码
        recData.MoveNext
    Loop
    
    If bGetDetailData(sChequeCode) = False Then Exit Function                '''生成发票详细数据的上报数据
    If bGetItemInfo = False Then Exit Function                               '''上报项目信息