能用vba实现水平文本框内文字的垂直对齐吗？

sylun

今天围绕多行或多段落的垂直居中问题进行学习，勉强有了处理办法，当然只是不择手段的土办法，代码自然也不够简洁。至于关键的段落行间距与字符大小、页面设置等的关系问题还是无法弄明，Word对此似乎也是秘而不宣。只以初步测试，不知此法是否可靠。我想应会有简便的方法。

Sub Test()
Dim Oh As Single, myRange As Range, ll As Long, ww As Long, tt As Long
Dim h As Long, h1 As Long, h2 As Long, h3 As Long, h4 As Long, h5 As Long, hh As Long, te As Long
On Error GoTo Exit_sub
Application.ScreenUpdating = False
With Selection
    If .Type <> wdSelectionShape And .ShapeRange.Count <> 1 Then MsgBox "没有选中文本框或光标不在文本框内！": Exit Sub
    .Expand wdStory
    Oh = .ShapeRange.Height
    .ShapeRange.TextFrame.MarginTop = 0
    .ShapeRange.TextFrame.MarginBottom = 0
    Set myRange = .Range
    .StartOf wdStory
    .MoveDown
End With
With myRange
    If Selection.End > 1 Then '如果有两行以上
        .Paragraphs(1).SpaceBefore = 0
        .Paragraphs.Last.SpaceAfter = 0
        ActiveWindow.GetPoint ll, tt, ww, h, myRange
        If PixelsToPoints(h, True) > Oh Then MsgBox "文本框段落有隐藏，程序退出！": Exit Sub
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, ww, h1, .Paragraphs(1).Range.Characters(1)
        .Paragraphs(1).LineSpacingRule = wdLineSpaceExactly
        .Paragraphs(1).LineSpacing = .Paragraphs(1).Range.Font.Size
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, ww, h2, .Paragraphs(1).Range.Characters(1)
        Undo 2
        .Paragraphs.Add
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, ww, h3, .Paragraphs.Last.Previous.Range.Characters.Last
        .SetRange .Start, .Paragraphs.Last.Previous.Range.End
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, ww, h4, myRange
        .MoveEnd wdParagraph, 1
        .Paragraphs.Last.Previous.LineSpacingRule = wdLineSpaceExactly
        .Paragraphs.Last.Previous.LineSpacing = .Paragraphs.Last.Previous.Range.Font.Size
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, ww, h5, .Paragraphs.Last.Previous.Range.Characters.Last
        Undo 3
        hh = PixelsToPoints((h1 - h2) / 2, True)
        te = PixelsToPoints((h3 - h5) / 2, True)
        tt = PixelsToPoints(h4, True) - hh - te
        .Paragraphs(1).SpaceBefore = (Oh - tt) / 2 - hh
    Else  '如果只有一行
        .Paragraphs(1).LineSpacingRule = wdLineSpaceExactly
        .Paragraphs(1).LineSpacing = .Paragraphs(1).Range.Font.Size
        .Paragraphs(1).SpaceBefore = (Oh - .Paragraphs(1).Range.Font.Size) / 2
    End If
    .ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Selection.StartOf wdStory
Exit Sub
Exit_sub: MsgBox "程序意外终止！"
Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2008-4-6 23:27:20编辑过]

雨雪霏霏

sylun兄钻研得好深！佩服！
不知sylun兄能否上传一个附件，好让小弟认真学习每一具体内容？

sylun

雨兄过奖了。我只是喜欢以新鲜帖为学习线索，感觉这样学起来不显得枯燥。既然老兄翻出好帖，我当然要趁机好好学习了。

不知老兄所指的附件是哪方面的，其实论坛基本都有了。

感觉上，对上面的程序稍作修改，应可以针对竖排文本框内容作水平居中对齐，或者两者结合一起用。

sylun

再对代码作了修改，试图自动识别文本框的文字方向并实现居中

Sub SetTextFrameCenter()
'
Dim myRange As Range, TF As Boolean, ll As Long, tt As Long, te As Long, hw As Long
Dim Oh As Single, h As Long, h1 As Long, h2 As Long, h3 As Long, h4 As Long, h5 As Long
Dim Ow As Single, w As Long, w1 As Long, w2 As Long, w3 As Long, w4 As Long, w5 As Long
On Error GoTo Exit_sub
Application.ScreenUpdating = False
With Selection
    If .Type <> wdSelectionShape And .ShapeRange.Count <> 1 Then MsgBox "没有选中文本框或光标不在文本框中！": Exit Sub
    .Expand wdStory
    With .ShapeRange
        Oh = .Height
        Ow = .Width
        If .TextFrame.Orientation = 1 Or .TextFrame.Orientation = 6 Then TF = True
        If TF = True Then
            .TextFrame.MarginTop = 0
            .TextFrame.MarginBottom = 0
        Else
            .TextFrame.MarginLeft = 0
            .TextFrame.MarginRight = 0
        End If
    End With
    Set myRange = .Range
    .StartOf wdStory
    .MoveDown
