为什么我的代码给出的结果是运行时错误 5？

Question

我编写了以下代码来将图片从文件夹复制并粘贴到现有演示文稿中。然而，每次运行它时，我都会收到错误运行时间 5，但我无法解决。我尝试使用不同的 msgbox 控件来识别问题，但无法识别正确的问题。

Sub CopiaFotoInPowerPointEsistenteSemplificato()
    Dim pptApp As Object
    Dim pptPresentation As Object
    Dim pptSlide As Object
    Dim slideIndex As Integer
    Dim imgFolderPath As String
    Dim imgName As String
    Dim imgPath As String
    Dim imgCounter As Integer
    Dim imgPosArray(1 To 4, 1 To 2) As Single
    Dim imgWidth As Single
    Dim imgHeight As Single
    Dim pptFilePath As String

    ' Specifica il percorso della cartella contenente le immagini
    imgFolderPath = "C:\Users\Tuonomeutente\Desktop\Immagini\" ' Modifica questo percorso

    ' Verifica se la cartella esiste
    If Dir(imgFolderPath, vbDirectory) = "" Then
        MsgBox "La cartella specificata non esiste!"
        Exit Sub
    End If

    ' Specifica il percorso della presentazione PowerPoint esistente
    pptFilePath = "C:\Users\Tuonomeutente\Desktop\Presentazione.pptx" ' Modifica questo percorso

    ' Verifica se il file di PowerPoint esiste
    If Dir(pptFilePath) = "" Then
        MsgBox "Il file della presentazione PowerPoint non esiste!"
        Exit Sub
    End If

    ' Inizializzazione di PowerPoint
    On Error Resume Next
    Set pptApp = GetObject(, "PowerPoint.Application")
    If pptApp Is Nothing Then
        Set pptApp = CreateObject("PowerPoint.Application")
    End If
    On Error GoTo 0

    pptApp.Visible = True
    
    ' Apri la presentazione esistente
    Set pptPresentation = pptApp.Presentations.Open(pptFilePath)

    ' Verifica se la presentazione è stata aperta correttamente
    If pptPresentation Is Nothing Then
        MsgBox "Impossibile aprire la presentazione PowerPoint!"
        Exit Sub
    End If

    ' Definisci le posizioni delle immagini (4 per slide)
    imgPosArray(1, 1) = 50    ' Left della prima immagine
    imgPosArray(1, 2) = 50    ' Top della prima immagine
    imgPosArray(2, 1) = 400   ' Left della seconda immagine
    imgPosArray(2, 2) = 50    ' Top della seconda immagine
    imgPosArray(3, 1) = 50    ' Left della terza immagine
    imgPosArray(3, 2) = 300   ' Top della terza immagine
    imgPosArray(4, 1) = 400   ' Left della quarta immagine
    imgPosArray(4, 2) = 300   ' Top della quarta immagine

    imgWidth = 300 ' Larghezza delle immagini
    imgHeight = 200 ' Altezza delle immagini
    imgCounter = 0
    slideIndex = pptPresentation.Slides.Count + 1 ' Continua dopo l'ultima slide

    ' Inizia a scorrere le immagini nella cartella
    imgName = Dir(imgFolderPath & "*.jpg") ' Cambia l'estensione se necessario

    ' Aggiungi un controllo se non ci sono immagini
    If imgName = "" Then
        MsgBox "Non sono state trovate immagini nella cartella!"
        Exit Sub
    End If

    ' Inizia il ciclo per inserire le immagini
    Do While imgName <> ""
        imgCounter = imgCounter + 1
        
        ' Se imgCounter Mod 4 = 1, crea una nuova diapositiva
        If imgCounter Mod 4 = 1 Then
            Set pptSlide = pptPresentation.Slides.Add(slideIndex, ppLayoutBlank)
            slideIndex = slideIndex + 1
        End If

        imgPath = imgFolderPath & imgName

        ' Verifica se il file immagine esiste
        If Dir(imgPath) <> "" Then
            ' Verifica il file immagine
            MsgBox "Tentativo di inserimento immagine: " & imgPath
            
            ' Calcola la posizione dell'immagine corrente
            Dim imgRow As Integer
            imgRow = ((imgCounter - 1) Mod 4) + 1

            ' Aggiungi l'immagine alla slide
            On Error GoTo GestioneErrore
            pptSlide.Shapes.AddPicture imgPath, msoFalse, msoTrue, imgPosArray(imgRow, 1), imgPosArray(imgRow, 2), imgWidth, imgHeight
            MsgBox "Immagine inserita correttamente: " & imgPath
        Else
            MsgBox "Immagine non trovata: " & imgPath
        End If

        ' Carica la prossima immagine
        imgName = Dir
    Loop

    MsgBox "Le immagini sono state aggiunte alla presentazione PowerPoint esistente!"
    Exit Sub

GestioneErrore:
    MsgBox "Errore durante l'inserimento dell'immagine: " & Err.Description
    Err.Clear
    Exit Sub

End Sub

我想快速解决错误运行时间 5

Answer 1

我猜问题出在

If Dir(imgPath) <> "" Then

。它破坏了 Dir 函数的操作。

由于 Dir 返回了特定的文件名，因此您不需要另外检查文件是否存在。