Excel中使用VBA实现word邮件合并功能

Excel中使用VBA实现word邮件合并功能

代码为窗体程序样式如下：

代码：

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
' 声明 ShellExecute 函数，用于执行外部程序

Private Sub CommandButtonMerge_Click()
Dim exePath As String

' 设置要启动的外部exe程序路径
exePath = ThisWorkbook.Path & "\Tool\A30Merge.exe"

' 使用ShellExecute函数执行外部exe程序
ShellExecute 0, "open", exePath, vbNullString, vbNullString, vbNormalFocus

End Sub
Private Sub CommandButtonGenerateDoc_Click()
'生成Word文档按钮的点击事件
Dim selectedSheet As String
Dim templatePath As String
Dim ExcelPath As String
Dim StartRow As Integer
Dim EndRow As Integer
Dim i As Integer
Dim newDoc As Object
Dim fileName As String
Dim folderPath As String

'校验是否选择Word模板文件
If TextBoxWordTemplatePath.Value = "" Then
MsgBox "请选择Word模板文件", vbExclamation, "Error"
Exit Sub
End If

' 获取用户输入的信息
' 获取word模板路径
templatePath = TextBoxWordTemplatePath.Value
' 获取当前打开的excel文档
ExcelPath = ActiveWorkbook.FullName
'获取选择的Sheet页
selectedSheet = ComboBoxSheets.Value

'填充数据行数选择
'StartRow为空，默认从第二行开始
StartRow = IIf(TextBoxStartRow.Value = "" Or TextBoxStartRow.Value = 1, 2, TextBoxStartRow.Value)
'EndRow为空，默认选择当前Sheet中所有非空行数据
EndRow = IIf(TextBoxEndRow.Value = "", Cells(Rows.count, 1).End(xlUp).Row, TextBoxEndRow.Value)

autoFilePath = ThisWorkbook.Path & "\AutoFile\" & selectedSheet & "\"
' 判断文件夹路径是否存在，不存在则创建
' 先判断父文件夹是否存在，不存在则创建
If Dir(ThisWorkbook.Path & "\AutoFile\", vbDirectory) = "" Then
MkDir ThisWorkbook.Path & "\AutoFile\"
End If

' 再判断文件夹路径是否存在，不存在则创建
If Dir(autoFilePath, vbDirectory) = "" Then
MkDir autoFilePath
End If

For i = StartRow To EndRow
Dim wordApp As Object
Dim wordDoc As Object

' 创建一个Word应用程序
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = False ' 设为True可见

' 打开模板文件
If Right(templatePath, 4) = ".doc" Or Right(templatePath, 5) = ".docx" Then
Set wordDoc = wordApp.Documents.Open(templatePath)

' 填充数据到文档
With wordDoc.Content
'建设项目会涉及换行，单独处理
.Find.Execute FindText:="<建设项目>", ReplaceWith:=Replace(Cells(i, 1).Value, Chr(10), vbNewLine), Replace:=2
.Find.Execute FindText:="<承包单位>", ReplaceWith:=Cells(i, 2).Value, Replace:=2
.Find.Execute FindText:="<监理单位>", ReplaceWith:=Cells(i, 3).Value, Replace:=2
.Find.Execute FindText:="<工程名称>", ReplaceWith:=Cells(i, 4).Value, Replace:=2
.Find.Execute FindText:="<工程地点及桩号>", ReplaceWith:=Cells(i, 5).Value, Replace:=2
.Find.Execute FindText:="<气温>", ReplaceWith:=Cells(i, 6).Value, Replace:=2
.Find.Execute FindText:="<天气情况>", ReplaceWith:=Cells(i, 7).Value, Replace:=2
.Find.Execute FindText:="<开工日期>", ReplaceWith:=Cells(i, 8).Value, Replace:=2
.Find.Execute FindText:="<施工日期>", ReplaceWith:=Cells(i, 9).Value, Replace:=2
'施工内容会涉及换行，单独处理
.Find.Execute FindText:="<施工内容part1>", ReplaceWith:=Replace(Cells(i, 10).Value, Chr(10), vbNewLine), Replace:=2
.Find.Execute FindText:="<施工内容part2>", ReplaceWith:=Replace(Cells(i, 12).Value, Chr(10), vbNewLine), Replace:=2
.Find.Execute FindText:="<施工内容part3>", ReplaceWith:=Replace(Cells(i, 14).Value, Chr(10), vbNewLine), Replace:=2
.Find.Execute FindText:="<人员设备>", ReplaceWith:=Replace(Cells(i, 16).Value, Chr(10), vbNewLine), Replace:=2
'复制Excel单元格内容到Word文档
Set rngh = Cells(i, 1)
rngh.Copy
Set rnga = Cells(i, 10)
rnga.Copy
Set rngb = Cells(i, 12)
rngb.Copy
Set rngc = Cells(i, 14)
rngc.Copy
Set rngd = Cells(i, 16)
rngd.Copy
wordApp.Selection.EndKey 6
'wordApp.Selection.Paste
End With

' 保存填充后的文档到相同路径下
If i < 10 Then
fileName = autoFilePath & selectedSheet & "_0" & i & ".docx"
Else
fileName = autoFilePath & selectedSheet & "_" & i & ".docx"
End If
wordDoc.SaveAs fileName

Else
MsgBox "请选择正确的Word模板文件", vbInformation, "Task Completed"
End If

' 关闭Word应用程序
wordDoc.Close
wordApp.Quit
'释放程序
Set wordDoc = Nothing
Set wordApp = Nothing
Next i

'提示保存路径
MsgBox "数据扫描完成，请进行文件转换", vbInformation, "Task Completed"

End Sub
' 用户单击“选择文件”按钮执行文件选择操作
Private Sub CommandButtonBrowseTemplate_Click()
Dim FileDialog As FileDialog
Set FileDialog = Application.FileDialog(msoFileDialogFilePicker)
With FileDialog
.Title = "请选择Word模板文件"
.Filters.Clear
.Filters.Add "Word文件", "*.doc; *.docx"
.AllowMultiSelect = False
If .Show = -1 Then
TextBoxWordTemplatePath.Value = .SelectedItems(1)
End If
End With
End Sub
' 窗体初始化时加载Excel中的sheet名称到下拉列表框中
Private Sub UserForm_Initialize()
'窗体初始化事件
Dim ws As Worksheet
'加载当前Excel文件的Sheet列表到下拉框中
For Each ws In ThisWorkbook.Sheets
ComboBoxSheets.AddItem ws.Name
Next ws
'默认选择第一个Sheet
ComboBoxSheets.Value = ThisWorkbook.Sheets(1).Name
End Sub

 更多实用教程资源：http://sj.ysok.net/jydoraemon 访问码：JYAM