为提高运行稳定性,建议在代码中添加错误处理机制,对可能出现的错误进行捕获和处理。例如,在选择文件夹和文件时,应该对用户可能取消选择的情况进行处理,避免程序崩溃。在插入图片和文本框时,应该对可能出现的类型不匹配或空对象等情况进行处理,避免程序出错。

完整代码如下:

''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批量插图()

On Error GoTo ErrorHandler '添加错误处理

'创建文件系统对象
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) 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
    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, totalStep
一名vba程序员请针对以下代码请给出提高运行稳定性方面的建议并输出完整代码。modulename=模块1强制申明所有变量option explicit声明全局变量dim pptapp as powerpointapplicationdim pptpres as powerpointpresentationdim pptslide as powerpointslidedim pptshape

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

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