[求助]这个不知怎办?(已解决)

ssq1109 · 发表于 2006-2-22 17:07

Giq4EFLI.rar (2.47 KB, 下载次数: 49)
本网的灵魂人物守柔大侠近时大概非常忙,比前时少见其身影.
烦请再帮忙,见附件.

[此贴子已经被作者于2007-4-2 11:10:15编辑过]

yuyvtul · 发表于 2006-2-23 12:34

楼主的问题，至少第一条我用录制宏实现过。录制的原始宏为(其中很多行是可以省略的)： Sub Macro1() ' ' Macro1 Macro ' 宏在 2006-2-23 由 YUYVTUL 录制 ' Selection.TypeText Text:="SO" Selection.Font.Subscript = wdToggle With Selection.Font .NameFarEast = "宋体" .NameAscii = "Times New Roman" .NameOther = "Times New Roman" .Name = "Times New Roman" .Size = 10.5 .Bold = False .Italic = False .Underline = wdUnderlineNone .UnderlineColor = wdColorAutomatic .StrikeThrough = False .DoubleStrikeThrough = False .Outline = False .Emboss = False .Shadow = False .Hidden = False .SmallCaps = False .AllCaps = False .Color = wdColorAutomatic .Engrave = False .Superscript = False .Subscript = True .Spacing = -3.5 .Scaling = 100 .Position = 0 .Kerning = 1 .Animation = wdAnimationNone .DisableCharacterSpaceGrid = False .EmphasisMark = wdEmphasisMarkNone End With Selection.TypeText Text:="4" With Selection.Font .NameFarEast = "宋体" .NameAscii = "Times New Roman" .NameOther = "Times New Roman" .Name = "Times New Roman" .Size = 10.5 .Bold = False .Italic = False .Underline = wdUnderlineNone .UnderlineColor = wdColorAutomatic .StrikeThrough = False .DoubleStrikeThrough = False .Outline = False .Emboss = False .Shadow = False .Hidden = False .SmallCaps = False .AllCaps = False .Color = wdColorAutomatic .Engrave = False .Superscript = False .Subscript = True .Spacing = 0 .Scaling = 100 .Position = 0 .Kerning = 1 .Animation = wdAnimationNone .DisableCharacterSpaceGrid = False .EmphasisMark = wdEmphasisMarkNone End With Selection.Font.Subscript = wdToggle Selection.Font.Superscript = wdToggle Selection.TypeText Text:="2-" Selection.Font.Superscript = wdToggle End Sub

[此贴子已经被作者于2006-2-23 12:47:00编辑过]

ssq1109 · 发表于 2006-2-23 14:21

我的要求是将所有类似的上标全部替换，不一定就是只一个2-和4。

yuyvtul · 发表于 2006-2-23 20:04

明白了，你是通过双行合一实现的。

守柔 · 发表于 2006-2-23 20:10

以下代码供参考，特别是双行合一，需要楼主特别关注并测试。

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋

'* Created By I LOVE YOU WORD!@ExcelHome 2006-2-23 20:10:03

'仅测试于System: Windows NT Word: 11.0 Language: 2052

'№ 0021^The Code CopyIn [ThisDocument-ThisDocument]^'

'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Option Explicit

Sub Example()

Dim i As Range, myDoc As Document

Dim myString As String, N As Integer, M As Integer

Dim L As Integer

Application.ScreenUpdating = False

With ThisDocument

For Each i In .Characters

With i

'判断是否有边框

If .Font.Borders(1).LineStyle <> wdLineStyleNone Then

If N = 0 Then '边框起始位置加上开始标记

myString = myString & "[BOX(]" & .Text

Else

myString = myString & .Text

End If

N = N + 1

'如果N>0并且此时没有字体边框时,加上结束标记

ElseIf N > 0 And .Font.Borders(1).LineStyle = wdLineStyleNone Then

myString = myString & "[BOX)]" & .Text

N = 0

'判断底纹

ElseIf .Font.Shading.Texture <> wdTextureNone Then

If M = 0 Then

'加上起始底纹标记

myString = myString & "[DW(]" & .Text

Else

myString = myString & .Text

End If

M = M + 1

ElseIf M > 0 And .Font.Shading.Texture = wdTextureNone Then

'加上底纹结束标记

myString = myString & "[DW)]" & .Text

