怎么实现VBA排版文章后的落款和时间

sqhsqhli

自动排版标题居中就好了，文章后的落款和时间却要置于右侧，算法是个问题，实现起来也问题多多。代码如下，求指教。
Sub 排版文章结尾的落款和时间()
'排版文章结尾的落款和时间
'调整落款和时间位置，分别可能有以下情况：1、有落款和时间。2、只有时间无落款。3、落款为xxx：，如合同等待签字类型。4、落款很长或几个单位
                 Dim ew As Range, ew2 As Range, ew3 As Range, ha As Integer, i As Integer, p As Integer
           '删除文章后空行和空格段,以及倒数第二段空段落
                Do While ActiveDocument.Paragraphs.Count > 1
                Set ew = ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range
                If Len(Replace(ew.Text, " ", "")) = 1 Then
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range.Delete
                Else
                Exit Do
                End If
                Loop
                If Not (ew.Text Like "*年*月*" & Chr(13)) Then GoTo voa: '如果最后一段非时间格式则倒数1-2段不必排版，
                '至此，已经明确最后一段时间，再检查倒数2段
                 Do While ActiveDocument.Paragraphs.Count > 2
                Set ew2 = ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count - 1).Range
                If Len(Replace(ew2.Text, " ", "")) = 1 Then
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count - 1).Range.Delete
                Else
                Exit Do
                End If
                Loop
     '删除文章后空行和空格段,以及倒数第二段空段落

        '取最大行字符数，最多遍历15行,还有更好的办法吗？页面设置ActiveDocument.PageSetup.CharsLine不可用
Selection.EndKey unit:=wdStory
y = Selection.Information(wdFirstCharacterLineNumber)
Selection.HomeKey unit:=wdStory
Do Until i = 15 Or i = y - 2
Selection.MoveDown unit:=wdLine, Count:=1
Selection.HomeKey unit:=wdLine
Selection.EndKey unit:=wdLine, Extend:=wdExtend
i = i + 1
p = Len(Selection.Range.Text)
If p > ha Then ha = p
Loop
           '取最大行字符数ha
     With ActiveDocument
  If (Len(ew2.Text) < (ha * 3 / 4)) And (ew.Information(wdFirstCharacterLineNumber) - ew2.Information(wdFirstCharacterLineNumber) = 1) Then
   '落款时间都有
   '将倒数第三行空行删除
   Do While ActiveDocument.Paragraphs.Count > 3
                Set ew3 = ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count - 2).Range
                If Len(Replace(ew3.Text, " ", "")) = 1 Then
                ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count - 2).Range.Delete
                Else
                Exit Do
                End If
Loop '将倒数第三行空行删除
Set ew = ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count).Range
ew.ParagraphFormat.Alignment = wdAlignParagraphLeft
ew.Text = Replace(LTrim(RTrim((ew.Text))), Chr(13), "") '去掉左右侧可能空格，落款可能是多个主体，故中间空格保留
  If Int(Len(ew.Text) / 2) < Round(ha / 4 + 0.4, 0) Then
For i = 1 To Len(Space(ha - (Len(ew.Text) - (Round(ha / 4, 0) - Int(Len(ew.Text) / 2)))))
ActiveDocument.Range(ew.Start, ew.Start).InsertBefore "  "
Next
End If
Set ew2 = ActiveDocument.Paragraphs(ActiveDocument.Paragraphs.Count - 1).Range
ew2.ParagraphFormat.Alignment = wdAlignParagraphLeft
ew2.Text = Replace(LTrim(RTrim((ew2.Text))), Chr(13), "") '去掉左右侧可能空格，落款可能是多个主体，故中间空格保留
  If Int(Len(ew2.Text) / 2) < Round(ha / 4 + 0.4, 0) Then
For i = 1 To Len(Space(ha - (Len(ew2.Text) - (Round(ha / 4, 0) - Int(Len(ew2.Text) / 2)))))
ActiveDocument.Range(ew2.Start, ew2.Start).InsertBefore "  "
Next
End If
ew2.InsertBefore Chr(13)
ew2.InsertBefore Chr(13)
ElseIf (Len(ew2.Text) >= ha * 3 / 4) Or (ew.Information(wdFirstCharacterLineNumber) - ew2.Information(wdFirstCharacterLineNumber) <> 1) Then
  '落款太长不符合，仅仅排时间
