VBA 代码优化建议：提高运行稳定性

本文针对一段 VBA 代码，从对象释放、错误处理、代码可读性和效率等方面给出优化建议，并提供具体示例，帮助程序员编写更稳定、高效的 VBA 代码。

代码示例

'ModuleName="模块1" '强制申明所有变量
Option Explicit
'声明全局变量
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape
Dim excelApp As Object
Dim excelWorkbook As Object
Dim excelWorksheet As Object
Dim productFLD As Object
Dim coverFLD As Object
Dim productFIL As Object
Dim coverFIL As Object
Dim productSUBFLD As Object
Dim coverSUBFLD As Object
Dim xlsPath As String
Dim productPath As String
Dim coverPath As String
Dim productName As String
Dim coverName As String
Dim fileExtension As String
Dim n As Integer
Dim C As Long
Dim p As Long
Dim rcount As Long

'==========PPT批量插图主程序==========
Sub PPT批量插图()
'创建文件系统对象
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
'设置文件扩展名
fileExtension = ".jpg"
'选择产品材料清单Excel文件
xlsPath = GetFilePath("请选择【导入】表单")
If xlsPath = "" Then Exit Sub
'选择产品图片文件夹
productPath = GetFolderPath("请选择【产品】文件夹")
If productPath = "" Then Exit Sub
'选择材料图片文件夹
coverPath = GetFolderPath("请选择【材料】文件夹")
If coverPath = "" Then Exit Sub
'创建Excel对象
Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = False
'打开Excel文件
Set excelWorkbook = excelApp.Workbooks.Open(xlsPath)
'获取工作表对象
Set excelWorksheet = excelWorkbook.Sheets("Sheet1")
'获取工作表最后一行行号并给【行号变量】赋值
rcount = excelWorksheet.Cells(excelWorksheet.Rows.Count, "B").End(xlUp).Row
'弹窗提示
If rcount < 2 Then
'关闭Excel文件和退出Excel应用程序
excelWorkbook.Close SaveChanges:=False
Set excelWorkbook = Nothing '释放对象
excelApp.Quit
Set excelApp = Nothing '释放对象
'弹窗提示
MsgBox "好像没有货号哟，请修改后重试"
Exit Sub
End If
'弹窗提示
If rcount > 51 Then
'关闭Excel文件和退出Excel应用程序
excelWorkbook.Close SaveChanges:=False
Set excelWorkbook = Nothing '释放对象
excelApp.Quit
Set excelApp = Nothing '释放对象
'弹窗提示
MsgBox "导入货号不可以超过50行啦，请修改后重试"
Exit Sub
End If
'弹窗提示
MsgBox "批量插图开始啦，这次共有 " & rcount - 1 & " 个货号"
'从第2行到最后一行
For p = 2 To rcount
'产品名productName=B列p行单元格的值
'获取产品文件夹并赋值给productFLD
productName = excelWorksheet.Cells(p, "B").value
'Set productFLD = fso.GetFolder(productPath)
If fso.FolderExists(productPath) Then
Set productFLD = fso.GetFolder(productPath)
Else
'关闭Excel文件和退出Excel应用程序
excelWorkbook.Close SaveChanges:=False
Set excelWorkbook = Nothing '释放对象
excelApp.Quit
Set excelApp = Nothing '释放对象
'弹窗提示
MsgBox "产品文件夹不存在，请检查后重试"
Exit Sub
End If
'材料名coverName=C列p行单元格的值
'获取材料文件夹并赋值给coverFLD
coverName = excelWorksheet.Cells(p, "C").value
'Set coverFLD = fso.GetFolder(coverPath)
If fso.FolderExists(coverPath) Then
Set coverFLD = fso.GetFolder(coverPath)
Else
'关闭Excel文件和退出Excel应用程序
excelWorkbook.Close SaveChanges:=False
Set excelWorkbook = Nothing '释放对象
excelApp.Quit
Set excelApp = Nothing '释放对象
'弹窗提示
MsgBox "材料文件夹不存在，请检查后重试"
Exit Sub
End If
'获取当前活动的PPT文件
Set pptPres = ActivePresentation
'运行产品插图子程序
InsertProductPics productFLD, productName
' 创建进度窗体
Dim prgForm As UserForm1
Set prgForm = New UserForm1
Dim totalSteps As Integer
Dim processedSteps As Integer
totalSteps = rcount - 1
processedSteps = p - 1
'显示窗体
prgForm.Show vbModeless
' 更新进度信息
Call prgForm.UpdateProgress(processedSteps, totalSteps)
' 关闭进度窗体
Unload prgForm
Next p
' 关闭进度窗体
Unload prgForm
'关闭Excel文件和退出Excel应用程序
excelWorkbook.Close SaveChanges:=False
Set excelWorkbook = Nothing '释放对象
excelApp.Quit
Set excelApp = Nothing '释放对象
'弹窗提示
MsgBox "任务完成啦"
End Sub
'==========产品插图子程序，检索文件夹和子文件夹并插入产品图片==========
Sub InsertProductPics(ByVal productFLD As Object, ByVal productName As String)
'命名子程序并定义其参数
'获取当前活动的PPT文件
Set pptPres = ActivePresentation
'遍历（each）产品文件夹（productFLD）里的所有文件（.files）并赋值给productFIL
For Each productFIL In productFLD.Files
'判断图片是否存在，并且文件名中包含指定字符串，并且不含中文逗号
If LCase(Right(productFIL.Name, Len(fileExtension))) = LCase(fileExtension) _
And InStr(productFIL.Path, productName) <> 0 _
And InStr(productFIL.Path, "，") = 0 Then
'复制第一张幻灯片
pptPres.Slides(1).Copy
'粘贴至最后一张之后
pptPres.Slides.Paste pptPres.Slides.Count + 1
'选择最后这页幻灯片作为编辑对象
Set pptSlide = pptPres.Slides(pptPres.Slides.Count)
'插入产品图片，设置坐标及长宽
With pptSlide.Shapes.AddPicture(FileName:=productFIL.Path, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=50, Top:=100, _
Width:=495, Height:=235)
End With
'材料名coverName=C列p行单元格的值
coverName = excelWorksheet.Cells(p, "C").value
'运行材料插图子程序
'Call InsertCoverPics(coverFLD, coverName)
If Not coverFLD Is Nothing Then
Call InsertCoverPics(coverFLD, coverName)
End If
'运行文本框插入子程序
Call InsertTxtBox
End If
Next productFIL
'递归地遍历文件夹中的所有子文件夹，搜索指定的产品名称并进行处理
For Each productSUBFLD In productFLD.SubFolders
Call InsertProductPics(productSUBFLD, productName)
Next productSUBFLD
End Sub
'==========材料插图子程序，检索文件夹和子文件夹并插入材料图片==========
Sub InsertCoverPics(ByVal coverFLD As Object, ByVal coverName As String)
'命名子程序并定义其参数
'获取当前活动的PPT文件
Set pptPres = ActivePresentation
'选择最后这页幻灯片作为编辑对象
Set pptSlide = pptPres.Slides(pptPres.Slides.Count)
'遍历（each）材料文件夹（coverFLD）里的所有文件（.files）并赋值给coverFIL
For Each coverFIL In coverFLD.Files
'判断图片是否存在，并且文件名中包含指定字符串，并且不含中文逗号
If LCase(Right(coverFIL.Name, Len(fileExtension))) = LCase(fileExtension) _
And InStr(coverFIL.Path, coverName) <> 0 _
And InStr(coverFIL.Path, "，") = 0 Then
'再次定义变量
Dim pptShape As PowerPoint.Shape
'插入材料图片，设置坐标及长宽
With pptSlide.Shapes.AddPicture(FileName:=coverFIL.Path, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=675, Top:=100, _
Width:=125, Height:=80)
End With
End If
Next coverFIL
'递归地遍历文件夹中的所有子文件夹，搜索指定的材料名称并进行处理
For Each coverSUBFLD In coverFLD.SubFolders
InsertCoverPics coverSUBFLD, coverName
Next coverSUBFLD
End Sub
'==========文本框插入子程序==========
Sub InsertTxtBox()
For C = 2 To 3
With pptPres.Slides(pptPres.Slides.Count)
With .Shapes.AddTextbox _
(msoTextOrientationHorizontal, 75 + (C - 2) * 600, 10 + (C - 2) * 170, 200 - (C - 2) * 75, 10)
'文本框坐标及长宽
.TextFrame.TextRange.Font.Name = "微软雅黑" '字体
.TextFrame.TextRange.Font.Size = 28 - (C - 2) * 14 '字号
.TextFrame.TextRange.Font.Color = RGB(0, 0, 0) '字体颜色
.TextFrame.TextRange.Font.Bold = True '加粗
.TextFrame.TextRange.Text = excelWorksheet.Cells(p, C).value '文本内容
End With
End With
Next C
End Sub
'==========封装选择文件夹的函数==========
Function GetFolderPath(ByVal dialogTitle As String) As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = dialogTitle
.AllowMultiSelect = False
If .Show = -1 Then
GetFolderPath = .SelectedItems(1) & "\"
Else
GetFolderPath = ""
End If
End With
End Function
'==========封装选择文件的函数==========
Function GetFilePath(ByVal dialogTitle As String) As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = dialogTitle
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel文件", "*.xls;*.xlsx"
If .Show = -1 Then
GetFilePath = .SelectedItems(1)
Else
GetFilePath = ""
End If
End With
End Function

