| |
ブック内に含まれる全テキストボックスを対象に
文字の色やスタイル、サイズなどを変えることなく
文字を置換したいのですが、うまくいかず困っています。
例えば「このペンは赤ペンです」という文章がはいったテキストボックスで
「このペンは」は「ＭＳ Ｐゴシック」「黒色の文字」
「赤ペン」は「ＭＳ Ｐ明朝」「赤い文字」「太字」
「です」は「ＭＳ Ｐゴシック」「青色の文字」
というように、文字一つひとつに異なるフォントを設定しているとします。
このテキストボックス内の「赤ペン」の部分を「私の物」と変えたい場合に
「赤ペン」の部分の「ＭＳ Ｐ明朝」「赤い文字」「太字」を変えずに
文字だけ「私の物」に変えたいのです。
そこで、置換をする前に書式の情報を配列にいれてから、文字を置換し、
置換された文章に、元の書式を適用するようなコードを書いたのですが、
一部の書式は保持されるものの、すべての書式を保持することができませんでした。
下記がそのコードです。
解決方法や、参考になるようなサイトなどをご存知でしたら
ご教示の程お願い致します。
なお、下記のコードでは、「検索文字列」と「置換文字列」が
同じ文字数と想定して書いています。
「検索文字列」と「置換文字列」の文字数が違う場合のパターンは
コメントアウトで「検索と置換の文字数が違う場合」と記したところに
書く予定にしています。
Option Explicit
Option Base 1
Dim BeforeStr As String ' 検索文字列
Dim AfterStr As String ' 置換文字列
Dim bCount As Long ' 検索文字列の文字数
Dim aCount As Long ' 置換文字列の文字数
Dim dif As Long ' 置換文字列の文字数−検索文字列の文字数
Dim WS As Worksheet ' ワークシート
Dim s As Shape ' オートシェイプ
Dim i As Long
Dim sCount As Long ' 置換前･後のオートシェイプ内の文字数
Dim myName() As String ' フォントの種類
Dim myFontStyle() As String ' フォントのスタイル（太字、斜体など）
Dim mySize() As Variant ' フォントのサイズ
Dim myStrikethrough() As Boolean ' 水平な取り消し線の設定
Dim mySuperscript() As Variant ' 上付き文字
Dim mySubscript() As Variant ' 下付き文字
Dim myOutlineFont() As Boolean ' アウトライン フォント
Dim myShadow() As Boolean ' 影付きフォント
Dim myUnderline() As Variant ' 下線の種類
Dim myColorIndex() As Variant ' フォントの色
Dim bInStr As Long ' 検索文字が何文字目からスタートするのか
Sub 文字列入力()
' Application.ScreenUpdating = False
BeforeStr = InputBox("置換前の文字列を入力してください。")
AfterStr = InputBox("置換後の文字列を入力してください。")
Call 文字列操作
End Sub
Sub 文字列操作()
bCount = Len(BeforeStr) ' 検索文字列の文字数
aCount = Len(AfterStr) ' 置換文字列の文字数
dif = aCount - bCount ' 検索文字列の文字数−置換文字列の文字数
For Each WS In Worksheets '-----------------------------------------------▼For文 -（1）ブック内のシート全て
WS.Activate
For Each s In WS.Shapes '---------------------------------------------▼For文 -（2）シート内のテキストボックスすべて
If s.Name Like "Text Box*" Then '---------------------------------▼If文 -（1）オートシェイプを判別
s.Select
sCount = Len(Selection.Characters.Text) ' 置換前･後のオートシェイプ内の文字数
bInStr = InStr(Selection.Characters.Text, BeforeStr) ' 検索文字が何文字目からスタートするのか
Call 書式格納
Call 置換
Call 適用
End If '---------------------------------------------------------▲If文 -（1）テキストボックスを判別
Next '----------------------------------------------------------------▲For文 -（2）シート内のテキストボックスすべて
Next '--------------------------------------------------------------------▲For文 -（1）ブック内のシート全て
' Application.ScreenUpdating = True
End Sub
Sub 書式格納()
ReDim myName(sCount) ' フォントの種類
ReDim myFontStyle(sCount) ' フォントのスタイル（太字、斜体など）
ReDim mySize(sCount) ' フォントのサイズ
ReDim myStrikethrough(sCount) ' 水平な取り消し線の設定
ReDim mySuperscript(sCount) ' 上付き文字
ReDim mySubscript(sCount) ' 下付き文字
ReDim myOutlineFont(sCount) ' アウトライン フォント
ReDim myShadow(sCount) ' 影付きフォント
ReDim myUnderline(sCount) ' 下線の種類
ReDim myColorIndex(sCount) ' フォントの色
For i = 1 To sCount '-----------------------------------------▼For文 -（3）オートシェイプ内の1文字〜最後の文字
With Selection.Characters(Start:=i, Length:=i).Font '-----▼With -（2）オートシェイプ内のフォント
If IsNull(.Name) Then '-------------------------------▼IF文 -（2）フォントの種類のプロパティが空のとき
myName(i) = "ＭＳ Ｐゴシック"
Else
myName(i) = .Name
End If '----------------------------------------------▲IF文 -（2）フォントの種類のプロパティが空のとき
If IsNull(.FontStyle) Then '--------------------------▲IF文 -（3）フォントのスタイルのプロパティが空のとき
myFontStyle(i) = "標準"
Else
myFontStyle(i) = .FontStyle
End If '----------------------------------------------IF文 -（3）フォントのスタイルのプロパティが空のとき
mySize(i) = .Size
myStrikethrough(i) = .Strikethrough
mySuperscript(i) = .Superscript
mySubscript(i) = .Subscript
myOutlineFont(i) = .OutlineFont
myShadow(i) = .Shadow
myUnderline(i) = .Underline
myColorIndex(i) = .ColorIndex
End With '------------------------------------------------▲With -（2）オートシェイプ内のフォント
Next '--------------------------------------------------------▲For文 -（3）オートシェイプ内の1文字〜最後の文字
End Sub
Sub 置換()
Selection.Characters.Text = Replace(Selection.Characters.Text, BeforeStr, AfterStr)
End Sub
Sub 適用()
If aCount = bCount Then
For i = 1 To sCount '-----------------------------------------▼For文 -（4）オートシェイプ内の1文字〜最後の文字
With Selection.Characters(Start:=i, Length:=i).Font '-----▼With文 -（3）オートシェイプ内のフォント
.Name = myName(i)
.FontStyle = myFontStyle(i)
.Size = mySize(i)
.Strikethrough = myStrikethrough(i)
.Superscript = mySuperscript(i)
.Subscript = mySubscript(i)
.OutlineFont = myOutlineFont(i)
.Shadow = myShadow(i)
.Underline = myUnderline(i)
.ColorIndex = myColorIndex(i)
End With '--------------------------------------------▲With文 -（3）オートシェイプ内のフォント
Next '----------------------------------------------------▲For文 -（4）オートシェイプ内の1文字〜最後の文字
End If
sCount = Len(Selection.Characters.Text)
ReDim Preserve myName(sCount) ' フォントの種類
ReDim Preserve myFontStyle(sCount) ' フォントのスタイル（太字、斜体など）
ReDim Preserve mySize(sCount) ' フォントのサイズ
ReDim Preserve myStrikethrough(sCount) ' 水平な取り消し線の設定
ReDim Preserve mySuperscript(sCount) ' 上付き文字
ReDim Preserve mySubscript(sCount) ' 下付き文字
ReDim Preserve myOutlineFont(sCount) ' アウトライン フォント
ReDim Preserve myShadow(sCount) ' 影付きフォント
ReDim Preserve myUnderline(sCount) ' 下線の種類
ReDim Preserve myColorIndex(sCount) ' フォントの色
'▼ 検索と置換の文字数が違う場合********************
'▲ 検索と置換の文字数が違う場合********************
End Sub
|
|
めー
- 11/9/1(木) 17:57 -
