标签：erp data docx source png exit col tin 增加
去年五一，用ExcelDNA+C#的方式写了一个输出河北股权证的插件工具。
前段时间又使用Excel vba的方式写了几个输出股权证的工具。
前面一直使用Excel作为输出文件，对于左右两页格子不等高的证书，使用Excel输出便出现了不能解决的难题——在Excel中不能随意定义行高，这样就难以通过合并单元格的形式实现左右两页合为一页输出，而左右分两页输出会增加打印时的送纸次数，影响效率。
那么，使用Word输出是不是一个更好的选择？经测试，效果是理想的。通过分栏的形式，在一页的左右两栏分别插入表格，对表格的行高、列宽、地址进行定义，提取Excel数据填写Word模板，另存Word文件。
实现代码如下：
注意
①代码宿主为Excel，因为博主已经做了现成的Ribbon，懒得换为Word；
②为方便操作者使用，代码中Word对象与FSO对象的创建采用了“后期绑定”；
③IsFileExist函数用于主过程中调用以判断所需的文件是否存在。
Sub Generate(control As IRibbonControl)
Dim wordApp As Object
Dim sourceBook, institutionBook As Workbook
Dim templateDoc As Object
Dim wsSource, wsInstitution As Worksheet
Dim mainFolder, institutionCode, desFolderPath, newDocName As String
Dim rowCount, indexOfTable, indexOfNo3 As Integer
Set wordApp = CreateObject("Word.Application")
wordApp.ScreenUpdating = False
wordApp.DisplayAlerts = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
mainFolder = ThisWorkbook.path
‘ get data source book
If IsFileExists(mainFolder + "\" + "成员信息.xlsx") Then
Workbooks.Open Filename:=mainFolder + "\" + "成员信息.xlsx"
Set sourceBook = ActiveWorkbook
Else
MsgBox "成员信息.xlsx 在当前路径下不存在！"
Exit Sub
End If
‘ get institution infos book
If IsFileExists(mainFolder + "\" + "机构信息.xls") Then
Workbooks.Open Filename:=mainFolder + "\" + "机构信息.xls"
Set institutionBook = ActiveWorkbook
Set wsInstitution = institutionBook.Worksheets(1)
Else
MsgBox "机构信息.xls 在当前路径下不存在！"
sourceBook.Close
Exit Sub
End If
‘ get template word document
If IsFileExists(mainFolder + "\" + "证书模板.docx") Then
wordApp.Documents.Open Filename:=mainFolder + "\" + "证书模板.docx"
Set templateDoc = wordApp.ActiveDocument
Else
MsgBox "证书模板.docx"
sourceBook.Close
institutionBook.Close
Exit Sub
End If
For Each wsSource In sourceBook.Worksheets
indexOfInstInfoRow = wsInstitution.Cells.Find(what:=wsSource.Range("A2").Text, After:=[b1], searchorder:=XlSearchOrder.xlByColumns, _
SearchDirection:=XlSearchDirection.xlPrevious).Row
‘社会信用代码
templateDoc.Tables(1).Cell(1, 2).Range = wsInstitution.Cells(indexOfInstInfoRow, 1).Value
‘组织名称
templateDoc.Tables(1).Cell(2, 2).Range = wsInstitution.Cells(indexOfInstInfoRow, 2).Value
‘法定代表人
templateDoc.Tables(1).Cell(4, 2).Range = wsInstitution.Cells(indexOfInstInfoRow, 3).Value
‘机构区划代码，用于生成股权证号
institutionCode = wsInstitution.Cells(indexOfInstInfoRow, 4).Text
‘create folder named as each worksheet‘s name.
desFolderPath = mainFolder + "\" + wsSource.Name
If Dir(desFolderPath, vbDirectory) = vbNullString Then
MkDir desFolderPath
End If
‘
rowCount = wsSource.Range("e65536").End(xlUp).Row
For i = rowCount To 4 Step -1
k = k + 1
If wsSource.Range("A" & i).Text <> "" Then
templateDoc.Tables(1).Cell(6, 2).Range = "GQZ" + institutionCode + Format(wsSource.Range("A" & i), "0000")
‘clear tables‘comtents
For Each oCell In templateDoc.Tables(2).Range.Cells
oCell.Range.Text = ""
Next oCell
For r = 1 To 13
For c = 1 To 4
templateDoc.Tables(3).Cell(r, c).Range.Text = ""
Next c
Next r
indexOfTable = 1
indexOfNo3 = 1
For j = i To i + k - 1 Step 1
templateDoc.Tables(2).Cell(indexOfTable, 1).Range.Text = wsSource.Cells(j, 4).Value
templateDoc.Tables(2).Cell(indexOfTable, 2).Range.Text = wsSource.Cells(j, 6).Value
templateDoc.Tables(2).Cell(indexOfTable, 3).Range.Text = wsSource.Cells(j, 8).Value
templateDoc.Tables(2).Cell(indexOfTable, 4).Range.Text = wsSource.Cells(j, 9).Value
templateDoc.Tables(3).Cell(indexOfTable, 2).Range.Text = wsSource.Cells(j, 4).Value
templateDoc.Tables(3).Cell(indexOfTable, 3).Range.Text = 10
indexOfTable = indexOfTable + 1
If indexOfTable = 13 Then
Exit For
End If
Next j
templateDoc.Tables(3).Cell(14, 3).Range.Text = 10 * k
k = 0
‘save as a new doc
newDocName = desFolderPath & "\" & wsSource.Range("A" & i).Text & wsSource.Range("B" & i).Text & "_股权证书.docx"
templateDoc.SaveAs Filename:=newDocName, FileFormat:=wdFormatXMLDocument
End If
Next i
Next
sourceBook.Close
institutionBook.Close
templateDoc.Close
wordApp.Quit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "输出完成！"
End Sub
Function IsFileExists(ByVal strFileName As String) As Boolean
Dim objFileSystem As Object
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
If objFileSystem.fileExists(strFileName) = True Then
IsFileExists = True
Else
IsFileExists = False
End If
End Function
【Excel Word VBA】农村集体产权制度改革“股权证”打印文件制作
标签：erp data docx source png exit col tin 增加
原文地址：https://www.cnblogs.com/yzhyingcool/p/14055521.html