优化建议

对象释放问题： 在代码中，多次创建了对象，但没有及时释放，可能会导致程序崩溃或者占用系统资源。建议在使用完对象后，使用 Set obj = Nothing 来释放对象。

示例：

Set fso = Nothing
Set excelWorksheet = Nothing
Set pptPres = Nothing
Set productFLD = Nothing
Set coverFLD = Nothing
Set productFIL = Nothing
Set coverFIL = Nothing
Set productSUBFLD = Nothing
Set coverSUBFLD = Nothing

错误处理机制： 在代码中，没有使用错误处理机制来处理可能发生的异常情况，如文件夹不存在、文件不存在等。建议使用 On Error 语句来捕获异常，并使用 MsgBox 或者日志记录等方式进行提示。

示例：
```
On Error GoTo HandleError
' ... 代码逻辑 ...
```

HandleError: MsgBox Err.Description Resume Next ' 忽略错误继续执行 ' 或者记录错误信息到日志文件 ```

代码可读性： 在代码中，使用了大量的缩写和简写，可能会降低代码的可读性。建议使用有意义的变量名和注释来提高代码的可读性。

示例：
```
' 将 productFLD 变量名改为 productFolder
' 并添加注释说明变量的用途
Dim productFolder As Object ' 产品文件夹对象
```
效率问题： 在代码中，使用了多层循环和递归调用，可能会导致程序运行效率低下。建议使用更高效的算法来提高程序运行效率。

示例：

可以使用 Collection 对象来存储文件信息，避免多次遍历文件夹，提高代码效率。
```
Dim fileCollection As Collection
Set fileCollection = New Collection

' ... 遍历文件夹，将文件信息添加到 fileCollection ...

' ... 使用 fileCollection 对象快速访问文件信息 ...
```

其他建议

使用 With 语句来简化代码，减少重复代码。
使用 Option Explicit 声明所有变量，避免潜在的错误。
使用 VBA Editor 中的 Format 命令来格式化代码，提高代码可读性。
充分利用 VBA 的内置函数和对象，简化代码逻辑，提高代码效率。

总结

通过以上优化建议，可以有效提高 VBA 代码的运行稳定性，减少代码错误，提高代码效率，并使代码更加易于阅读和维护。建议程序员在编写 VBA 代码时，要养成良好的编程习惯，并注意代码优化，才能编写出高质量的 VBA 代码。