Maybe this will help. Sub CharacterToSuperscript2() Dim p As Page, s As Shape, t As TextRange, sr As ShapeRange Dim i&, myReplaceFont$, myCharacterToFind$, j& myCharacterToFind = "©" 'changes this character to superscript myReplaceFont = "Arial" 'changes character to this font j = ActiveDocument.ActivePage.Index For Each p In ActiveDocument.Pages p.Activate Set sr = ActivePage.Shapes.FindShapes(, cdrTextShape) For Each s In sr For i = 1 To s.Text.Story.Characters.Count Set t = s.Text.Story.Characters(i) If t = myCharacterToFind Then s.Text.FontPropertiesInRange(i, 1).Position = cdrSuperscriptFontPosition Next i Next s Next p ActiveDocument.Pages(j).Activate End Sub
↧