Converting arabic text to table using a script for custom/auto formatting

[johnny27]

Greetings

I need to present a word for word translation for arabic text so it requires me to convert the arabic text into a borderless table. I need a row with borders below each arabic word to provide the english translation. Bear in mind that the arabic runs from right to left so the table should be anchored accordingly otherwise some of the arabic symbols will not display correctly.

Now to do this manually each time and creating a new table for each paragraph or line of arabic is rather tedious. First you have to select the arabic text, convert it to a table and then the table needs to be anchored the other way so the text is not back to front. Then you have to create another row below with borders for the english translation and make the arabic row borderless to achieve the look I am going for. Doing this for an entire book would waste too much time.

Is there no macro I could use which would allow me to make my arabic text selection and run the macro on that selection then it converts it to a table with a bordered blank row below each word so I can just type in the english translation? The table should fit the width of an A4 page and continue on the next line if the arabic text requires more space. Bear in mind that arabic runs from right to left.

This is the desired output I seek:

15984

Would really appreciate a solution!

Thank you

[gmayor]

Post an example (prefeably as a document rather than a screen shot) of the text BEFORE the processing - preferably the example you have posted in your screen shot so we can see what you have done. I think it fair to say that most contributors (certainly not this one) have no command of Arabic which makes the task less than obvious.

[johnny27]

Hey thanks for the response, sorry for the delay.

Hope this helps.

16015

[gmayor]

Maybe something like the following. Put your cursor in the line to be processed and run the macro. The table is created in a separate document.

Option Explicit
Sub Macro1()
'Graham Mayor - www.gmayor.com
Dim oRng As Range
Dim oDoc As Document
Dim oTarget As Document
Dim oTable As Table
Dim oNewRng As Range
Dim oWord As Range
Dim oCell As Range
Dim i As Long
Dim iCount As Long
Const sPath As String = "C:\Path\Forums\Translate Table.docx"

Set oDoc = ActiveDocument
If Not FileExists(sPath) Then
Set oTarget = Documents.Add
oTarget.PageSetup.Orientation = wdOrientLandscape
oTarget.SaveAs2 Filename:=sPath, AddToRecentFiles:=False
Else
Set oTarget = Documents.Open(Filename:=sPath, AddToRecentFiles:=False)
End If
oDoc.Activate
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Set oRng = Selection.Range
Do While oRng.Characters.Last = Chr(13)
oRng.End = oRng.End - 1
Loop
Set oNewRng = oTarget.Range
oNewRng.Collapse 0
iCount = oRng.Words.Count
Set oTable = oTarget.Tables.Add(Range:=oNewRng, _
NumRows:=2, _
NumColumns:=iCount)
With oTable.Rows(1)
For i = 1 To iCount
Set oWord = oRng.Words(iCount + 1 - i)
Set oCell = .Cells(i).Range
oCell.End = oCell.End - 1
oCell.FormattedText = oWord.FormattedText
Next i
End With
oTable.AutoFitBehavior (wdAutoFitContent)
Set oNewRng = oTarget.Range
oNewRng.Collapse 0
oNewRng.Text = vbCr
oTarget.Save
lbl_Exit:
Set oTarget = Nothing
Set oDoc = Nothing
Set oCell = Nothing
Set oCell = Nothing
Set oRng = Nothing
Set oNewRng = Nothing
Exit Sub
End Sub

Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'strFullName is the name with path of the file to check
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strFullName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

[johnny27]

Thanks for the code.

However I require it to run entire selections of text, one line at a time will be too tedious. Is there no way it can be done to entire selections of text?

Also another problem is that the generated table tries to fit all the words in one line by increasing the column size vertically and decreasing horizontally. Ideally it should maintain the vertical height of the word and whatever horizontal size is required since the words have different lengths. If it is not possible to maintain the horizontal size then it should continue on the next line.

This can be seen in 16031

The blank second row for the english should have solid borders as seen in the first document.

Sorry for being so difficult, I really appreciate the responses.

Thanks again

[gmayor]

What you ask for is quite complex, because there are no 'lines' in a Word document. The 'lines' of text are mere artifices of text flow between the margins. They are volatile entries that vary with formatting. You have complicated that further with the requirement for right left and left right processing. This is why I resorted to a separate document for the tables. I have added a process to take account of a larger selection. The following does not fulfil all your requirements, but is as close as I have been able to get.

Your second document does not display the text from your first document correctly here, and bears no relationship to the example posted originally.


Option Explicit
Sub Macro1()
Dim oSel As Range
Set oSel = Selection.Range
Selection.Collapse 1
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
If Len(Selection.Range) > 1 Then ProcessLine
Do While Selection.InRange(oSel)
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
If Len(Selection.Range) > 1 Then ProcessLine
Loop
lbl_Exit:
Set oSel = Nothing
Exit Sub
End Sub

Sub ProcessLine()
'Graham Mayor - www.gmayor.com
Dim oRng As Range
Dim oDoc As Document
Dim oTarget As Document
Dim oTable As Table
Dim oNewRng As Range
Dim oWord As Range
Dim oCell As Range
Dim oRow As Row
Dim oBorder As Border
Dim i As Long
Dim iCount As Long
Const sPath As String = "C:\Path\Forums\Translate Table.docx"

Set oDoc = ActiveDocument
If Not FileExists(sPath) Then
Set oTarget = Documents.Add
oTarget.PageSetup.Orientation = wdOrientLandscape
oTarget.SaveAs2 Filename:=sPath, AddToRecentFiles:=False
Else
Set oTarget = Documents.Open(Filename:=sPath, AddToRecentFiles:=False)
End If
oDoc.Activate
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Set oRng = Selection.Range
Do While oRng.Characters.Last = Chr(13)
oRng.End = oRng.End - 1
Loop
Set oNewRng = oTarget.Range
oNewRng.Collapse 0
iCount = oRng.Words.Count
Set oTable = oTarget.Tables.Add(Range:=oNewRng, _
NumRows:=2, _
NumColumns:=iCount)
oTable.Range.ParagraphFormat.Alignment = wdAlignParagraphRight

Set oRow = oTable.Rows(1)
With oRow
For i = 1 To iCount
Set oWord = oRng.Words(iCount + 1 - i)
Set oCell = .Cells(i).Range
oCell.End = oCell.End - 1
oCell.FormattedText = oWord.FormattedText
Next i
For Each oBorder In .Borders
oBorder.LineStyle = wdLineStyleNone
Next oBorder
End With

Set oRow = oTable.Rows.Last
With oRow.Borders(wdBorderTop)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With oRow.Borders(wdBorderLeft)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With oRow.Borders(wdBorderBottom)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With oRow.Borders(wdBorderRight)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
With oRow.Borders(wdBorderVertical)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With

oTable.AutoFitBehavior (wdAutoFitContent)
Set oNewRng = oTarget.Range
oNewRng.Collapse 0
oNewRng.Text = vbCr
oTarget.Save
lbl_Exit:
Set oTarget = Nothing
Set oDoc = Nothing
Set oCell = Nothing
Set oCell = Nothing
Set oRng = Nothing
Set oNewRng = Nothing
Exit Sub
End Sub

Private Function FileExists(strFullName As String) As Boolean
'Graham Mayor
'strFullName is the name with path of the file to check
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(strFullName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

[johnny27]

Hi Graham

Thank you so much for your efforts. I really appreciate it! Being able to do a larger selection will have a major improvement on my workflow and save me lots of time. I understand what you mean by there are no "lines" in word.

Thanks again!