CODEWITHSUNDEEP
vbams-wordtransliteration
Vadim
Vadim

Reputation: 1

Interacting with a document without using selection

I have a transliteration function (from cyrillic to latin). I will use this function in a unviersal subroutine (with text of any lenght). This sub must to copy the source text, transliterate (from cyrillic to latin) and paste it below without any formatting changes and without using selection. The next step is reverse transliteration (again copy and paste below). There must be 3 textes in the final. I kinda know how to realize it, but i don't know what i should use instead of selection.

an example of what it have to be in the final is in the picture*

P.S. i tried use For Each word In ActiveDocument.Range.Words but it works bad with reverse transliteration (exactly that. without it, the function works perfectly in debugging) P.P.S. sorry for mistakes in the text, i'm not a native speaker

Upvotes: 0

Views: 122

Answers (1)

macropod
macropod

Reputation: 13515

Since you haven't posted any actual transliteration code, I'll leave you to add the cyrillic and latin character sets to the code below:

Sub Transliterate()
Application.ScreenUpdating = False
Dim p As Long, i As Long, StrLng1, StrLng2
'Insert the character codes for the cyrillic characters here
StrLng1 = Array(ChrW(&H430), ChrW(&H431), ChrW(&H432))
'Insert the corresponding latin characters here
StrLng2 = Array("a", "b", "c")
With ActiveDocument.Range
  Do While .Characters.Last.Previous = vbCr
    .Characters.Last.Previous.Delete
  Loop
  .InsertAfter vbCr
  'Duplicate Content
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "^13"
    .Replacement.Text = "^l"
    .Execute Replace:=wdReplaceAll
    .Font.Bold = True
    .Text = "[!^l]@^l"
    .Replacement.Text = "^p^&"
    .Execute Replace:=wdReplaceAll
    .ClearFormatting
    .Text = "^l^13"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    .Execute Replace:=wdReplaceAll
    .Text = "[!^13]@^13"
    .Replacement.Text = "^&^&^p"
    .Execute Replace:=wdReplaceAll
  End With
  .Characters.Last.Previous.Delete
  .Characters.First.Delete
  'Loop through duplicated paragraphs
  For p = .Paragraphs.Count - 1 To 2 Step -3
    With .Paragraphs(p).Range
      .Font.Italic = True
      'Transliterate paragraph
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Wrap = wdFindStop
        .MatchWildcards = False
        .MatchCase = True
        .Font.Bold = False
        For i = 0 To UBound(StrLng1)
          .Text = StrLng1(i)
          .Replacement.Text = StrLng2(i)
          .Execute Replace:=wdReplaceAll
        Next
      End With
      'Duplicate translated paragraph
      .Characters.Last.Next.FormattedText = .FormattedText
    End With
  Next
  .Characters.Last.Previous.Delete
  'Loop through duplicated paragraphs
  For p = .Paragraphs.Count To 3 Step -3
    With .Paragraphs(p).Range
    .Font.Underline = wdUnderlineSingle
      'Reverse Transliterate paragraph
      With .Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Wrap = wdFindStop
        .MatchWildcards = False
        .Font.Bold = False
        .MatchCase = True
        For i = 0 To UBound(StrLng1)
          .Text = StrLng2(i)
          .Replacement.Text = StrLng1(i)
          .Execute Replace:=wdReplaceAll
        Next
      End With
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub

Upvotes: 0

Related Questions