原创-VBA金税盘开票XML生成

'2017-11-24 20:05 乔治

'原创代码，转载请注明出处

Option Explicit

Public Type SE
    S As Integer
    E As Integer
End Type
''''''''''''''''''''''''''''''''''''''''''''''''
''''''''取得客户编码.txt文件总行数''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
Function GetLine(ByVal TargetFile As String) As Integer
    Dim m As Integer
    Dim NextLine As String
    Open TargetFile For Input As #1
    Do Until EOF(1)
        Line Input #1, NextLine
        m = m + 1
    Loop
    Close #1
    GetLine = m
End Function
''''''''''''''''''''''''''''''''''''''''''''''''
''''开始RGB(0, 255, 0)，结束RGB(255, 0, 0)''''''
''''''''''''''''''''''''''''''''''''''''''''''''
Function GetSE() As SE
    Dim j As Integer
    Dim LastRow As Integer
        LastRow = Application.CountA(Sheets(1).Range("F:F"))
        For j = 1 To LastRow
            If Sheets(1).Cells(j, 6).Font.Color = RGB(0, 255, 0) Then GetSE.S = j
            If Sheets(1).Cells(j, 6).Font.Color = RGB(255, 0, 0) Then GetSE.E = j
        Next
        If GetSE.E = 0 Then GetSE.E = GetSE.S
End Function


Sub Inv2Xml()
    Dim Line, TotalRow As Integer
    Dim i, l, k, z, y As Integer
''''''''''''''''''''''''''''''''''''''''''''''''
'金税盘导出的客户编码，TXT格式，默认为逗号分隔符
''''''''''''''''''''''''''''''''''''''''''''''''
    Const TargetFile As String = "C:\Users\Administrator\Desktop\客户编码.txt"
    Application.ScreenUpdating = False
        Line = GetLine(TargetFile)
    ReDim Arr_Line(Line - 1) '获取客户编码
        i = 1
        Open TargetFile For Input As #1
            Do While Not EOF(1)
                Line Input #1, Arr_Line(i - 1)
                i = i + 1
            Loop
        Close #1
        Sheets(2).Select
        Cells.Delete
        Cells(1, 1) = "编码,名称,简码,税号,地址,电话,银行,账号,邮件地址,备注,身份证校验"
        For k = 1 To Line - 3
          Cells(k + 1, 1).Value = Arr_Line(k + 2)
        Next k
''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''简单的分列''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
        Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
            :=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), _
            Array(7, 2), Array(8, 2), Array(9, 2)), TrailingMinusNumbers:=True
            
        Columns("F:F").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        
        Columns("E:E").TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
            :=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True
            
        Columns("G:G").TextToColumns Destination:=Range("G1"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
            :=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True
            
        Range("E1").Value = "地址"
        Range("F1").Value = "电话"
        Range("G1").Value = "银行"
        Range("H1").Value = "账号"
        Range("A:A,C:C,I:I,J:J,K:K,L:L,M:M").Delete Shift:=xlToLeft
        TotalRow = Application.CountA(Sheets(2).Range("A:A"))
''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''建立字典'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
    
        Static Tin As New Scripting.Dictionary
        Static Addr As New Scripting.Dictionary
        Static Tel As New Scripting.Dictionary
        Static Bank As New Scripting.Dictionary
        Static Acc As New Scripting.Dictionary
        
        For l = 2 To TotalRow
            Tin(Cells(l, 1).Value) = Cells(l, 2).Value
            Addr(Cells(l, 1).Value) = Cells(l, 3).Value
            Tel(Cells(l, 1).Value) = Cells(l, 4).Value
            Bank(Cells(l, 1).Value) = Cells(l, 5).Value
            Acc(Cells(l, 1).Value) = Cells(l, 6).Value
        Next
''''''''''''''''''''''''''''''''''''''''''''''''
'''''检查开票资料完整性，不完整则退出模块'''''''
''''''''''''''''''''''''''''''''''''''''''''''''
        Sheets(3).Select                        '如果没有3个sheet会下标超限出错
        Cells.Delete
        Call GetSE
   
        z = 0
        For y = GetSE.S To GetSE.E
            If Not Tin.Exists(Sheets(1).Cells(y, 7).Value) Then
                z = z + 1
                Sheets(3).Cells(z, 1).Value = Sheets(1).Cells(y, 7).Value
            End If
        Next
        If z <> 0 Then
        Exit Sub
        Else
        End If
    Dim InvFile As String
    If Dir("d:\xml\Inv2Xml\", vbDirectory) <> "" Then
    Else: MkDir "d:\xml\Inv2Xml\"
    End If
    InvFile = "d:\xml\Inv2Xml\" & "InvoiceModel_" & Format(Date, "YYYYMMDD") & "_" & Sheets(1).Cells(GetSE.S, 6) & "~" & Sheets(1).Cells(GetSE.E, 6) & ".xml"
''''''''''''''''''''''''''''''''''''''''''''''''
   
    Dim Inv As DOMDocument60                    'xml文档
    Dim Ver As IXMLDOMProcessingInstruction     '进程指令
    Dim Arr_Inv As Variant                      '定义数组
    Dim Counter_FpLine As Integer               '发票计数器
'''''''''''''''''根节点'''''''''''''''''''''''''
    Dim N_Kp As IXMLDOMElement                  '开票
'''''''''''''''''一级节点'''''''''''''''''''''''
    Dim N_Version As IXMLDOMElement             '版本，有此节点，则表示用带分类编码
    Dim N_Fpxx As IXMLDOMElement                '发票信息
'''''''''''''''''二级节点'''''''''''''''''''''''
    Dim N_Zsl As IXMLDOMElement                 '总数量
    Dim N_Fpsj As IXMLDOMElement                '发票数据
'''''''''''''''''三级节点'''''''''''''''''''''''
    Dim N_Fp As IXMLDOMElement                  '发票
'''''''''''''''''四级节点'''''''''''''''''''''''
    Dim N_Djh As IXMLDOMElement                 '单据号，20字节
    Dim N_Gfmc As IXMLDOMElement                '购方名称，100字节
    Dim N_Gfsh As IXMLDOMElement                '购方税号，100字节
    Dim N_Gfyhzh As IXMLDOMElement              '购方银行账号，100字节
    Dim N_Gfdzdh As IXMLDOMElement              '购方地址电话，100字节
    Dim N_Bz As IXMLDOMElement                  '备注，240字节
    Dim N_Fhr As IXMLDOMElement                 '复核人，8字节
    Dim N_Skr As IXMLDOMElement                 '收款人，8字节
    Dim N_Spbmbbh As IXMLDOMElement             '商品编码版本号，20字节，必输项
    Dim N_Hsbz As IXMLDOMElement                '含税标志：含税标志0：不含税税率，1：含税税率，2：差额税;中外合作油气田（原海洋石油）5%税率、1.5%税率为1，差额税为2，其他为0；
    Dim N_Spxx As IXMLDOMElement                '商品信息
''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''五级节点'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
    Dim N_Sph As IXMLDOMElement                 '商品行
''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''六级节点'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
    Dim N_Xh As IXMLDOMElement                  '序号
    Dim N_Spmc As IXMLDOMElement                '商品名称，100字节，金额为负数时此行是折扣行，折扣行的商品名称应与上一行的商品名称一致
    Dim N_Ggxh As IXMLDOMElement                '规格型号，40字节
    Dim N_Jldw As IXMLDOMElement                '计量单位，32字节
    Dim N_Spbm As IXMLDOMElement                '商品编码，19字节，必输项
    Dim N_Syyhzcbz As IXMLDOMElement            '使用优惠政策标识，1字节，是否使用优惠政策标识0：不使用，1：使用
    Dim N_Qyspbm As IXMLDOMElement              '企业商品编码，20字节
    Dim N_Lslbz As IXMLDOMElement               '零税率标志，1字节，零税率标识空：非零税率，0：出口退税，1：免税，2：不征收，3普通零税率
    Dim N_Yhzcsm As IXMLDOMElement              '优惠政策说明
    Dim N_Dj As IXMLDOMElement                  '单价，为不含税单价（中外合作油气田（原海洋石油）5%税率，单价为含税单价）
    Dim N_Sl As IXMLDOMElement                  '数量
    Dim N_Je As IXMLDOMElement                  '金额，当金额为负数时为折扣行，为不含税金额
    Dim N_Slv As IXMLDOMElement                 '税率
    Dim N_Kce As IXMLDOMElement                 '扣除额，用于差额税计算
''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''常量赋值'''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
    Const Review As String = "陈琴"
    Const Payee As String = "乐雪梅"
    Const Code_Version As String = "14.0"
    Const Hs_Code As String = "1010202010000000000"
    Const R_Unit As String = "立方米"
    Const Corp_Code As String = "002"
    Const Crude_Wood As String = "原木"
''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''生成根节点'''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
    Set Inv = New MSXML2.DOMDocument60
    Set N_Kp = Inv.createElement("Kp")
    Set Inv.DocumentElement = N_Kp
''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''生成一级节点'''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
    Set N_Version = Inv.createNode(NODE_ELEMENT, "Version", "")
    N_Version.Text = "2.0"
    Set N_Fpxx = Inv.createNode(NODE_ELEMENT, "Fpxx", "")
    N_Kp.appendChild N_Version
    N_Kp.appendChild N_Fpxx
''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''生成二级节点'''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
    Set N_Zsl = Inv.createNode(NODE_ELEMENT, "Zsl", "")
    Set N_Fpsj = Inv.createNode(NODE_ELEMENT, "Fpsj", "")
    N_Fpxx.appendChild N_Zsl
    N_Fpxx.appendChild N_Fpsj
''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''循环生成三级节点'''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
    Counter_FpLine = 0
    Arr_Inv = Sheets(1).Range("A" & (GetSE.S - 1) & ":S" & GetSE.E)
    For i = 2 To UBound(Arr_Inv)
        If Arr_Inv(i, 6) <> Arr_Inv((i - 1), 6) Then
            Counter_FpLine = Counter_FpLine + 1
            Set N_Fp = Inv.createNode(NODE_ELEMENT, "Fp", "")
''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''循环生成四级节点'''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
            Set N_Djh = Inv.createNode(NODE_ELEMENT, "Djh", "")
            Set N_Gfmc = Inv.createNode(NODE_ELEMENT, "Gfmc", "")
            Set N_Gfsh = Inv.createNode(NODE_ELEMENT, "Gfsh", "")
            Set N_Gfyhzh = Inv.createNode(NODE_ELEMENT, "Gfyhzh", "")
            Set N_Gfdzdh = Inv.createNode(NODE_ELEMENT, "Gfdzdh", "")
            Set N_Bz = Inv.createNode(NODE_ELEMENT, "Bz", "")
            Set N_Fhr = Inv.createNode(NODE_ELEMENT, "Fhr", "")
            Set N_Skr = Inv.createNode(NODE_ELEMENT, "Skr", "")
            Set N_Spbmbbh = Inv.createNode(NODE_ELEMENT, "Spbmbbh", "")
            Set N_Hsbz = Inv.createNode(NODE_ELEMENT, "Hsbz", "")
            Set N_Spxx = Inv.createNode(NODE_ELEMENT, "Spxx", "")
            N_Djh.Text = Arr_Inv(i, 6)
            N_Gfmc.Text = Arr_Inv(i, 7)
            N_Gfsh.Text = Tin(Arr_Inv(i, 7))
            N_Gfyhzh.Text = Bank(Arr_Inv(i, 7)) & " " & Acc(Arr_Inv(i, 7))
            N_Gfdzdh.Text = Addr(Arr_Inv(i, 7)) & " " & Tel(Arr_Inv(i, 7))
            N_Fhr.Text = Review
            N_Skr.Text = Payee
            N_Spbmbbh.Text = Code_Version
            N_Hsbz.Text = "0"
            N_Fp.appendChild N_Djh
            N_Fp.appendChild N_Gfmc
            N_Fp.appendChild N_Gfsh
            N_Fp.appendChild N_Gfyhzh
            N_Fp.appendChild N_Gfdzdh
            N_Fp.appendChild N_Bz
            N_Fp.appendChild N_Fhr
            N_Fp.appendChild N_Skr
            N_Fp.appendChild N_Spbmbbh
            N_Fp.appendChild N_Hsbz
            N_Fp.appendChild N_Spxx
            N_Fpsj.appendChild N_Fp
        End If
''''''''''''''''''''''''''''''''''''''''''''''''
        Set N_Xh = Inv.createNode(NODE_ELEMENT, "Xh", "")
        Set N_Spmc = Inv.createNode(NODE_ELEMENT, "Spmc", "")
        Set N_Ggxh = Inv.createNode(NODE_ELEMENT, "Ggxh", "")
        Set N_Jldw = Inv.createNode(NODE_ELEMENT, "Jldw", "")
        Set N_Spbm = Inv.createNode(NODE_ELEMENT, "Spbm", "")
        Set N_Syyhzcbz = Inv.createNode(NODE_ELEMENT, "Syyhzcbz", "")
        Set N_Qyspbm = Inv.createNode(NODE_ELEMENT, "Qyspbm", "")
        Set N_Lslbz = Inv.createNode(NODE_ELEMENT, "Lslbz", "")
        Set N_Yhzcsm = Inv.createNode(NODE_ELEMENT, "Yhzcsm", "")
        Set N_Dj = Inv.createNode(NODE_ELEMENT, "Dj", "")
        Set N_Sl = Inv.createNode(NODE_ELEMENT, "Sl", "")
        Set N_Je = Inv.createNode(NODE_ELEMENT, "Je", "")
        Set N_Slv = Inv.createNode(NODE_ELEMENT, "Slv", "")
        Set N_Kce = Inv.createNode(NODE_ELEMENT, "Kce", "")
        N_Xh.Text = Arr_Inv(i, 2)
        N_Spmc.Text = Crude_Wood
        N_Jldw.Text = R_Unit
        N_Spbm.Text = Hs_Code
        N_Qyspbm.Text = Corp_Code
        N_Dj.Text = Arr_Inv(i, 10)
        N_Sl.Text = Arr_Inv(i, 9)
        N_Je.Text = Arr_Inv(i, 12)
        N_Slv.Text = Arr_Inv(i, 13)
''''''''''''''''''''''''''''''''''''''''''''''''
        Set N_Sph = Inv.createNode(NODE_ELEMENT, "Sph", "")
        N_Sph.appendChild N_Xh
        N_Sph.appendChild N_Spmc
        N_Sph.appendChild N_Ggxh
        N_Sph.appendChild N_Jldw
        N_Sph.appendChild N_Spbm
        N_Sph.appendChild N_Syyhzcbz
        N_Sph.appendChild N_Qyspbm
        N_Sph.appendChild N_Lslbz
        N_Sph.appendChild N_Yhzcsm
        N_Sph.appendChild N_Dj
        N_Sph.appendChild N_Sl
        N_Sph.appendChild N_Je
        N_Sph.appendChild N_Slv
        N_Sph.appendChild N_Kce
''''''''''''''''''''''''''''''''''''''''''''''''
        Inv.getElementsByTagName("Spxx").Item(Counter_FpLine - 1).appendChild N_Sph
        If Arr_Inv(i, 6) <> Arr_Inv((i - 1), 6) Then
            Inv.getElementsByTagName("Bz").Item(Counter_FpLine - 1).Text = Arr_Inv(i, 5)
        Else
            Inv.getElementsByTagName("Bz").Item(Counter_FpLine - 1).Text = Inv.getElementsByTagName("Bz").Item(Counter_FpLine - 1).Text & vbCrLf & Arr_Inv(i, 5)
        End If
    Next
    N_Zsl.Text = Inv.getElementsByTagName("Fp").Length
''''''''''''''''''''''''''''''''''''''''''''''''
    Set Ver = Inv.createProcessingInstruction("xml", "version='1.0' encoding='GBK'")
    Call Inv.insertBefore(Ver, Inv.childNodes(0))
    Inv.Save InvFile
''''''''''''''''''''''''''''''''''''''''''''''''
    Tin.RemoveAll
    Addr.RemoveAll
    Tel.RemoveAll
    Bank.RemoveAll
    Acc.RemoveAll
    Set Tin = Nothing
    Set Addr = Nothing
    Set Tel = Nothing
    Set Bank = Nothing
    Set Acc = Nothing
    Set Inv = Nothing
    Set N_Kp = Nothing
    Set N_Version = Nothing
    Set N_Fpxx = Nothing
    Set N_Zsl = Nothing
    Set N_Fpsj = Nothing
    Set N_Fp = Nothing
    Set N_Djh = Nothing
    Set N_Gfmc = Nothing
    Set N_Gfsh = Nothing
    Set N_Gfyhzh = Nothing
    Set N_Gfdzdh = Nothing
    Set N_Bz = Nothing
    Set N_Fhr = Nothing
    Set N_Skr = Nothing
    Set N_Spbmbbh = Nothing
    Set N_Hsbz = Nothing
    Set N_Spxx = Nothing
    Set N_Sph = Nothing
    Set N_Xh = Nothing
    Set N_Spmc = Nothing
    Set N_Ggxh = Nothing
    Set N_Jldw = Nothing
    Set N_Spbm = Nothing
    Set N_Syyhzcbz = Nothing
    Set N_Qyspbm = Nothing
    Set N_Lslbz = Nothing
    Set N_Yhzcsm = Nothing
    Set N_Dj = Nothing
    Set N_Sl = Nothing
    Set N_Je = Nothing
    Set N_Slv = Nothing
    Set N_Kce = Nothing
    Application.ScreenUpdating = True
End Sub