Word (VBA)

Word VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7全般 : Word 2010)
@が含まれる単語、いわゆるメールアドレスの記述部分(半角または全角空白が文字列の最初と最後にある)に変更を加える
投稿日時: 19/09/12 09:02:33
投稿者: らむだす

@が含まれる単語、いわゆるメールアドレスの記述部分(半角または全角空白が文字列の最初と最後にある)を、作業したいテキストをワード文章からハイライトして・・・
 
@すべてを、消去する
A消去はせずに「xxx@yyy」というテキストに置き換える
 
例) 下記の文章をハイライトして
東京tokyo@tokyo.co.jp より発信されたメールが 京都 kyoto@kyouto.ne.jp へ転送された。
これを、下記のように一発変更したい。
@東京より発信されたメールが 京都  へ転送された。
A東京xxx@yyy より発信されたメールが 京都 xxx@yyy へ転送された。

回答
投稿日時: 19/09/12 16:36:54
投稿者: sk

引用:
@が含まれる単語、いわゆるメールアドレスの記述部分

引用:
A消去はせずに「xxx@yyy」というテキストに置き換える

(標準モジュール)
-----------------------------------------------------------
Sub MaskEmailAddress()
     
    Const EmailAddressPattern As String = "([\w\d\.\!\#\$\%\&\'\*\+\-\/\=\?\^\_\`\{\|\}\~]+)@([\w\d\-]+)\.([\w\d\.\-]*)[\w]{2,4}"
     
    Dim wrdDocument As Word.Document
     
    Dim objRegExp As Object 'VBScript_RegExp_55.RegExp
    Dim objMatchCollection As Object 'VBScript_RegExp_55.MatchCollection
    Dim objMatch As Object 'VBScript_RegExp_55.Match
     
    Dim strSourceString As String
    Dim strAddressMask As String
    Dim lngCnt As Long
     
    strAddressMask = "xxx@yyy.jp"
     
    Set wrdDocument = ActiveDocument
    strSourceString = wrdDocument.Range.Text
     
    Set objRegExp = CreateObject("VBScript.RegExp")
     
    With objRegExp
        .Pattern = EmailAddressPattern
        .IgnoreCase = True
        .Global = True
        .MultiLine = True
        Set objMatchCollection = .Execute(strSourceString)
    End With
         
    If objMatchCollection.Count = 0 Then
        Set objMatchCollection = Nothing
        Set objRegExp = Nothing
        Set wrdDocument = Nothing
        Exit Sub
    End If
     
    With wrdDocument.Range.Find
        .ClearAllFuzzyOptions
        .ClearFormatting
        .ClearHitHighlight
        .MatchWholeWord = True
        .MatchByte = True
        .MatchCase = False
    End With
     
    For lngCnt = 0 To objMatchCollection.Count - 1
        Set objMatch = objMatchCollection(lngCnt)
        Debug.Print objMatch.Value
        With wrdDocument.Range.Find
            .Text = objMatch.Value
            .Replacement.Text = strAddressMask
            .Execute Replace:=wdReplaceOne
        End With
        Set objMatch = Nothing
    Next
     
    Set objMatchCollection = Nothing
    Set objRegExp = Nothing
    Set wrdDocument = Nothing
     
End Sub
-----------------------------------------------------------
 
引用:
@すべてを、消去する

この場合は変数 strAddressMask の値を
空文字列にしておけばよいでしょう。

回答
投稿日時: 19/09/13 12:33:04
投稿者: んなっと

半角または全角空白が文字列の最初と最後にある
と書いてあるのに
東京tokyo@tokyo.co.jp より発信
東京の後ろに半角スペースがないので、回答がためらわれてしまいます。
 
仮に
半角英数字記号@半角英数字記号
と考えると、こんな方法も。
 
Sub test()
  Dim r As Range
  If Selection.Type <> wdSelectionNormal Then
    Set r = ActiveDocument.Content
  Else
    Set r = Selection.Range
  End If
  With r.Find
    .Text = "[\!-~]@\@[\!-~]{1,}"
    .Replacement.Text = "xxx@yyy"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
End Sub

投稿日時: 19/09/15 15:18:21
投稿者: らむだす

◆skさま、
ありがとうございました。問題なく目的達成いたしました。お礼申し上げます。
@については、「strAddressMask の値を空文字列にしておけばよいでしょう」 →値=”” に変更して
成功いたしました。Thank you !
 
◆んなっとさま
 そうでした、例文を正しく表記しませんでした。しかし、さすがは小生の気持ちをわかっていただきました。
お礼もうしあげます。Merci!