|
|
以下是一段可以批量生成合同的代码，是可以运行的。
只是有几个问题想请教下下坛友们：
1、"生成合同"按钮点击了没用、每次需要在代码窗口里手动运行；
2、还要弹出窗口选择数据区域(如果添加了的话，帮备注下可以看懂这样，后期可能有变动)、然后再选择word模板文件，再选择存放位置等，问下要直接生成合同到文件夹里的话要加什么代码啊？
3、日期需要单独改下公式，
4、金额需要加大写；
5、如果可以看到生成的过程，比如 已生成xx份/合计xx份！ 就好了，因为可能有点多；
Private Sub cmd_makedoc_Click()
On Error GoTo Err_cmdExportToWord_Click
Dim objApp As Object 'Word.Application
Dim objDoc As Object 'Word.Document
Dim strTemplates As String '模板文件路径名
Dim strFileName As String '将数据导出到此文件
Dim i As Integer
Dim contact_NO As String
Dim side_A As String
Dim side_B As String
Dim data_areas As Range
Dim total_data As Integer
Set data_areas = Application.InputBox(prompt:="请鼠标选择需要输出数据的区域", Title:="选择", Type:=8) '选取输出的数据区域
i = data_areas.Row '获取选取区域开始行所在行号
j = data_areas.Rows.Count ' 获取选取区域总行数
With Application.FileDialog(msoFileDialogFilePicker) '选择模板文件
.Filters.Add "word文件", "*.doc*", 1
.AllowMultiSelect = False
If .Show Then strTemplates = .SelectedItems(1) Else Exit Sub
End With
With Application.FileDialog(msoFileDialogFolderPicker) '获取输出的文件存储路径
If .Show = False Then Exit Sub
Path = .SelectedItems(1)
End With
Set objApp = CreateObject("Word.Application")
objApp.Visible = False
For k = i To i + j - 1
contact_NO = Cells(k, 1)
side_A = Cells(k, 2)
side_B = Cells(k, 3)
side_C = Cells(k, 4)
side_D = Cells(k, 5)
side_E = Cells(k, 6)
side_F = Cells(k, 7)
side_G = Cells(k, 8)
Set objDoc = objApp.Documents.Open(strTemplates, , False)
strFileName = contact_NO & ".doc"
'文件名必须包括“.doc”的文件扩展名，如没有则自动加上
If Not strFileName Like "*.doc" Then strFileName = strFileName & ".doc"
'如果文件已存在，则删除已有文件
If Dir(strFileName) <> "" Then Kill strFileName
'打开模板文件
'开始替换模板预置变量文本
With objApp.Application.Selection
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
With .Find
.Text = "{$合同编号}"
.Replacement.Text = contact_NO
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$甲方}"
.Replacement.Text = side_A
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$乙方}"
.Replacement.Text = side_B
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$金额}"
.Replacement.Text = side_C
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$开始}"
.Replacement.Text = side_D
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$结束}"
.Replacement.Text = side_E
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$位置}"
.Replacement.Text = side_F
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$备注}"
.Replacement.Text = side_G
End With
.Find.Execute Replace:=wdReplaceAll
End With
'将写入数据的模板另存为文档文件
objDoc.SaveAs Path & "\" & strFileName
objDoc.Saved = True
objDoc.Close
Next k
MsgBox "合同文本生成完毕！", vbYes + vbExclamation
Exit_cmdExportToWord_Click:
Set objApp = Nothing
Set objDoc = Nothing
Set objTable = Nothing
Exit Sub
Err_cmdExportToWord_Click:
MsgBox Err.Description, vbCritical, "出错"
Resume Exit_cmdExportToWord_Click
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-3-8 14:08
楼主
为啥啊