ew.Text = LTrim(RTrim(Replace((ew.Text), Chr(13), ""))) & Chr(13) '去掉右侧可能空格
ew.ParagraphFormat.Alignment = wdAlignParagraphLeft
If Int(Len(Trim(ew)) / 2) < 7 Then
For i = 1 To 8 - Int(Len(LTrim(RTrim(Replace((ew.Text), Chr(13), "")))) / 2)
ActiveDocument.Range(ew.Start, ew.End - 1).InsertAfter " "
Next
ew.InsertBefore Chr(13)
ew.InsertBefore Chr(13)
End If
End If '都不满足条件，不需要排、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、
'落款为xxx：待签字类型
voa:
Set ew = Nothing
Set ew2 = Nothing
Set ew3 = Nothing
End With

End Sub

sqhsqhli

刚看到413191246se以下代码，用数组直接定义取值，在A4里很好，问题是如果是讲话稿，时间放在标题下他可能也把排右侧了。  另外，我的想法是搞清楚每行最多字符数，让落款时间自适应，比如，A3纸张排个通告，可能每行字符就比较多了，落款能不能根据行的最大字符数和自身的字符数自动调整到合理位置。


Sub 落款()
    Dim arr, r As Range, j&
    arr = Array(17.25, 16.75, 16.25, 15.75, 15.2, 14.6, 14.15, 13.5, 12.95, 12.3, 11.95, 11.4, 10.95, 10.4, 9.85, 8.95, 7.95, 6.95)
    With ActiveDocument.Content.Find
        .ClearFormatting
        .Text = "^13[0-9]{4}年[0-9]{1,2}月[0-9]{1,2}日^13"
        .Forward = True
        .MatchWildcards = True
        Do While .Execute
            With .Parent
                .MoveStart
                If .Style = "标题 1" Then
                    .Start = .End
                Else
                    With .ParagraphFormat
                        .Alignment = wdAlignParagraphRight
                        .CharacterUnitRightIndent = 5.9
                    End With
                    Set r = .Previous(4, 1)
                    With r
                        If .Text Like "*[!。：；，、！？…—.:;,!?]?" Then
                            .InsertBefore Text:=vbCr & vbCr & vbCr
                            .SetRange Start:=.Paragraphs.Last.Range.Start, End:=.Paragraphs.Last.Range.End
                            j = Len(.Text)
                            If j > 20 Then j = 20
                            If .Font.Size = 16 Then
                                .ParagraphFormat.CharacterUnitFirstLineIndent = arr(j - 3)
                            ElseIf .Font.Size = 14 Then
                                .ParagraphFormat.CharacterUnitFirstLineIndent = arr(j - 3) + 3.15
                            End If
                        Else
                            .InsertAfter Text:=vbCr
                        End If
                        .Next(4, 1).Select
                        Exit Sub
                    End With
                End If
            End With
        Loop
    End With
End Sub

413191246se

* 楼主，好久不见！我最近发布的《金秋版》，可否试用了？请提宝贵意见。
* 你对落款要求较高，我要求就较低。其实，我不想要较多代码，够用就好。
* 你读没读过2012《国家机关公文规范（或标准）》PDF？里面有新规定：落款时间必须右空四个汉字。。。不是自己想放到哪里就放到哪里的。
* 楼主，我的最新《金秋版》，如果没用过，建议试用一下，现在的排版速度已经比过去快不少了。。。

sqhsqhli

网上有新规范了。关于落款有根据长度适当调整的表述。另，我写这代码不特别针对公文，主要用在起草的讲话稿，证明，个人小结之类的，化繁为简，偷点小懒。几年不动手了，皮毛也忘了，见笑见笑

sqhsqhli

413191246se 发表于 2020-8-15 20:41
* 楼主，好久不见！我最近发布的《金秋版》，可否试用了？请提宝贵意见。
* 你对落款要求较高，我要求就较 ...

这个是百度上的

xiaoyouxi01

终于遇到同道中人啊！先顶再细看！

“发文机关署名”和“成文日期”自动排版的问题，我也研究了好久，一直没有找到理想的解决方案。

期待高人出手！