M = 0

'判断双行合一

ElseIf .TwoLinesInOne <> wdTwoLinesInOneNone Then

If L = 0 Then '起始标记

myString = myString & "↑(" & .Text

ElseIf .Text = " " Then '空格作为双行合一的分隔符,必须!

myString = myString & ")↓(" '结束标记

Else

myString = myString & .Text

End If

L = L + 1

ElseIf L > 0 And .TwoLinesInOne = wdTwoLinesInOneNone Then

myString = myString & ")" & .Text

L = 0

Else

myString = myString & .Text

End If

End With

' Debug.Print myString

Set myDoc = Documents.Add

myDoc.Content.InsertAfter myString

Application.ScreenUpdating = True

End Sub

ssq1109 · 发表于 2006-2-24 13:41

奇怪了，守柔大侠的代码运行出现了异常？运行时源文档无任何变化,但又新建了一个空白文档.
我想应该是下两句有问题。
Set myDoc = Documents.Add
myDoc.Content.InsertAfter myString

守柔 · 发表于 2006-2-24 16:45

以下是引用[I]ssq1109[/I]在2006-2-24 13:41:32的发言：[BR]
奇怪了，守柔大侠的代码运行出现了异常？运行时源文档无任何变化,但又新建了一个空白文档.
我想应该是下两句有问题。
Set myDoc = Documents.Add
myDoc.Content.InsertAfter myString

我是在新建的文档中把你需要转化的内容写进去，好让你比较，你比较了吗？什么结果呢？

ssq1109 · 发表于 2006-2-24 17:05

但新文档中什么也没有，旧文档也没有变化。

守柔 · 发表于 2006-2-24 17:48

你把代码置于哪个模块中了？

注意，这是“THISDOCUMENT”不是“ACTIVEDOCUENT”，请将代码粘贴于活动文档的“THISDOCUMET”类模块中。

ssq1109 · 发表于 2006-2-24 20:47

我吃晚饭时已意识到自己可能错了，将U盘的代码COPY在家的老爷机（WIN98+WORD2000）上，再改写（见下，注意倒数第3、4行）后试了一下，OK！

再到单位来时看到你的批评很感惭愧。不过我觉得我改的下面的代码是乎思维太过简单，要是很长的文档且其中包含要替换的此类内容极少，这种类似删除、拷贝的方法效率也太低了，哪怎么改进才好呢？

Option Explicit

Sub Example()

Dim i As Range
Dim myString As String, N As Integer, M As Integer
Dim L As Integer
Application.ScreenUpdating = False
With ActiveDocument
For Each i In .Characters
With i
'判断是否有边框
If .Font.Borders(1).LineStyle <> wdLineStyleNone Then
If N = 0 Then '边框起始位置加上开始标记
myString = myString & "[BOX(]" & .Text
Else
myString = myString & .Text
End If
N = N + 1
'如果N>0并且此时没有字体边框时,加上结束标记
ElseIf N > 0 And .Font.Borders(1).LineStyle = wdLineStyleNone Then
myString = myString & "[BOX)]" & .Text
N = 0
'判断底纹
ElseIf .Font.Shading.Texture <> wdTextureNone Then
If M = 0 Then
'加上起始底纹标记
myString = myString & "[DW(]" & .Text
Else
myString = myString & .Text
End If
M = M + 1
ElseIf M > 0 And .Font.Shading.Texture = wdTextureNone Then
'加上底纹结束标记
myString = myString & "[DW)]" & .Text
M = 0
'判断双行合一
ElseIf .TwoLinesInOne <> wdTwoLinesInOneNone Then
If L = 0 Then '起始标记
myString = myString & "↑(" & .Text
ElseIf .Text = " " Then '空格作为双行合一的分隔符,必须!
myString = myString & ")↓(" '结束标记
Else
myString = myString & .Text
End If
L = L + 1
ElseIf L > 0 And .TwoLinesInOne = wdTwoLinesInOneNone Then
myString = myString & ")" & .Text
L = 0
Else
myString = myString & .Text
End If
End With
Next
End With
Debug.Print myString
'增加的两行
Selection.WholeStory
Selection.Delete

ActiveDocument.Content.InsertAfter myString
Application.ScreenUpdating = True
End Sub

		自动登录	找回密码
密码			免费注册