[求助]如何用WORD VBA批量自动排版？

fjajie

我手头有很多由其他排版软件转换来的公文文本文件，这些文件格式基本一样，第一行是文件标题，第二行是文号，第三行开始是文件正文，见附件“文本文件.txt”，现在我想把它们批量转换成WORD版的公文文件，有红色字体和红线的函头，如附件“公文版式.DOC”，原本想利用录制宏的方式，但在录制宏时没办法使用鼠标，就画不了横线，而且设置字体也不好设置，相当郁闷![em06]请高手帮忙看看这个VBA程序要怎么写，不胜感激!

fjajie

版主们有没有看看到俺这个求助的呢？

cuteword

用MS-WORD灵感百宝箱吧，其中的智能格式功能是否可以解决！

http://down.banma.com/xingyeguanli/bangongruanjian/msword_ling_gan_bai_bao_xiang_114802.shtml

[此贴子已经被作者于2007-5-30 20:26:01编辑过]

fjajie

谢谢三楼的朋友，我试试看

chylhr

'请参考:

Sub newFile()
   Dim myPath As String, myShape As Shape, myRange As Range
   Dim txt_Doc As Document, txt_Path
   With Application.FileDialog(msoFileDialogFilePicker)
      .Title = "请选择被处理的txt文件"
      .AllowMultiSelect = True
      .Filters.Clear
      .Filters.Add "文本文件", "*.txt"
      If .Show = -1 Then
         For Each txt_Path In .SelectedItems
             Set txt_Doc = Documents.Open(FileName:=txt_Path)
             With txt_Doc.Paragraphs(1).Range.Font
                 .Name = "黑体"
                 .Size = 36
                 .Color = wdColorRed
                 .Parent.ParagraphFormat.Alignment = wdAlignParagraphCenter
             End With
             txt_Doc.Paragraphs(2).Range.Delete          '删除文本文件中的空白第二段
             With txt_Doc.Paragraphs(2).Range.Font  '删除空白段后，第3段变为第2段
                 .Name = "仿宋_GB2312"
                 .Size = 15
                 .Parent.ParagraphFormat.Alignment = wdAlignParagraphCenter
             End With
             txt_Doc.Paragraphs(3).Range.InsertAfter Chr(13)  '第三段后加一个空段
             Set myShape = txt_Doc.Shapes.AddLine(0, 10, 420, 10, txt_Doc.Paragraphs(3).Range)
             With myShape
                .Line.Weight = 3#
                .Line.DashStyle = msoLineSolid
                .Line.Style = msoLineSingle
                .Line.Transparency = 0#
                .Line.Visible = msoTrue
                .Line.ForeColor.RGB = RGB(255, 0, 0)
                .Line.BackColor.RGB = RGB(255, 255, 255)
                .Line.BeginArrowheadLength = msoArrowheadLengthMedium
                .Line.BeginArrowheadWidth = msoArrowheadWidthMedium
                .Line.BeginArrowheadStyle = msoArrowheadNone
                .Line.EndArrowheadLength = msoArrowheadLengthMedium
                .Line.EndArrowheadWidth = msoArrowheadWidthMedium
                .Line.EndArrowheadStyle = msoArrowheadNone
             End With
             Set myRange = txt_Doc.Range(txt_Doc.Paragraphs(3).Range.Start, txt_Doc.Content.End)
             With myRange
                 .Font.Name = "仿宋_GB2312"
                 .Font.Size = 16
                 .ParagraphFormat.CharacterUnitFirstLineIndent = 2
             End With
             txt_Doc.Sections(1).Headers(1).Range.Style = "正文"     '除页眉横线
             txt_Doc.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:= _
                       wdAlignPageNumberCenter, FirstPage:=True
             On Error Resume Next
             MkDir txt_Doc.Path & "\New"
             txt_Doc.SaveAs txt_Doc.Path & "\New\" & Left(txt_Doc.Name, Len(txt_Doc.Name) - 3) & "doc", wdFormatDocument
             txt_Doc.Close
         Next
      Else
        Exit Sub
      End If
   End With

End Sub

fjajie

谢谢chylhr兄，最近工作忙了些日子，今天才上来看到有老大的回复了

等俺试后再回复情况了

[em05]

fjajie

首先要谢谢chylhr，已经解决一部份的问题了，但现在有一个新问题请教，我在打开TXT文件后，想先插入两行字(函头)，并根据要求设置不同的字体，我这么写但得不到正确的结果，能否请您再指导一下？

             Set txt_Doc = Documents.Open(FileName:=txt_Path)

             Selection.TypeText Text:="关 于 X X 问 题 的"
             With Selection.Font
                 .Name = "黑体"
                 .Size = 28
                 .Color = wdColorRed
                 .Parent.ParagraphFormat.Alignment = wdAlignParagraphCenter
             End With

             Selection.TypeText Text:="会 议 纪 要"
             With Selection.Font
                 .Name = "宋体"
                 .Size = 32
                 .Color = wdColorRed
                 .Parent.ParagraphFormat.Alignment = wdAlignParagraphCenter
             End With

好象有看到帮助里说，一个文档只能有一个selection，会不会是这个原因引起的？有什么办法可以实现在打开的TXT文件前插入这个函头吗？期待高手解答!

[em06] c3Jv7H05.rar (2.18 KB, 下载次数: 185)

2007-6-13 19:46 上传

点击文件名下载附件
遇上新问题了

[此贴子已经被作者于2007-6-13 19:46:50编辑过]

chylhr

'将以下代码放在5楼代码的On Error Resume Next前面即可

Set myRange = txt_Doc.Range(0, 0)
myRange.InsertBefore ("会 议 纪 要" & Chr(13))
With myRange.Font
    .Name = "黑体"
    .Size = 28
    .Color = wdColorRed
    .Parent.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
Set myRange = txt_Doc.Range(0, 0)
myRange.InsertBefore ("关 于 X X 问 题 的" & Chr(13))
With myRange.Font
    .Name = "宋体"
    .Size = 32
    .Color = wdColorRed
    .Parent.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With

xwjsyyx

请教chylhr：
你写的代码能否转换为VBS的代码？？？
特别是　.Line.ForeColor.RGB = RGB(255, 0, 0)     和   　.Line.BackColor.RGB = RGB(255, 255, 255)　如何转换！

守柔

注意，红线只需设置段落边框线即可！