0

## 某D企業有限公司 222桃園縣1111111號 Tel.03-22222

222[ADRS]桃園縣1111111號[ADRE]
Tel.03-22222

hahahacja iT邦新手 5 級 ‧ 2010-04-09 23:21:18 檢舉

Sub 巨集1111()
Dim parag As Paragraph
Dim i, nLineNum, total As Integer
nLineNum = 0
total = 0
For Each parag In ActiveDocument.Paragraphs
nLineNum = nLineNum + 1
parag.Range.Select
sText = Selection.Text
i = InStr(sText, "ADRS")
If i > 0 Then
total = total + 1
e = InStr(sText, "ADRE")
sText_len = e - (i + 4)
'MsgBox i & "--" & e
sText2 = Mid(sText, i + 4, sText_len)

Selection.HomeKey Unit:=wdLine '跳到每格的第一個字
Selection.MoveRight Unit:=wdCharacter, Count:=i - 1
'移到ADRS的A字
Selection.Delete Unit:=wdCharacter, Count:=1 '刪A
Selection.Delete Unit:=wdCharacter, Count:=1 '刪D
Selection.Delete Unit:=wdCharacter, Count:=1 '刪R
Selection.Delete Unit:=wdCharacter, Count:=1 '刪S

hahahacja iT邦新手 5 級 ‧ 2010-04-09 23:21:57 檢舉
'移道ADRE前 算選取地址
Selection.MoveRight Unit:=wdCharacter, Count:=sText_len, Extend:=wdExtend
'判地址字數來算要所縮小多少字距
If sText_len < 18 Then
Scaling_num = 100
Else
Scaling_num = 90 - (sText_len - 18) * 3
End If

hahahacja iT邦新手 5 級 ‧ 2010-04-09 23:22:48 檢舉
With Selection.Font
.NameFarEast = "細明體"
.NameAscii = "細明體"
.NameOther = "細明體"
.Name = "細明體"
.Size = 9
.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

hahahacja iT邦新手 5 級 ‧ 2010-04-09 23:24:01 檢舉
.Superscript = False
.Subscript = False
.Spacing = 0
.Scaling = Scaling_num
.Position = 0
.Kerning = 1
.Animation = wdAnimationNone
.DisableCharacterSpaceGrid = False
.EmphasisMark = wdEmphasisMarkNone
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1 '移一格
Selection.Delete Unit:=wdCharacter, Count:=1 '刪A
Selection.Delete Unit:=wdCharacter, Count:=1 '刪D
Selection.Delete Unit:=wdCharacter, Count:=1 '刪R
Selection.Delete Unit:=wdCharacter, Count:=1 '刪e
End If
Next
If total > 0 Then
MsgBox "總計找到 " & total & " 個 地址!!"
End If
End Sub

---end----

### 1 個回答

6

iT邦大神 1 級 ‧ 2010-04-09 14:09:25

``````&lt;pre class="c" name="code">
Sub iTHelpIsGood()
'
'--搜尋 [ADRS] 字串
Selection.Find.ClearFormatting
With Selection.Find
.Text = "[ADRS]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.MatchFuzzy = False
End With
'--如果找得到的話, 就將字體間距縮小
'--如果找不到的話, 就結束執行
Do While Selection.Find.Execute
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
With Selection.Font
.NameFarEast = "新細明體"
.NameAscii = "Times New Roman"
.NameOther = "Times New Roman"
.Name = ""
.Size = 12
.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 = False
.Spacing = -1
.Scaling = 100
.Position = 0
.Kerning = 1
.Animation = wdAnimationNone
.DisableCharacterSpaceGrid = False
.EmphasisMark = wdEmphasisMarkNone
End With
Selection.MoveDown Unit:=wdLine, Count:=1
Loop
End Sub
``````
hahahacja iT邦新手 5 級 ‧ 2010-04-09 23:26:05 檢舉