Option Explicit
'2017-11-24 20:05 乔治
'原创代码,转载请注明出处
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