|
|
楼主 |
发表于 2023-11-21 10:59
|
显示全部楼层
提起发票信息的函数: GetInfoInvoice
发票样式:
识别的内容:
函数代码:
- Rem *********************************
- Rem ******* 北极狐工作室出品 ******
- Rem ******* QQ：14885553 ******
- Rem *********************************
- Option Explicit '//强制声明变量
- Sub FA_提取PDF发票信息()
- Dim PathPDF, StrXiangMu
- Dim ARX
-
- ' PathPDF = ThisWorkbook.Path & "\发票\10月发票\CA001.PDF"
- ' StrXiangMu = "*经营租赁*通行费,*经营租赁*代收通行费"
-
- PathPDF = ThisWorkbook.Path & "\发票\F001.PDF"
- StrXiangMu = "*供电*电费"
-
- ARX = GetInfoInvoice(PathPDF:=PathPDF, StrXiangMu:=StrXiangMu)
- Worksheets("发票识别A").Range("A2").Resize(UBound(ARX, 1), UBound(ARX, 2)) = ARX
-
- MsgBox "OK"
- End Sub
- Function GetInfoInvoice(ByVal PathPDF As String, ByVal StrXiangMu As String, Optional ByVal StrFenLei As String = "")
- Rem PathPDF PDF格式的发票文件
- Rem StrXiangMu 需要提取那些项目名称,可以多个 "*经营租赁*通行费,*经营租赁*代收通行费"
- Rem StrFenLei 输出结果的部分 发票明细部分的标题 一般8个 例如: 项目名称,车牌号,类型,开始日期,结束日期,金额,税额,税率
- Rem ARX = GetInfo(PathPDF:=PathPDF, StrXiangMu:=StrXiangMu)
-
- Dim I, X, ICOL, INTA, INTB, INTC As Long
- Dim StrE, StrX, Mystr, PathSave, ZCM As String
- Dim BL As Boolean
- Dim PDFDLL, FSO, STM As Object
- Dim ARX, CRX, DRX, ERX, FRX, ZAC, ZAD
-
- 'On Error Resume Next
-
- Rem 发票不同 一次只能获取一类发票的内容
- Rem 项目名称: StrXiangMu 和 各列内容:StrFenLei 都是不一样的
- Rem StrXiangMu = "*经营租赁*通行费,*经营租赁*代收通行费"
- Rem StrXiangMu = "*供电*电费"
- Rem If StrFenLei = "" Then StrFenLei = "项目名称,车牌号,类型,开始日期,结束日期,金额,税额,税率"
- If StrFenLei = "" Then StrFenLei = "项目名称,规格,单位,数量,单价,金额,税额,税率"
-
- Rem 文件名,发票代码,发票号码,开票日期,价税合计 是固定的
- StrFenLei = "文件名,发票代码,发票号码,开票日期,价税合计," & StrFenLei
- CRX = Split(StrFenLei, ",")
- Rem 结果的标题
- Set ZAC = CreateObject("Scripting.Dictionary")
- For X = 0 To UBound(CRX)
- ZAC(CRX(X)) = X + 1
- Next
-
- Rem 保存发票内容的文本文件
- PathSave = ThisWorkbook.Path & "\TempTxt.txt"
- Set FSO = CreateObject("Scripting.FileSystemObject")
- If FSO.FileExists(PathSave) = True Then
- Kill PathSave '//删除文件
- End If
-
- Rem 获取发票文本, 也可以用纯VBA的代码获取
- Set PDFDLL = CreateObject("GTDPDFPlugIn.PDFClass")
- ZCM = "QQ14885553"
- BL = PDFDLL.ExtractTextFromPDF(PathPDF:=PathPDF, PathSave:=PathSave, StrPages:="", StrArea:="", ZCM:=ZCM)
-
- Rem 读取文本 发票内容
- Set STM = CreateObject("Adodb.Stream")
- STM.Type = 2
- STM.Mode = 3
- STM.CharSet = "utf-8"
- STM.Open
- STM.LoadFromFile PathSave
- Mystr = STM.ReadText '//文本文件内容
- STM.Close
-
- Rem 分解发票内容
- INTA = 0
- DRX = Split(StrXiangMu, ",")
- ERX = Split(Mystr, vbCrLf)
- ReDim ARX(1 To 50, 1 To UBound(CRX) + 1)
- Set ZAD = CreateObject("Scripting.Dictionary")
-
- For I = 0 To UBound(ERX)
- INTB = INTA
- For X = 0 To UBound(DRX)
- Rem 每一行的内容
- If InStr(ERX(I), DRX(X)) > 0 Then
- Rem 符合项目名称的要求
- StrX = Split(WorksheetFunction.Trim(ERX(I)), DRX(X))(1)
- INTA = INTA + 1
- FRX = Split(StrX, " ")
- ARX(INTA, ZAC(CRX(5))) = DRX(X)
- ARX(INTA, ZAC(CRX(6))) = Split(StrX, " ")(1)
- ARX(INTA, ZAC(CRX(7))) = Split(StrX, " ")(2)
- ARX(INTA, ZAC(CRX(8))) = Split(StrX, " ")(3)
- ARX(INTA, ZAC(CRX(9))) = Split(StrX, " ")(4)
- ARX(INTA, ZAC(CRX(10))) = Split(StrX, " ")(5)
- ARX(INTA, ZAC(CRX(11))) = Split(StrX, " ")(6)
- ARX(INTA, ZAC(CRX(12))) = Split(StrX, " ")(7)
- End If
- Next
-
- Rem 当前发票的: 文件名,发票代码,发票号码,开票日期,价税合计
- ZAD("文件名") = Dir(PathPDF, vbNormal)
- StrE = Replace(ERX(I), "：", ":")
- If InStr(StrE, "发票代码:") > 0 Then
- ZAD("发票代码") = Trim(Split(StrE, "发票代码:")(1))
- End If
- If InStr(StrE, "发票号码:") > 0 Then
- ZAD("发票号码") = Trim(Split(StrE, "发票号码:")(1))
- End If
- If InStr(StrE, "开票日期:") > 0 Then
- ZAD("开票日期") = Replace(WorksheetFunction.Trim(Left(Split(StrE, "开票日期:")(1), 12)), " ", "-")
- End If
- If InStr(ERX(I), "（小写）") > 0 Then
- ZAD("价税合计") = Trim(Split(ERX(I), "（小写）")(1))
- End If
- Next
-
- Rem 整体信息 每行相同
- For X = 1 To UBound(ARX, 1)
- ARX(X, ZAC("文件名")) = ZAD("文件名")
- ARX(X, ZAC("发票代码")) = ZAD("发票代码")
- ARX(X, ZAC("发票号码")) = ZAD("发票号码")
- ARX(X, ZAC("开票日期")) = ZAD("开票日期")
- ARX(X, ZAC("价税合计")) = ZAD("价税合计")
- Next
-
- Rem 去掉多余行
- ReDim TRX(1 To INTA, 1 To UBound(ARX, 2))
- For X = 1 To INTA
- For ICOL = 1 To UBound(ARX, 2)
- TRX(X, ICOL) = ARX(X, ICOL)
- Next
- Next
-
- GetInfoInvoice = TRX
- End Function
|
|
楼主: opiona
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-11-3 12:52
