none
Macro for subtituting extended characters to HTML code points

    Question

  • Hi,

    I'm new to VB and I'm trying to create a macro for word that will convert the non-latin extended characters to HTML code points.

    I've worked it out as the snippet below shows but it takes an age as I run through every possible non-latin character. I'm sure there must be a more efficient method like a scan for or do while character between chrW(128) and chr(984), if found replace etc. but I'm struggling with it.

    Many thanks in advance for help.

    Sub convert_extended()
    '
    ' convert_extended Macro
    '
    '
    Set rngSearch = ActiveDocument.Content
    rngSearch.Find.Execute FindText:=ChrW(128), Wrap:=wdFindContinue, ReplaceWith:="€", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(131), Wrap:=wdFindContinue, ReplaceWith:="ƒ", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(134), Wrap:=wdFindContinue, ReplaceWith:="†", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(135), Wrap:=wdFindContinue, ReplaceWith:="‡", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(137), Wrap:=wdFindContinue, ReplaceWith:="‰", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(138), Wrap:=wdFindContinue, ReplaceWith:="Š", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(140), Wrap:=wdFindContinue, ReplaceWith:="Œ", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(142), Wrap:=wdFindContinue, ReplaceWith:="Ž", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(153), Wrap:=wdFindContinue, ReplaceWith:="™", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(154), Wrap:=wdFindContinue, ReplaceWith:="š", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(156), Wrap:=wdFindContinue, ReplaceWith:="œ", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(158), Wrap:=wdFindContinue, ReplaceWith:="ž", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(159), Wrap:=wdFindContinue, ReplaceWith:="Ÿ", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(162), Wrap:=wdFindContinue, ReplaceWith:="¢", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(163), Wrap:=wdFindContinue, ReplaceWith:="£", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(165), Wrap:=wdFindContinue, ReplaceWith:="¥", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(167), Wrap:=wdFindContinue, ReplaceWith:="§", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(169), Wrap:=wdFindContinue, ReplaceWith:="©", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(170), Wrap:=wdFindContinue, ReplaceWith:="ª", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(174), Wrap:=wdFindContinue, ReplaceWith:="®", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(176), Wrap:=wdFindContinue, ReplaceWith:="°", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(177), Wrap:=wdFindContinue, ReplaceWith:="±", Replace:=wdReplaceAll
    rngSearch.Find.Execute FindText:=ChrW(178), Wrap:=wdFindContinue, ReplaceWith:="²", Replace:=wdReplaceAll


    Thursday, December 19, 2013 10:24 AM

Answers

  • I think you could use something more like this:

    Sub substchars()
    Dim rngSearch As Range
    Set rngSearch = ActiveDocument.Content
    With rngSearch.Find
      .ClearFormatting
      .MatchAllWordForms = False
      .MatchWildcards = True
      .Forward = True
      .Wrap = wdFindContinue
      .Text = "[" & ChrW(128) & "-" & ChrW(984) & "]"
      While .Execute
        rngSearch.Text = "&#" & CStr(AscW(rngSearch.Text)) & ";"
      Wend
    End With
    End Sub
    


    Peter Jamieson

    Thursday, December 19, 2013 6:12 PM

All replies

  • Hello coolh4nd,

    As far as I know the Word Object Model doesn't provide anything else for searching and replacing a text in the document. The Find object is the only possible way for implementing the required functionality without loosing formatting.

    I would suggest configuring the Find object and then call Execute method without getting a new Find object each time, for example:

    Dim fnd as Word.Find
    Set fnd = rngSearch.Find
    fnd.Wrap := wdFindContinue
    fnd.Replacement.Text:="€"
    fnd.Text:=ChrW(128)
    ind.Execute  
    ' then each time you need to set the text to look for and run the search procedure again
    fnd.Text:=ChrW(128)
    ind.Execute  
    
    You can read more about this in the How to: Programmatically Search for and Replace Text in Documents article in MSDN.

    Thursday, December 19, 2013 12:26 PM
  • I think you could use something more like this:

    Sub substchars()
    Dim rngSearch As Range
    Set rngSearch = ActiveDocument.Content
    With rngSearch.Find
      .ClearFormatting
      .MatchAllWordForms = False
      .MatchWildcards = True
      .Forward = True
      .Wrap = wdFindContinue
      .Text = "[" & ChrW(128) & "-" & ChrW(984) & "]"
      While .Execute
        rngSearch.Text = "&#" & CStr(AscW(rngSearch.Text)) & ";"
      Wend
    End With
    End Sub
    


    Peter Jamieson

    Thursday, December 19, 2013 6:12 PM