word vba 对 带编号格式的PO单 段落下添加对应的图片

'Attribute VB_Name = "APO_PathStaging"
Option Explicit

' Configuration Constants
Private Const BASE_FOLDER As String = "\\10.0.0.10\部门共享\PO\"
Private Const START_PARA As Long = 582
Private Const PATH_TAG As String = "[IMG] "
Private Const MAX_IMAGE_WIDTH As Long = 350
Private Const MAX_IMAGE_HEIGHT As Long = 250
Private Const LOG_FILE As String = "C:\APO_PathStaging.log"

' Static Regex for APO detection
Private rxAPO As Object

' Initialize Regex object for APO pattern
Private Sub InitializeRegex()
    If rxAPO Is Nothing Then
        Set rxAPO = CreateObject("VBScript.RegExp")
        rxAPO.IgnoreCase = True
        rxAPO.Global = False
        rxAPO.Pattern = "APO\d{15}"
    End If
End Sub

' ========== Phase 1: Insert Placeholder Lines ==========
Public Sub InsertAllPathsFrom582_BottomUp()
    Dim base As String: base = EnsureBase(BASE_FOLDER)
    If Len(base) = 0 Then Exit Sub
    
    Dim fileCache As Object: Set fileCache = CacheFolderFiles(base)
    Dim doc As Document: Set doc = ActiveDocument
    If doc.Paragraphs.Count < START_PARA Then
        ShowMessage "Document has fewer than " & START_PARA & " paragraphs.", True
        Exit Sub
    End If
    
    If InStr(doc.Paragraphs(doc.Paragraphs.Count).Range.text, "APO") > 0 Then
        doc.Paragraphs(doc.Paragraphs.Count).Range.InsertParagraphAfter
    End If
    
    Dim pos As Collection: Set pos = CollectAPOs(doc, START_PARA)
    Dim i As Long
    For i = pos.Count To 1 Step -1
        Dim pi As Long: pi = CLng(pos(i)("ParaIndex"))
        Dim apo As String: apo = CStr(pos(i)("APO"))
        If pi <= doc.Paragraphs.Count Then
            Dim para As Paragraph: Set para = doc.Paragraphs(pi)
            If InStr(para.Range.text, apo) > 0 Then
                Insert_APO_Path_Lines base, apo, para, fileCache
            End If
        End If
    Next i
    
    ShowMessage "Phase 1 completed: All image placeholder lines inserted (bottom-up)."
End Sub

Public Sub InsertLastAPOPathsOnly()
    Dim base As String: base = EnsureBase(BASE_FOLDER)
    If Len(base) = 0 Then Exit Sub
    
    Dim fileCache As Object: Set fileCache = CacheFolderFiles(base)
    Dim doc As Document: Set doc = ActiveDocument
    Dim i As Long
    For i = doc.Paragraphs.Count To START_PARA Step -1
        Dim apo As String: apo = ExtractAPO(doc.Paragraphs(i).Range.text)
        If Len(apo) = 18 Then
            Insert_APO_Path_Lines base, apo, doc.Paragraphs(i), fileCache
            Exit Sub
        End If
    Next i
    ShowMessage "No APO found (from paragraph " & START_PARA & ").", True
End Sub

Private Sub Insert_APO_Path_Lines(ByVal base As String, ByVal apo As String, ByVal para As Paragraph, ByVal fileCache As Object)
    Dim monthName As String: monthName = DetectMonth(base, apo, fileCache)
    Dim imgs As Collection: Set imgs = FindAPOImagesInMonth(base, monthName, apo, fileCache)
    If imgs.Count = 0 Then
        Set imgs = FindAPOImagesAcrossMonths(base, apo, fileCache)
        If imgs.Count > 0 Then
            On Error Resume Next
            Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
            monthName = fso.GetFile(imgs(1)).ParentFolder.name
            On Error GoTo 0
        End If
    End If
    
    Dim rng As Range: Set rng = para.Range.Duplicate
    rng.Collapse wdCollapseEnd
    Dim textToInsert As String
    If imgs.Count = 0 Then
        textToInsert = PATH_TAG & "<NO-IMAGE> " & apo & "  Month=" & IIf(monthName = "", "(Unknown)", monthName) & vbCr
    Else
        Dim i As Long
        For i = 1 To imgs.Count
            textToInsert = textToInsert & PATH_TAG & imgs(i) & vbCr
        Next i
    End If
    
    If Len(textToInsert) > 0 Then
        rng.text = textToInsert
        Dim p As Paragraph
        For Each p In rng.Paragraphs
            NormalizeIMGParagraph p
        Next p
    End If
    
    LogMessage "Inserted " & imgs.Count & " placeholders for APO: " & apo & " in month: " & monthName