End With
With myRange
    If Selection.End > 1 Then '如果有两行以上
        .Paragraphs(1).SpaceBefore = 0
        .Paragraphs.Last.SpaceAfter = 0
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, w, h, myRange
        If PixelsToPoints(h, True) > Oh Or PixelsToPoints(w, False) > Ow Then
            MsgBox "文本框文本区域有隐藏，程序退出！"
            Exit Sub
        End If
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, w1, h1, .Paragraphs(1).Range.Characters(1)
        .Paragraphs(1).LineSpacingRule = wdLineSpaceExactly
        .Paragraphs(1).LineSpacing = .Paragraphs(1).Range.Font.Size
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, w2, h2, .Paragraphs(1).Range.Characters(1)
        Undo 2
        .Paragraphs.Add
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, w3, h3, .Paragraphs.Last.Previous.Range.Characters.Last
        .SetRange .Start, .Paragraphs.Last.Previous.Range.End
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, w4, h4, myRange
        .MoveEnd wdParagraph, 1
        .Paragraphs.Last.Previous.LineSpacingRule = wdLineSpaceExactly
        .Paragraphs.Last.Previous.LineSpacing = .Paragraphs.Last.Previous.Range.Font.Size
        Application.ScreenRefresh
        ActiveWindow.GetPoint ll, tt, w5, h5, .Paragraphs.Last.Previous.Range.Characters.Last
        Undo 3
        hw = IIf(TF, PixelsToPoints((h1 - h2) / 2, True), PixelsToPoints((w1 - w2) / 2, False))
        te = IIf(TF, PixelsToPoints((h3 - h5) / 2, True), PixelsToPoints((w3 - w5) / 2, False))
        tt = IIf(TF, PixelsToPoints(h4, True), PixelsToPoints(w4, False)) - hw - te
        .Paragraphs(1).SpaceBefore = IIf(TF, (Oh - tt) / 2, (Ow - tt) / 2) - hw
    Else  '如果只有一行
        .Paragraphs(1).LineSpacingRule = wdLineSpaceExactly
        .Paragraphs(1).LineSpacing = .Paragraphs(1).Range.Font.Size
        .Paragraphs(1).SpaceBefore = (IIf(TF, Oh, Ow) - .Paragraphs(1).Range.Font.Size) / 2
    End If
    .ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Selection.StartOf wdStory
Exit Sub
Exit_sub: MsgBox "程序意外终止！请检查文本框是否有隐藏段落。"
Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2008-4-7 11:21:19编辑过]

雨雪霏霏

　　感谢sylun兄对文本框内容“中部居中”问题的多次探索！
　　小弟这一段时间碰上了一些杂事，久未“回家”，迟复为歉！
　　前边小弟提请sylun兄在发代码帖时最好能加一个示例附件，是想sylun兄能够将“劳动成果”更好地展示于论坛，方便大家学习参考。因由如下：
　　①论坛功能改版时，有可能会将所有独立成段的代码变成一段，有doc文档附件则可避免此问题；
　　②阶段性地探索，必有其特定对象，能够将该对象以及针对该对象的代码一起放在附件中，更有利于大家的学习以及作者本人（呵呵，此处仅指像sylun兄一样的“高手”）每阶段的总结整理。

sylun

QUOTE:

以下是引用雨雪霏霏在2008-5-10 23:48:00的发言：
　　感谢sylun兄对文本框内容“中部居中”问题的多次探索！
　　小弟这一段时间碰上了一些杂事，久未“回家”，迟复为歉！
　　前边小弟提请sylun兄在发代码帖时最好能加一个示例附件，是想sylun兄能够将“劳动成果”更好地展示于论坛，方便大家学习参考。因由如下：
　　①论坛功能改版时，有可能会将所有独立成段的代码变成一段，有doc文档附件则可避免此问题；
　　②阶段性地探索，必有其特定对象，能够将该对象以及针对该对象的代码一起放在附件中，更有利于大家的学习以及作者本人（呵呵，此处仅指像sylun兄一样的“高手”）每阶段的总结整理。

雨兄说的有理。我原想图形对象及文本格式由测试者随意设置也许更能检验程序的适应性，没考虑其他因素，故没有附件。现根据14楼程序补上，烦请测试。谢谢！

Nzaj0lTN.rar (10.37 KB, 下载次数: 198)

2008-5-11 15:47 上传

点击文件名下载附件
能用vba实现水平文本框内文字的垂直对齐吗？

雨雪霏霏

呵呵，感谢sylun兄迅捷出手！得到sylun兄精心打造的附件，操作起来果然顺手！

小弟稍作测试，一切合于sylun兄程序设计初衷：使用该宏，能够将横排文本框、竖排文本框中的文本内容设置为“中部居中”（即在“水平居中”的同时也“垂直居中”）。

该宏的适用条件为：文本框能“从容”地把文本内容包围在内。

异常情况为：对较大号的字体，文本框如果宽度或高度略显“局促”，“挤压”着了文本内容，则该宏不能完成“垂直居中”。

小弟浅评：对于绝大部分的横排文本框、竖排文本框中的文本内容，该宏可以帮助大家快捷地实现手工操作无法实现的“中部居中”效果。而“中部居中”是许多关涉排版的版友们经常需要的。

[此贴子已经被作者于2008-5-12 0:20:34编辑过]