|
在活动文档的工程资源管理器下插入一模块（必须） 确认当前WORD程序只有一个文档即活动文档关闭其它WORD窗口和文档（必须） 运行过程：DelSecBlank 代码如下： Option Compare Text '将字符串比较方法设为 Text,不区分字母大小写
Sub SaveText()
Dim i As Paragraph, a As Long, b As Long, c As Range, NewDoc As Document
Dim FilName As String, SavPath As String
On Error Resume Next
Application.ScreenUpdating = False
SavPath = "D:\temp\" '预设保存路径
a = 0 '预设起点位置
For Each i In ActiveDocument.Paragraphs '段落中循环
If Len(i.Range) <= 1 Then '如果为空白段落(行)
'如果该段落的下一个段落中不包括英文字母或者包括英文字母但段落为粗体字者
If i.Next(1).Range Like "[A-Z]*" = False Or i.Next(1).Range.Font.Bold = True Then
b = i.Range.End '取得该段落最后位置
Set c = ActiveDocument.Range(a, b) '设置Range对象
'从C中提取文件名,该文件名为C中的第一个段落(提问),去掉空格和最后的回车符
FilName = Mid(Trim(c.Paragraphs(1)), 1, Len(Trim(c.Paragraphs(1))) - 1)
' ActiveDocument.Range(a, b).Select
Set NewDoc = Documents.Add '新建一文档
Selection.InsertAfter c '插入问答题内容
'另存为文本文件
NewDoc.SaveAs FileName:=SavPath & FilName & ".txt", FileFormat:=wdFormatText
ActiveWindow.Close False '退出该文档
Set NewDoc = Nothing
End If
End If
a = b '重设起点位置
Next
Application.ScreenUpdating = True
End Sub
Sub DelSecBlank()
Dim i As Paragraph, ParEnd As Long
On Error Resume Next
Application.ScreenUpdating = False
With ActiveDocument
ParEnd = .Paragraphs.Count
.Paragraphs(ParEnd).Range.InsertAfter Chr(13) & Chr(13) & "小奔" & Now '设定最后一个标记
ParEnd = .Paragraphs.Count
.Paragraphs(ParEnd).Range.Font.Bold = True
.Paragraphs(1).Range.Delete '第一个段落删除(与要求不符)
For Each i In .Paragraphs
If Len(i.Range) <= 1 And Len(i.Next(1).Range) <= 1 Then
i.Next(1).Range.Delete '查找连续二个空白段落者将第二个空白段落删除
End If
Next
End With
Application.ScreenUpdating = True
Call SaveText
End Sub
| 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2004-8-23 11:22
楼主