End Sub

' ========== Phase 2: Convert Placeholders to Images ==========
Public Sub ConvertPathsToInlineImages()
    Dim doc As Document: Set doc = ActiveDocument
    Dim i As Long
    For i = doc.Paragraphs.Count To START_PARA Step -1
        Dim para As Paragraph: Set para = doc.Paragraphs(i)
        Dim path As String: path = ExtractPathFromParagraph(para.Range.text)
        If Len(path) > 0 Then
            ReplaceParagraphWithInlineImage para, path
        End If
    Next i
    ShowMessage "Phase 2 completed: All placeholder lines converted to inline images."
End Sub

Public Sub ConvertPathsToIncludePictureFields()
    Dim doc As Document: Set doc = ActiveDocument
    Dim i As Long
    For i = doc.Paragraphs.Count To START_PARA Step -1
        Dim para As Paragraph: Set para = doc.Paragraphs(i)
        Dim path As String: path = ExtractPathFromParagraph(para.Range.text)
        If Len(path) > 0 Then
            ReplaceParagraphWithIncludePicture para, path
        End If
    Next i
    ShowMessage "Phase 2 completed: All placeholder lines converted to IncludePicture fields."
End Sub

Private Function ExtractPathFromParagraph(ByVal raw As String) As String
    Dim txt As String: txt = Trim$(Replace$(raw, vbCr, ""))
    If Left$(txt, Len(PATH_TAG)) = PATH_TAG Then
        ExtractPathFromParagraph = Mid$(txt, Len(PATH_TAG) + 1)
    End If
End Function

Private Sub ReplaceParagraphWithInlineImage(ByVal para As Paragraph, ByVal path As String)
    If Len(path) = 0 Or Not FileExists(path) Or Not IsImageName(path) Then Exit Sub
    
    Dim rng As Range: Set rng = para.Range
    rng.text = ""
    rng.Collapse wdCollapseStart
    
    On Error Resume Next
    Dim pic As InlineShape
    Set pic = rng.InlineShapes.AddPicture(fileName:=path, LinkToFile:=False, SaveWithDocument:=True)
    If Err.Number = 0 Then
        With pic
            .LockAspectRatio = msoTrue
            If .Width > MAX_IMAGE_WIDTH Then .Width = MAX_IMAGE_WIDTH
            If .Height > MAX_IMAGE_HEIGHT Then .Height = MAX_IMAGE_HEIGHT
        End With
        NormalizeIMGParagraph rng.Paragraphs(1)
        LogMessage "Inserted inline image: " & path
    Else
        LogMessage "Failed to insert inline image: " & path & " (" & Err.Description & ")"
    End If
    On Error GoTo 0
End Sub

