WPS VBA当前指定落款单位+日期处盖章

Sub 盖章()
    On Error Resume Next
    Dim doc As Document, shp As Shape, rng As Range, foundShp As Boolean
    Dim searchTerms, i As Integer, validShp As Shape, found As Boolean
    Dim currentPage As Integer, targetLines As Collection, lineRng As Range
    Dim choice As VbMsgBoxResult, moveLeft As Integer, widthCm As Single
    
    Set doc = ActiveDocument
    currentPage = Selection.Information(wdActiveEndPageNumber)
    searchTerms = Array("*印章1*^13", "*印章2*^13")
    found = False
    Set targetLines = New Collection
    
    With Selection
        Set lineRng = .Range.Duplicate: lineRng.Expand wdLine
        If lineRng.Start > 1 Then
            Set lineRng = lineRng.GoTo(wdGoToLine, wdGoToPrevious)
            lineRng.Expand wdLine
            If lineRng.Information(wdActiveEndPageNumber) = currentPage Then targetLines.Add lineRng.Duplicate
        End If
        
        Set lineRng = .Range.Duplicate: lineRng.Expand wdLine
        If lineRng.Information(wdActiveEndPageNumber) = currentPage Then targetLines.Add lineRng.Duplicate
        
        Set lineRng = lineRng.GoTo(wdGoToLine, wdGoToNext)
        lineRng.Expand wdLine
        If lineRng.Information(wdActiveEndPageNumber) = currentPage Then targetLines.Add lineRng.Duplicate
    End With
    
    For Each lineRng In targetLines
        For i = 0 To 1
            Set rng = lineRng.Duplicate
            With rng.Find
                .ClearFormatting: .Text = searchTerms(i): .Font.Size = 16
                .MatchWildcards = True: .Forward = True: .Wrap = wdStop: .Execute
                If .Found Then found = True: Exit For
            End With
            If found Then Exit For
        Next i
        If found Then Exit For
    Next lineRng
    
    If Not found Then
        choice = MsgBox("当前页上下一行未找到单位名称，是否继续盖章？", vbQuestion + vbYesNoCancel)
        If choice = vbNo Or choice = vbCancel Then Exit Sub
        Set rng = doc.GoTo(wdGoToPage, wdGoToAbsolute, currentPage)
        rng.Collapse wdCollapseEnd
    End If
    
    If rng.Information(wdActiveEndPageNumber) <> currentPage Then
        MsgBox "定位位置不在当前页，取消操作", vbExclamation: Exit Sub
    End If
    Selection.SetRange rng.Start, rng.End
    
    foundShp = False
    For Each shp In doc.Shapes
        If shp.Type = msoPicture Then
            widthCm = shp.Width / 28.3465
            If widthCm >= 4 And widthCm <= 4.5 And shp.Anchor.Information(wdActiveEndPageNumber) = currentPage Then
                With shp
                    .WrapFormat.Type = wdWrapBehind: .ZOrder msoSendToBack
                    .RelativeHorizontalPosition = wdRelativeHorizontalPositionCharacter
                    .RelativeVerticalPosition = wdRelativeVerticalPositionCharacter
                    .WrapFormat.AllowOverlap = True
                End With
                Set validShp = shp: foundShp = True: Exit For
            End If
        End If
    Next shp
    
    If Not foundShp Then
        choice = MsgBox("盖印章1点是，盖印章2点否，退出点取消", vbQuestion + vbYesNoCancel)
        Select Case choice
            Case vbYes: Set validShp = CreateShape(doc, "***\印章\印章1.png", 4.3): moveLeft = 0
            Case vbNo: Set validShp = CreateShape(doc, "***\印章\印章2.png", 4.3): moveLeft = -40
            Case vbCancel: Exit Sub
        End Select
        If validShp Is Nothing Then Exit Sub
    Else
        widthCm = validShp.Width / 28.3465
        If Abs(widthCm - 4.34) < 0.1 Then moveLeft = 10 Else If Abs(widthCm - 4.18) < 0.1 Then moveLeft = -40 Else moveLeft = 0
    End If
    
    With validShp
        .Top = .Top + 10: .Left = .Left + moveLeft
        If .Top < 20 Then .Top = 20: If .Left < 20 Then .Left = 20
    End With
    
    Set g_doc = doc: Set g_validShp = validShp: adjustStep = 10
    If IsShapeValid(g_validShp) Then validShp.Select: frmAdjust.Show vbModeless Else MsgBox "印章对象初始化失败", vbExclamation
End Sub

Function CreateShape(doc As Document, imgPath As String, widthCm As Single) As Shape
    On Error Resume Next
    Dim inlineShp As InlineShape
    If Dir(imgPath) = "" Then MsgBox "印章路径不存在：" & imgPath, vbCritical: Exit Function
    Set inlineShp = doc.InlineShapes.AddPicture(imgPath, False, True, Selection.Range)
    If Err <> 0 Then MsgBox "插入图片失败：" & imgPath, vbCritical: Exit Function
    Set CreateShape = inlineShp.ConvertToShape
    CreateShape.Width = widthCm * 28.3465
    With CreateShape
        .WrapFormat.Type = wdWrapBehind: .ZOrder msoSendToBack
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionCharacter
        .RelativeVerticalPosition = wdRelativeVerticalPositionCharacter
        .WrapFormat.AllowOverlap = True
    End With
End Function

Function IsShapeValid(shp As Shape) As Boolean
    On Error Resume Next
    If shp Is Nothing Or Not shp.Parent Is g_doc Then Exit Function
    Dim testName As String: testName = shp.Name
    IsShapeValid = (Err = 0): Err.Clear
End Function

另外有个自动弹出微调印章界面frmAdjust（上下左右控制）因字数限制不展示，可以AI补上缺少代码。