调试 MS Word 宏以导入返回重复图像的 JPG

如何解决调试 MS Word 宏以导入返回重复图像的 JPG

我正在查看我继承的以下宏，并试图弄清楚为什么它在从同一文件夹中提取独特的照片时会导入重复的图像。任何帮助将不胜感激，我对 VBA 没有很多经验。

宏的目的是拉取word文档所在文件夹中的所有图片文件，并嵌入到word文档中。现在它正在获取文件夹中的第一张图像并多次嵌入。我认为这是循环逻辑的问题，但我对 VBA 还很陌生并且无法修复它。

Option Explicit

Dim msPath As String
Dim msPictures() As String
Dim mlPicturesCnt As Long


Public Sub ImportJPGFiles()
On Error GoTo Err_ImportJPGFiles

Dim lngCount As Long
Dim lngPicture As Long
Dim strMsg As String

Dim sngBEGTime As Single
Dim sngENDTime As Single

    
'Assume JPG files are in same directory as
'as the Word document containing this macro.
msPath = Application.ActiveDocument.Path & "\"
lngCount = LoadPicturesArray

'Let user browse to correct folder if pictures aren't in the same
'folder as Word document
While lngCount < 0
    strMsg = "Unable to find any JPG files in the following" & vbCrLf & _
             "directory:" & vbCrLf & vbCrLf & _
             msPath & vbCrLf & vbCrLf & _
             "Press the 'OK' button if you want to browse to" & vbCrLf & _
             "the directory containing your JPG files.  Press" & vbCrLf & _
             "the 'Cancel' button to end this macro."
    
    If (MsgBox(strMsg,vbOKCancel + vbinformation,"Technical Difficulties")) = vbOK Then
        With Application
            .WindowState = wdWindowStateMinimize
            msPath = browseForDirectory
            .WindowState = wdWindowStateMaximize
        End With
        If LenB(msPath) <> 0 Then
            If Right$(msPath,1) <> "\" Then
                msPath = msPath & "\"
            End If
            lngCount = LoadPicturesArray
        Else
            Exit Sub
        End If
    Else
        Exit Sub
    End If
Wend

Application.ScreenUpdating = False

sngBEGTime = Timer
For lngPicture = 0 To lngCount
    Application.StatusBar = "Importing picture " & _
                            CStr(lngPicture + 1) & " of " & _
                            CStr(lngCount + 1) & " pictures..."
                            
                            
    With Selection
        .EndKey Unit:=wdStory
        .MoveUp Unit:=wdLine,Count:=21,Extend:=wdExtend
        .copy
        .EndKey Unit:=wdStory
        .InsertBreak Type:=wdPageBreak
        .Paste
        .MoveUp Unit:=wdLine,Count:=24
        .Inlineshapes.AddPicture FileName:=msPath & msPictures(lngPicture),_
                               LinkToFile:=False,_
                         SaveWithDocument:=True
    End With

    
Next lngPicture
sngENDTime = Timer

strMsg = "Import Statistics: " & vbCrLf & vbCrLf & _
         "Pictures Imported: " & CStr(lngCount + 1) & vbCrLf & _
         "Total Seconds:     " & Format((sngENDTime - sngBEGTime),"###0.0") & vbCrLf & _
         "Seconds/Picture:   " & Format((sngENDTime - sngBEGTime) / (lngCount + 1),"###0.00")

MsgBox strMsg,"Finished"

Exit_ImportJPGFiles:
With Application
    .StatusBar = "Ready"
    .ScreenUpdating = True
End With
Exit Sub

Err_ImportJPGFiles:
MsgBox Err.Number & " - " & Err.Description,"ImportJPGFiles"
Resume Exit_ImportJPGFiles
End Sub

Public Function LoadPicturesArray() As Long
On Error GoTo Err_LoadPicturesArray

Dim strName As String

strName = Dir(msPath)
mlPicturesCnt = 0
ReDim msPictures(0)
do while strName <> ""
    If strName <> "." And strName <> ".." _
    And strName <> "pagefile.sys" Then
        If UCase(Right$(strName,3)) = "JPG" Then
            msPictures(mlPicturesCnt) = strName
            mlPicturesCnt = mlPicturesCnt + 1
            ReDim Preserve msPictures(mlPicturesCnt)
            'Debug.Print strName
        End If
    End If
    strName = Dir
Loop
    
Call QSort(msPictures,mlPicturesCnt - 1)

'    Dim i As Integer
'    Debug.Print "----AFTER SORT----"
'    For i = 0 To mlPicturesCnt - 1
'        Debug.Print msPictures(i)
'    Next i

LoadPicturesArray = mlPicturesCnt - 1


Exit_LoadPicturesArray:
Exit Function

Err_LoadPicturesArray:
MsgBox Err.Number & " - " & Err.Description,"LoadPicturesArray"
Resume Exit_LoadPicturesArray
End Function

Public Sub QSort(ListArray() As String,lngBEGOfArray As Long,lngENDOfArray As Long)
Dim i As Long
Dim j As Long
Dim strPivot As String
Dim strTEMP As String

i = lngBEGOfArray
j = lngENDOfArray
strPivot = ListArray((lngBEGOfArray + lngENDOfArray) / 2)

While (i <= j)
    While (ListArray(i) < strPivot And i < lngENDOfArray)
        i = i + 1
    Wend
    
    While (strPivot < ListArray(j) And j > lngBEGOfArray)
        j = j - 1
    Wend

    If (i <= j) Then
        strTEMP = ListArray(i)
        ListArray(i) = ListArray(j)
        ListArray(j) = strTEMP
                        
        i = i + 1
        j = j - 1
    End If
Wend

If (lngBEGOfArray < j) Then QSort ListArray(),lngBEGOfArray,j
If (i < lngENDOfArray) Then QSort ListArray(),i,lngENDOfArray

End Sub