'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 ThenSet rxAPO = CreateObject("VBScript.RegExp")rxAPO.IgnoreCase = TruerxAPO.Global = FalserxAPO.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 SubDim fileCache As Object: Set fileCache = CacheFolderFiles(base)Dim doc As Document: Set doc = ActiveDocumentIf doc.Paragraphs.Count < START_PARA ThenShowMessage "Document has fewer than " & START_PARA & " paragraphs.", TrueExit SubEnd IfIf InStr(doc.Paragraphs(doc.Paragraphs.Count).Range.text, "APO") > 0 Thendoc.Paragraphs(doc.Paragraphs.Count).Range.InsertParagraphAfterEnd IfDim pos As Collection: Set pos = CollectAPOs(doc, START_PARA)Dim i As LongFor i = pos.Count To 1 Step -1Dim pi As Long: pi = CLng(pos(i)("ParaIndex"))Dim apo As String: apo = CStr(pos(i)("APO"))If pi <= doc.Paragraphs.Count ThenDim para As Paragraph: Set para = doc.Paragraphs(pi)If InStr(para.Range.text, apo) > 0 ThenInsert_APO_Path_Lines base, apo, para, fileCacheEnd IfEnd IfNext iShowMessage "Phase 1 completed: All image placeholder lines inserted (bottom-up)."
End SubPublic Sub InsertLastAPOPathsOnly()Dim base As String: base = EnsureBase(BASE_FOLDER)If Len(base) = 0 Then Exit SubDim fileCache As Object: Set fileCache = CacheFolderFiles(base)Dim doc As Document: Set doc = ActiveDocumentDim i As LongFor i = doc.Paragraphs.Count To START_PARA Step -1Dim apo As String: apo = ExtractAPO(doc.Paragraphs(i).Range.text)If Len(apo) = 18 ThenInsert_APO_Path_Lines base, apo, doc.Paragraphs(i), fileCacheExit SubEnd IfNext iShowMessage "No APO found (from paragraph " & START_PARA & ").", True
End SubPrivate 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 ThenSet imgs = FindAPOImagesAcrossMonths(base, apo, fileCache)If imgs.Count > 0 ThenOn Error Resume NextDim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")monthName = fso.GetFile(imgs(1)).ParentFolder.nameOn Error GoTo 0End IfEnd IfDim rng As Range: Set rng = para.Range.Duplicaterng.Collapse wdCollapseEndDim textToInsert As StringIf imgs.Count = 0 ThentextToInsert = PATH_TAG & "<NO-IMAGE> " & apo & " Month=" & IIf(monthName = "", "(Unknown)", monthName) & vbCrElseDim i As LongFor i = 1 To imgs.CounttextToInsert = textToInsert & PATH_TAG & imgs(i) & vbCrNext iEnd IfIf Len(textToInsert) > 0 Thenrng.text = textToInsertDim p As ParagraphFor Each p In rng.ParagraphsNormalizeIMGParagraph pNext pEnd IfLogMessage "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 = ActiveDocumentDim i As LongFor i = doc.Paragraphs.Count To START_PARA Step -1Dim para As Paragraph: Set para = doc.Paragraphs(i)Dim path As String: path = ExtractPathFromParagraph(para.Range.text)If Len(path) > 0 ThenReplaceParagraphWithInlineImage para, pathEnd IfNext iShowMessage "Phase 2 completed: All placeholder lines converted to inline images."
End SubPublic Sub ConvertPathsToIncludePictureFields()Dim doc As Document: Set doc = ActiveDocumentDim i As LongFor i = doc.Paragraphs.Count To START_PARA Step -1Dim para As Paragraph: Set para = doc.Paragraphs(i)Dim path As String: path = ExtractPathFromParagraph(para.Range.text)If Len(path) > 0 ThenReplaceParagraphWithIncludePicture para, pathEnd IfNext iShowMessage "Phase 2 completed: All placeholder lines converted to IncludePicture fields."
End SubPrivate Function ExtractPathFromParagraph(ByVal raw As String) As StringDim txt As String: txt = Trim$(Replace$(raw, vbCr, ""))If Left$(txt, Len(PATH_TAG)) = PATH_TAG ThenExtractPathFromParagraph = Mid$(txt, Len(PATH_TAG) + 1)End If
End FunctionPrivate Sub ReplaceParagraphWithInlineImage(ByVal para As Paragraph, ByVal path As String)If Len(path) = 0 Or Not FileExists(path) Or Not IsImageName(path) Then Exit SubDim rng As Range: Set rng = para.Rangerng.text = ""rng.Collapse wdCollapseStartOn Error Resume NextDim pic As InlineShapeSet pic = rng.InlineShapes.AddPicture(fileName:=path, LinkToFile:=False, SaveWithDocument:=True)If Err.Number = 0 ThenWith pic.LockAspectRatio = msoTrueIf .Width > MAX_IMAGE_WIDTH Then .Width = MAX_IMAGE_WIDTHIf .Height > MAX_IMAGE_HEIGHT Then .Height = MAX_IMAGE_HEIGHTEnd WithNormalizeIMGParagraph rng.Paragraphs(1)LogMessage "Inserted inline image: " & pathElseLogMessage "Failed to insert inline image: " & path & " (" & Err.Description & ")"End IfOn Error GoTo 0
End SubPrivate Sub ReplaceParagraphWithIncludePicture(ByVal para As Paragraph, ByVal path As String)If Len(path) = 0 Or Not FileExists(path) Or Not IsImageName(path) Then Exit SubDim rng As Range: Set rng = para.Rangerng.text = ""rng.Collapse wdCollapseStartpath = Replace(path, "\", "\\")On Error Resume NextDim fld As FieldSet fld = rng.fields.Add(Range:=rng, Type:=wdFieldIncludePicture, _text:=Chr$(34) & path & Chr$(34), PreserveFormatting:=True)fld.UpdateIf Err.Number = 0 And fld.result.InlineShapes.Count > 0 ThenWith fld.result.InlineShapes(1).LockAspectRatio = msoTrueIf .Width > MAX_IMAGE_WIDTH Then .Width = MAX_IMAGE_WIDTHIf .Height > MAX_IMAGE_HEIGHT Then .Height = MAX_IMAGE_HEIGHTEnd WithNormalizeIMGParagraph fld.result.Paragraphs(1)LogMessage "Inserted IncludePicture field: " & pathElseLogMessage "Failed to insert IncludePicture field: " & path & " (" & Err.Description & ")"End IfOn Error GoTo 0
End Sub' ========== APO and Image Discovery ==========
Private Function CollectAPOs(ByVal doc As Document, ByVal startPara As Long) As CollectionInitializeRegexDim col As New CollectionDim seen As Object: Set seen = CreateObject("Scripting.Dictionary")Dim i As LongFor i = startPara To doc.Paragraphs.CountDim apo As String: apo = ExtractAPO(doc.Paragraphs(i).Range.text)If Len(apo) = 18 ThenIf Not seen.Exists(apo) ThenDim item As Object: Set item = CreateObject("Scripting.Dictionary")item("ParaIndex") = iitem("APO") = apocol.Add itemseen.Add apo, TrueEnd IfEnd IfNext iSet CollectAPOs = col
End FunctionPrivate Function DetectMonth(ByVal base As String, ByVal apo As String, ByVal fileCache As Object) As StringDim monthArr As Variant: monthArr = GetMonths(base)Dim rxPDF As Object: Set rxPDF = CreateObject("VBScript.RegExp")rxPDF.IgnoreCase = True: rxPDF.Global = FalserxPDF.Pattern = "^[0-9]+-" & apo & "[ ]*\.pdf$"Dim rxJPG As Object: Set rxJPG = CreateObject("VBScript.RegExp")rxJPG.IgnoreCase = True: rxJPG.Global = FalserxJPG.Pattern = "^[0-9]+-" & apo & "_[0-9]{4}\.(jpg|jpeg|png|bmp|gif)$"Dim m As LongFor m = LBound(monthArr) To UBound(monthArr)Dim month As String: month = monthArr(m)If fileCache.Exists(month) ThenDim fileName As VariantFor Each fileName In fileCache(month).KeysIf rxPDF.Test(fileName) Or rxJPG.Test(fileName) ThenDetectMonth = monthExit FunctionEnd IfNext fileNameEnd IfNext m
End FunctionPrivate Function FindAPOImagesInMonth(ByVal base As String, ByVal monthName As String, ByVal apo As String, ByVal fileCache As Object) As CollectionDim col As New CollectionIf Len(monthName) = 0 Or Not fileCache.Exists(monthName) ThenSet FindAPOImagesInMonth = colExit FunctionEnd IfDim rx As Object: Set rx = CreateObject("VBScript.RegExp")rx.IgnoreCase = True: rx.Global = Falserx.Pattern = "^([0-9]+)-" & apo & "_([0-9]{4})\.(jpg|jpeg|png|bmp|gif)$"Dim paths() As String, pages() As Long, cnt As LongReDim paths(0 To 0): ReDim pages(0 To 0)Dim fileName As VariantFor Each fileName In fileCache(monthName).KeysIf IsImageName(fileName) ThenDim m As Object: Set m = rx.Execute(fileName)If m.Count > 0 ThenReDim Preserve paths(cnt)ReDim Preserve pages(cnt)paths(cnt) = fileCache(monthName)(fileName)pages(cnt) = CLng(m(0).SubMatches(1))cnt = cnt + 1End IfEnd IfNext fileName' Sort by page numberDim i As Long, j As Long, tempPage As Long, tempPath As StringFor i = 0 To cnt - 2For j = i + 1 To cnt - 1If pages(i) > pages(j) ThentempPage = pages(i): pages(i) = pages(j): pages(j) = tempPagetempPath = paths(i): paths(i) = paths(j): paths(j) = tempPathEnd IfNext jNext iFor i = 0 To cnt - 1col.Add paths(i)Next iSet FindAPOImagesInMonth = col
End FunctionPrivate Function FindAPOImagesAcrossMonths(ByVal base As String, ByVal apo As String, ByVal fileCache As Object) As CollectionDim col As New CollectionDim monthArr As Variant: monthArr = GetMonths(base)Dim i As LongFor i = LBound(monthArr) To UBound(monthArr)Dim part As Collection: Set part = FindAPOImagesInMonth(base, monthArr(i), apo, fileCache)Dim k As LongFor k = 1 To part.Countcol.Add part(k)Next kNext iSet FindAPOImagesAcrossMonths = col
End Function' ========== Debugging and Utilities ==========
Public Sub DebugCheckSingleAPO()Dim base As String: base = EnsureBase(BASE_FOLDER)If Len(base) = 0 Then Exit SubDim apo As String: apo = InputBox("Enter APO to check (e.g., APO123456250900036):", "Debug APO", "APO123456250900036")If Len(apo) = 0 Then Exit SubDim fileCache As Object: Set fileCache = CacheFolderFiles(base)Dim output As Stringoutput = "=== Debug APO === " & vbCrLf & _"Base: " & base & vbCrLf & _"APO: " & apo & vbCrLfDim mPDF As String: mPDF = DetectMonth(base, apo, fileCache)output = output & "Detected Month: " & mPDF & vbCrLfDim imgs As Collection: Set imgs = FindAPOImagesInMonth(base, mPDF, apo, fileCache)output = output & "Images in Month (" & mPDF & "): " & imgs.Count & vbCrLfIf imgs.Count = 0 ThenSet imgs = FindAPOImagesAcrossMonths(base, apo, fileCache)output = output & "Images Across All Months: " & imgs.Count & vbCrLfEnd IfDim i As LongFor i = 1 To imgs.Countoutput = output & " - " & imgs(i) & vbCrLfNext iDebug.Print outputLogMessage outputShowMessage "Check completed. See Immediate Window (Ctrl+G) for output."
End SubPrivate Sub NormalizeIMGParagraph(ByVal para As Paragraph)On Error Resume NextWith para.Range.Style = wdStyleNormal.Range.ListFormat.RemoveNumbers.Range.ParagraphFormat.Alignment = wdAlignParagraphCenterEnd WithIf Err.Number <> 0 Then LogMessage "Failed to normalize paragraph: " & Err.DescriptionOn Error GoTo 0
End SubPublic Sub NormalizeAllIMGParagraphs()Dim doc As Document: Set doc = ActiveDocumentDim i As LongFor i = START_PARA To doc.Paragraphs.CountDim txt As String: txt = Trim$(Replace$(doc.Paragraphs(i).Range.text, vbCr, ""))If Left$(txt, Len(PATH_TAG)) = PATH_TAG ThenNormalizeIMGParagraph doc.Paragraphs(i)End IfNext iShowMessage "All [IMG] paragraphs normalized to Normal style and centered."
End SubPublic Sub FixAdjacentEmptyNumberedParagraphs()Dim doc As Document: Set doc = ActiveDocumentDim i As LongFor i = doc.Paragraphs.Count To START_PARA Step -1Dim 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 ThenIf i > START_PARA ThenDim prevPara As Paragraph: Set prevPara = doc.Paragraphs(i - 1)Dim prevTxt As String: prevTxt = Trim$(Replace$(prevPara.Range.text, vbCr, ""))If Len(prevTxt) = 0 ThenprevPara.Range.DeleteElseOn Error Resume NextprevPara.Range.ListFormat.RemoveNumbersIf Err.Number <> 0 Then LogMessage "Failed to remove numbering: " & Err.DescriptionOn Error GoTo 0End IfEnd IfEnd IfNext iShowMessage "Cleaned empty numbered paragraphs before [IMG] placeholders."
End Sub' ========== Utility Functions ==========
Private Function ExtractAPO(ByVal text As String) As StringInitializeRegexDim m As Object: Set m = rxAPO.Execute(text)If m.Count > 0 Then ExtractAPO = m(0).Value
End FunctionPrivate Function EnsureBase(ByVal suggest As String) As StringDim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")Dim base As String: base = suggestIf Not fso.FolderExists(base) Thenbase = InputBox("Enter the root directory containing monthly folders:", "Image Root Directory", suggest)If Len(base) = 0 Then Exit FunctionIf Right$(base, 1) <> "\" And Right$(base, 1) <> "/" Then base = base & "\"If Not fso.FolderExists(base) ThenShowMessage "Directory does not exist: " & base, TrueExit FunctionEnd IfEnd IfEnsureBase = base
End FunctionPrivate Function JoinPath(ByVal base As String, ByVal leaf As String) As StringIf Right$(base, 1) = "\" Or Right$(base, 1) = "/" ThenJoinPath = base & leafElseJoinPath = base & "\" & leafEnd If
End FunctionPrivate Function FileExists(ByVal path As String) As BooleanOn Error Resume NextFileExists = (Len(Dir$(path)) > 0)If Err.Number <> 0 ThenLogMessage "Error checking file: " & path & " (" & Err.Description & ")"FileExists = FalseEnd IfOn Error GoTo 0
End FunctionPrivate Function IsImageName(ByVal name As String) As BooleanDim 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 FunctionPrivate Function CacheFolderFiles(ByVal base As String) As ObjectDim 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 LongFor m = LBound(monthArr) To UBound(monthArr)Dim p As String: p = JoinPath(base, monthArr(m))On Error Resume NextIf fso.FolderExists(p) ThenDim fd As Object: Set fd = fso.GetFolder(p)If Err.Number = 0 ThenDim ff As Objectcache.Add monthArr(m), CreateObject("Scripting.Dictionary")For Each ff In fd.Filescache(monthArr(m)).Add ff.name, ff.pathNext ffElseLogMessage "Failed to access folder: " & p & " (" & Err.Description & ")"End IfEnd IfOn Error GoTo 0Next mSet CacheFolderFiles = cache
End FunctionPrivate Function GetMonths(ByVal base As String) As VariantDim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")Dim months As String, folder As ObjectIf fso.FolderExists(base) ThenFor Each folder In fso.GetFolder(base).SubFoldersIf InStr(folder.name, "月PO") > 0 Thenmonths = months & IIf(months = "", "", "|") & folder.nameEnd IfNext folderEnd IfIf Len(months) = 0 Then months = "5月PO|6月PO|7月PO|8月PO|9月PO" ' Fallback to defaultGetMonths = Split(months, "|")
End FunctionPrivate Sub ShowMessage(ByVal msg As String, Optional ByVal isError As Boolean = False)MsgBox msg, IIf(isError, vbExclamation, vbInformation)LogMessage msg
End SubPrivate Sub LogMessage(ByVal msg As String)On Error Resume NextDim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")Dim logDir As String: logDir = fso.GetParentFolderName(LOG_FILE)If Not fso.FolderExists(logDir) Thenfso.CreateFolder logDirIf Err.Number <> 0 ThenDebug.Print "Failed to create log directory: " & logDir & " (" & Err.Description & ")"Debug.Print Now & ": " & msgExit SubEnd IfEnd IfOpen LOG_FILE For Append As #1If Err.Number = 0 ThenPrint #1, Now & ": " & msgClose #1ElseDebug.Print "Failed to log to file: " & LOG_FILE & " (" & Err.Description & ")"Debug.Print Now & ": " & msgEnd IfOn Error GoTo 0
End SubDebugCheckSingleAPO 根据 pdf 文件名 获取月份和对应的jpg文件路径，若无则回退检查。
InsertAllPathsFrom582_BottomUp 后需要在 PO 单之间添加换行，然后再进行转换成图片（否则格式可能会有问题），无论是用域代码还是根据图片路径直接转换图片。