Private Sub ReplaceParagraphWithIncludePicture(ByVal para As Paragraph, ByVal path As String)
    If Len(path) = 0 Or Not FileExists(path) Or Not IsImageName(path) Then Exit Sub
    
    Dim rng As Range: Set rng = para.Range
    rng.text = ""
    rng.Collapse wdCollapseStart
    
    path = Replace(path, "\", "\\")
     
    On Error Resume Next
    Dim fld As Field
    Set fld = rng.fields.Add(Range:=rng, Type:=wdFieldIncludePicture, _
                            text:=Chr$(34) & path & Chr$(34), PreserveFormatting:=True)
    fld.Update
    If Err.Number = 0 And fld.result.InlineShapes.Count > 0 Then
        With fld.result.InlineShapes(1)
            .LockAspectRatio = msoTrue
            If .Width > MAX_IMAGE_WIDTH Then .Width = MAX_IMAGE_WIDTH
            If .Height > MAX_IMAGE_HEIGHT Then .Height = MAX_IMAGE_HEIGHT
        End With
        NormalizeIMGParagraph fld.result.Paragraphs(1)
        LogMessage "Inserted IncludePicture field: " & path
    Else
        LogMessage "Failed to insert IncludePicture field: " & path & " (" & Err.Description & ")"
    End If
    On Error GoTo 0
End Sub

' ========== APO and Image Discovery ==========
Private Function CollectAPOs(ByVal doc As Document, ByVal startPara As Long) As Collection
    InitializeRegex
    Dim col As New Collection
    Dim seen As Object: Set seen = CreateObject("Scripting.Dictionary")
    Dim i As Long
    For i = startPara To doc.Paragraphs.Count
        Dim apo As String: apo = ExtractAPO(doc.Paragraphs(i).Range.text)
        If Len(apo) = 18 Then
            If Not seen.Exists(apo) Then
                Dim item As Object: Set item = CreateObject("Scripting.Dictionary")
                item("ParaIndex") = i
                item("APO") = apo
                col.Add item
                seen.Add apo, True
            End If
        End If
    Next i
    Set CollectAPOs = col
End Function

Private Function DetectMonth(ByVal base As String, ByVal apo As String, ByVal fileCache As Object) As String
    Dim monthArr As Variant: monthArr = GetMonths(base)
    Dim rxPDF As Object: Set rxPDF = CreateObject("VBScript.RegExp")
    rxPDF.IgnoreCase = True: rxPDF.Global = False
    rxPDF.Pattern = "^[0-9]+-" & apo & "[ ]*\.pdf$"
    
    Dim rxJPG As Object: Set rxJPG = CreateObject("VBScript.RegExp")
    rxJPG.IgnoreCase = True: rxJPG.Global = False
    rxJPG.Pattern = "^[0-9]+-" & apo & "_[0-9]{4}\.(jpg|jpeg|png|bmp|gif)$"
    
    Dim m As Long
    For m = LBound(monthArr) To UBound(monthArr)
        Dim month As String: month = monthArr(m)
        If fileCache.Exists(month) Then
            Dim fileName As Variant
            For Each fileName In fileCache(month).Keys
                If rxPDF.Test(fileName) Or rxJPG.Test(fileName) Then
                    DetectMonth = month
                    Exit Function
                End If
            Next fileName
        End If
    Next m
End Function

Private Function FindAPOImagesInMonth(ByVal base As String, ByVal monthName As String, ByVal apo As String, ByVal fileCache As Object) As Collection
    Dim col As New Collection
    If Len(monthName) = 0 Or Not fileCache.Exists(monthName) Then
        Set FindAPOImagesInMonth = col
        Exit Function
    End If
    
    Dim rx As Object: Set rx = CreateObject("VBScript.RegExp")
    rx.IgnoreCase = True: rx.Global = False
    rx.Pattern = "^([0-9]+)-" & apo & "_([0-9]{4})\.(jpg|jpeg|png|bmp|gif)$"
    
    Dim paths() As String, pages() As Long, cnt As Long
    ReDim paths(0 To 0): ReDim pages(0 To 0)
    
    Dim fileName As Variant
    For Each fileName In fileCache(monthName).Keys
        If IsImageName(fileName) Then
            Dim m As Object: Set m = rx.Execute(fileName)
            If m.Count > 0 Then
                ReDim Preserve paths(cnt)
                ReDim Preserve pages(cnt)
                paths(cnt) = fileCache(monthName)(fileName)
                pages(cnt) = CLng(m(0).SubMatches(1))
                cnt = cnt + 1
            End If
        End If
    Next fileName
    
    ' Sort by page number
    Dim i As Long, j As Long, tempPage As Long, tempPath As String
    For i = 0 To cnt - 2
        For j = i + 1 To cnt - 1
            If pages(i) > pages(j) Then
                tempPage = pages(i): pages(i) = pages(j): pages(j) = tempPage
                tempPath = paths(i): paths(i) = paths(j): paths(j) = tempPath
            End If
        Next j
    Next i
    
    For i = 0 To cnt - 1
        col.Add paths(i)
    Next i
    Set FindAPOImagesInMonth = col
End Function

Private Function FindAPOImagesAcrossMonths(ByVal base As String, ByVal apo As String, ByVal fileCache As Object) As Collection
    Dim col As New Collection
    Dim monthArr As Variant: monthArr = GetMonths(base)
    Dim i As Long
    For i = LBound(monthArr) To UBound(monthArr)
        Dim part As Collection: Set part = FindAPOImagesInMonth(base, monthArr(i), apo, fileCache)
        Dim k As Long
        For k = 1 To part.Count
            col.Add part(k)
        Next k
    Next i
    Set FindAPOImagesAcrossMonths = col
End Function

' ========== Debugging and Utilities ==========
Public Sub DebugCheckSingleAPO()
    Dim base As String: base = EnsureBase(BASE_FOLDER)
    If Len(base) = 0 Then Exit Sub
    Dim apo As String: apo = InputBox("Enter APO to check (e.g., APO123456250900036):", "Debug APO", "APO123456250900036")
    If Len(apo) = 0 Then Exit Sub
    
    Dim fileCache As Object: Set fileCache = CacheFolderFiles(base)
    Dim output As String
    output = "=== Debug APO === " & vbCrLf & _
             "Base: " & base & vbCrLf & _
             "APO: " & apo & vbCrLf
    
    Dim mPDF As String: mPDF = DetectMonth(base, apo, fileCache)
    output = output & "Detected Month: " & mPDF & vbCrLf
    
    Dim imgs As Collection: Set imgs = FindAPOImagesInMonth(base, mPDF, apo, fileCache)
    output = output & "Images in Month (" & mPDF & "): " & imgs.Count & vbCrLf
    If imgs.Count = 0 Then
        Set imgs = FindAPOImagesAcrossMonths(base, apo, fileCache)
        output = output & "Images Across All Months: " & imgs.Count & vbCrLf
    End If
    
    Dim i As Long
    For i = 1 To imgs.Count
        output = output & "  - " & imgs(i) & vbCrLf
    Next i
    
    Debug.Print output
    LogMessage output
    ShowMessage "Check completed. See Immediate Window (Ctrl+G) for output."
End Sub

Private Sub NormalizeIMGParagraph(ByVal para As Paragraph)
    On Error Resume Next
    With para
        .Range.Style = wdStyleNormal
        .Range.ListFormat.RemoveNumbers
        .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
    End With
    If Err.Number <> 0 Then LogMessage "Failed to normalize paragraph: " & Err.Description
    On Error GoTo 0
End Sub

Public Sub NormalizeAllIMGParagraphs()
    Dim doc As Document: Set doc = ActiveDocument
    Dim i As Long
    For i = START_PARA To doc.Paragraphs.Count
        Dim txt As String: txt = Trim$(Replace$(doc.Paragraphs(i).Range.text, vbCr, ""))
        If Left$(txt, Len(PATH_TAG)) = PATH_TAG Then
            NormalizeIMGParagraph doc.Paragraphs(i)
        End If
    Next i
    ShowMessage "All [IMG] paragraphs normalized to Normal style and centered."
End Sub

Public Sub FixAdjacentEmptyNumberedParagraphs()
    Dim doc As Document: Set doc = ActiveDocument
    Dim i As Long
    For i = doc.Paragraphs.Count To START_PARA Step -1
        Dim para As Paragraph: Set para = doc.Paragraphs(i)
        Dim txt As String: txt = Trim$(Replace$(para.Range.text, vbCr, ""))
        If Left$(txt, Len(PATH_TAG)) = PATH_TAG Then
            If i > START_PARA Then
                Dim prevPara As Paragraph: Set prevPara = doc.Paragraphs(i - 1)
                Dim prevTxt As String: prevTxt = Trim$(Replace$(prevPara.Range.text, vbCr, ""))
                If Len(prevTxt) = 0 Then
                    prevPara.Range.Delete
                Else
                    On Error Resume Next
                    prevPara.Range.ListFormat.RemoveNumbers
                    If Err.Number <> 0 Then LogMessage "Failed to remove numbering: " & Err.Description
                    On Error GoTo 0
                End If
            End If
        End If
    Next i
    ShowMessage "Cleaned empty numbered paragraphs before [IMG] placeholders."
End Sub

' ========== Utility Functions ==========
Private Function ExtractAPO(ByVal text As String) As String
    InitializeRegex
    Dim m As Object: Set m = rxAPO.Execute(text)
    If m.Count > 0 Then ExtractAPO = m(0).Value
End Function

Private Function EnsureBase(ByVal suggest As String) As String
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim base As String: base = suggest
    If Not fso.FolderExists(base) Then
        base = InputBox("Enter the root directory containing monthly folders:", "Image Root Directory", suggest)
        If Len(base) = 0 Then Exit Function
        If Right$(base, 1) <> "\" And Right$(base, 1) <> "/" Then base = base & "\"
        If Not fso.FolderExists(base) Then
            ShowMessage "Directory does not exist: " & base, True
            Exit Function
        End If
    End If
    EnsureBase = base
End Function

Private Function JoinPath(ByVal base As String, ByVal leaf As String) As String
    If Right$(base, 1) = "\" Or Right$(base, 1) = "/" Then
        JoinPath = base & leaf
    Else
        JoinPath = base & "\" & leaf
    End If
End Function

Private Function FileExists(ByVal path As String) As Boolean
    On Error Resume Next
    FileExists = (Len(Dir$(path)) > 0)
    If Err.Number <> 0 Then
        LogMessage "Error checking file: " & path & " (" & Err.Description & ")"
        FileExists = False
    End If
    On Error GoTo 0
End Function

Private Function IsImageName(ByVal name As String) As Boolean
    Dim ext As String: ext = LCase$(Right$(name, 4))
    IsImageName = (ext = ".jpg" Or ext = ".png" Or Right$(name, 5) = ".jpeg" Or ext = ".bmp" Or ext = ".gif")
End Function

Private Function CacheFolderFiles(ByVal base As String) As Object
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim cache As Object: Set cache = CreateObject("Scripting.Dictionary")
    Dim monthArr As Variant: monthArr = GetMonths(base)
    Dim m As Long
    For m = LBound(monthArr) To UBound(monthArr)
        Dim p As String: p = JoinPath(base, monthArr(m))
        On Error Resume Next
        If fso.FolderExists(p) Then
            Dim fd As Object: Set fd = fso.GetFolder(p)
            If Err.Number = 0 Then
                Dim ff As Object
                cache.Add monthArr(m), CreateObject("Scripting.Dictionary")
                For Each ff In fd.Files
                    cache(monthArr(m)).Add ff.name, ff.path
                Next ff
            Else
                LogMessage "Failed to access folder: " & p & " (" & Err.Description & ")"
            End If
        End If
        On Error GoTo 0
    Next m
    Set CacheFolderFiles = cache
End Function

Private Function GetMonths(ByVal base As String) As Variant
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim months As String, folder As Object
    If fso.FolderExists(base) Then
        For Each folder In fso.GetFolder(base).SubFolders
            If InStr(folder.name, "月PO") > 0 Then
                months = months & IIf(months = "", "", "|") & folder.name
            End If
        Next folder
    End If
    If Len(months) = 0 Then months = "5月PO|6月PO|7月PO|8月PO|9月PO" ' Fallback to default
    GetMonths = Split(months, "|")
End Function

Private Sub ShowMessage(ByVal msg As String, Optional ByVal isError As Boolean = False)
    MsgBox msg, IIf(isError, vbExclamation, vbInformation)
    LogMessage msg
End Sub

Private Sub LogMessage(ByVal msg As String)
    On Error Resume Next
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim logDir As String: logDir = fso.GetParentFolderName(LOG_FILE)
    
    If Not fso.FolderExists(logDir) Then
        fso.CreateFolder logDir
        If Err.Number <> 0 Then
            Debug.Print "Failed to create log directory: " & logDir & " (" & Err.Description & ")"
            Debug.Print Now & ": " & msg
            Exit Sub
        End If
    End If
    
    Open LOG_FILE For Append As #1
    If Err.Number = 0 Then
        Print #1, Now & ": " & msg
        Close #1
    Else
        Debug.Print "Failed to log to file: " & LOG_FILE & " (" & Err.Description & ")"
        Debug.Print Now & ": " & msg
    End If
    On Error GoTo 0
End Sub

DebugCheckSingleAPO 根据 pdf 文件名 获取月份和对应的jpg文件路径，若无则回退检查。

InsertAllPathsFrom582_BottomUp 后需要在 PO 单之间添加换行，然后再进行转换成图片（否则格式可能会有问题），无论是用域代码还是根据图片路径直接转换图片。