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)
    
    '材料名coverName=C列p行单元格的值
    '获取材料文件夹并赋值给coverFLD
    coverName = excelWorksheet.Cells(p, "C").value
    Set coverFLD = fso.GetFolder(coverPath)
    
    '获取当前活动的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)
        
        '运行文本框插入子程序
        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

' 1. 错误处理 ' - 在每个子程序开头添加 On Error Resume Next 忽略一些错误，或 On Error GoTo 错误处理标签 进行更细致的错误处理 ' - 例如： ' vba ' Sub InsertProductPics(ByVal productFLD As Object, ByVal productName As String) ' On Error Resume Next ' 或 On Error GoTo ErrHandler ' ' ... 子程序代码 ... ' ' 错误处理标签 ' ErrHandler: ' MsgBox Err.Description ' Resume Next ' 继续执行下一行代码 ' End Sub '

' 2. 对象释放 ' - 在每个子程序结束时，使用 Set 对象名 = Nothing 释放对象，避免内存泄漏 ' - 例如： ' vba ' Sub InsertProductPics(ByVal productFLD As Object, ByVal productName As String) ' ' ... 子程序代码 ... ' Set productFLD = Nothing ' Set productFIL = Nothing ' Set productSUBFLD = Nothing ' ' ... 其他对象释放 ... ' End Sub '

' 3. 使用 DoEvents ' - 在每个子程序的中间部分添加 DoEvents 语句，允许程序在运行过程中响应其他操作和事件，提高程序的稳定性 ' - 例如： ' vba ' Sub InsertProductPics(ByVal productFLD As Object, ByVal productName As String) ' ' ... 子程序代码 ... ' DoEvents ' 在处理大量数据或操作时添加 DoEvents ' ' ... 子程序代码 ... ' End Sub '

' 4. 文件操作优化 ' - 使用 FileSystemObject 的 GetFile 和 GetFolder 方法提高文件操作的效率和稳定性，避免直接使用 Dir 函数 ' - 例如： ' vba ' ' 原始代码 ' Dim fileName As String ' fileName = Dir(productPath & "*.jpg") ' ' 优化代码 ' Dim productFile As Object ' Set productFile = fso.GetFile(productPath & "*.jpg") '

' 5. 变量类型声明 ' - 在每个子程序开头添加 Dim 变量名 As 变量类型 语句，明确变量的类型，避免类型不匹配导致的错误 ' - 例如： ' vba ' Sub InsertProductPics(ByVal productFLD As Object, ByVal productName As String) ' Dim productFile As Object ' 明确变量类型 ' ' ... 子程序代码 ... ' End Sub '

' 6. 变量值检查 ' - 在每个子程序中，对重要变量进行值检查，确保变量不为空或值不正确 ' - 例如： ' vba ' Sub InsertProductPics(ByVal productFLD As Object, ByVal productName As String) ' If productName = "" Then ' MsgBox "产品名称不能为空！" ' Exit Sub ' End If ' ' ... 子程序代码 ... ' End Sub '

' 其他建议 ' - 使用更具描述性的变量名，提高代码可读性 ' - 避免使用全局变量，尽量使用局部变量，减少代码耦合 ' - 使用代码规范，例如使用缩进和空白来提高代码可读性 ' - 在代码中添加注释，解释代码逻辑 ' - 定期测试代码，确保代码功能正常

' 通过实施以上优化建议，可以显著提高 VBA 代码的运行稳定性和效率，避免出现运行时错误，并使代码更加易于维护和扩展。