以下是提高运行稳定性方面的建议:

  1. 在代码中添加错误处理机制,以便在出现错误时能够及时捕捉并进行处理。
  2. 在进行文件操作时,要先检查文件是否存在,避免出现文件不存在的情况。
  3. 在进行循环操作时,要先检查循环变量的取值范围,避免出现超出范围的情况。
  4. 在进行对象操作时,要先检查对象是否存在,避免出现对象不存在的情况。

以下是完整代码(包含以上建议):

''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
    If fso.FolderExists(productPath & productName) Then
        Set productFLD = fso.GetFolder(productPath & productName)
    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
    If fso.FolderExists(coverPath & coverName) Then
        Set coverFLD = fso.GetFolder(coverPath & coverName)
    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
        
        '运行材料插图子程序
        If Not coverFLD Is Nothing Then
            Call InsertCoverPics(coverFLD, coverName)
        End If
        
        '运行文本

原文地址: http://www.cveoy.top/t/topic/d25W 著作权归作者所有。请勿转载和采集!

免费AI点我,无需注册和登录