Select English text only

[baset]

How can i select only the english words and spaces between them and give them a different color.

Example:
Microsoft Lumia 950 XL هو الهاتف الذكي الأمثل الذي يتميز بشاشة QuadHD مقاس 5.7 بوصات، مع
Select:
Microsoft Lumia 950 XL & QuadHD

[John Wilson]

Does this code work for you?


Sub chexUAE()
Dim oshp As Shape
Dim osld As Slide
Dim otr As TextRange
Dim L As Long
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
With oshp.TextFrame.TextRange
For L = 1 To .Runs.Count
Set otr = .Runs(L)
If otr.LanguageID <> msoLanguageIDArabicUAE Then
otr.Font.Color.RGB = vbRed
Else
otr.Font.Color.RGB = vbBlack
End If
Next L
End With
End If
End If
Next oshp
Next osld
End Sub

[baset]

Thanks sir for offering help here; kindly note that i'm not making any selection according to the LanguageID as all text boxes have the same LanguageID (msoLanguageIDArabicEgypt) so i need a macro to go to every text box on every slide and search for any english character then select it then go next character; if it's space also select it if it's english character or number continue selection till he found first un-english character (arabic) then stop selection and after selecting this rang it should be given LtrRun or msoLanguageIDEnglishUS

Sample file is attached.

[SamT]

You can try

If AscW(Character) < 128 Then 'English Character

See "Character Set" in the VBA Help. You can also try < 256 which will catch some other latin characters and common symbols.

See also: http://www.unicode.org/charts/

To insert Arabic Characters, use ChrW

X = ChrW(610) & ChrW(611) & Chrw(612)

I mean no insult, I do not know what the Arabic Characters represented by those three random numbers mean.

[John Wilson]

The original sample did have the languages set to UK and UAE but the second was all the same.

As Sam suggests I think the only way would be to check each character which will run slowly.

This would probably work


Sub chexArabic()

Dim L As Long
Dim oshp As Shape
Dim osld As Slide
For Each osld In ActivePresentation.Slides
For Each oshp In osld.Shapes
If oshp.HasTextFrame Then
If oshp.TextFrame.HasText Then
With oshp.TextFrame.TextRange
For L = 1 To .Characters.Count
If AscW(.Characters(L)) < 256 Then .Characters(L).Font.Color = vbRed
Next L
End With
End If
End If
Next oshp
Next osld
End Sub

[baset]

Thanks for all trying to help here and sorry for any confusion; Let's simplify the request:

I need to select any text range that start and end with any English character or number ?

[John Wilson]

I'm pretty sure that would be impossible (well at least very difficult). If you just need to change the colour there is no need to select anyway.

[baset]

Now i can changed the color and languageID for all english characters and numbers; how can i select only space between 2 red characters or between 2 characters that have LanguageIdEnglishUS ?

[baset]

this is the code i reached so far with the latest example:

For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
With shp.TextFrame.TextRange
For L = 1 To .Characters.Count
If AscW(.Characters(L)) >= 48 And AscW(.Characters(L)) <= 57 Then '0-9
.Characters(L).Font.Color = vbRed
.Characters(L).LanguageID = msoLanguageIDEnglishUS
End If
If AscW(.Characters(L)) >= 65 And AscW(.Characters(L)) <= 90 Then 'A-Z
.Characters(L).Font.Color = vbRed
.Characters(L).LanguageID = msoLanguageIDEnglishUS
End If
If AscW(.Characters(L)) >= 97 And AscW(.Characters(L)) <= 122 Then 'a-z
.Characters(L).Font.Color = vbRed
.Characters(L).LanguageID = msoLanguageIDEnglishUS
End If
If AscW(.Characters(L)) = 174 Or AscW(.Characters(L)) = 8482 Then '® ™
.Characters(L).Font.Color = vbRed
.Characters(L).LanguageID = msoLanguageIDEnglishUS
End If
Next L
End With
End If
End If
Next shp
Next sld

[SamT]

This will be much faster than so many If...Then's. A Select Case ends when any match is found. Checking only for "Less Than" is twice as fast as checking for "between"

For L = 1 To .Characters.Count
Select Case AscW(.Characters(L))
Case < 48 'do nothing
Case < 58 '0-9
With .Characters(L)
.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With
Case < 65 'do nothing
Case < 91 'A-Z
With .Characters(L)
.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With
Case < 97 'do nothing
Case < 123 'a-z
With .Characters(L)
.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With
Case <173 'do nothing
Case 173 '®
With .Characters(L)
.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With
Case < 8482 'do nothing
Case 8482 '™
With .Characters(L)
.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With

Case Else 'do nothing
End Select

Next L

[baset]

Thanks for providing more professional code.

how can i select only space between 2 red characters or between 2 characters that have msoLanguageIDEnglishUS ?

[SamT]

Move the Select Case to a Function, but rewrite the Case's like


Private Function CharType(Letter As String) As String
Select Case AscW(Letter)
Case < 48 'do nothing
Case < 58 '0-9
CharType = "English
Case is = (Number for Space)
CharType = "Space"
'
'
'
End Select
End Function
Then your loop

For L = 1 To .Characters.Count
If CharType(.Characters(L)) = "English" Then
With .Characters(L)
.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With

ElseIf CharType(.Characters(L)) = "Space" Then
If CharType(.Characters(L - 1)) = "English" And CharType(.Characters(L + 1)) = "English" Then
'Do Space Stuff on Character L
End If
End If
Next L

[baset]

Thanks SamT for your reply; Kindly note that i'm not a developer like you (an Expert) and my information is very limited on that matters so can you plz help me how to do your 2 suggestions:

Move the Select Case to a Function, but rewrite the Case's like
Then your loop

[baset]

i used the below suggested code but space is not changed yes:

Sub Baset_PowerPoint_Language()


Dim sld As Slide
Dim shp As Shape
Dim L As Long

For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes


If shp.HasTextFrame Then
shp.TextFrame.TextRange.Font.Name = "Arial"
shp.TextFrame.TextRange.Font.NameComplexScript = "Arial"
shp.TextFrame.TextRange.ParagraphFormat.TextDirection = ppDirectionRightToLeft
shp.TextFrame.TextRange.RtlRun
End If
Next shp
sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Font.Name = "Arial"
sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Font.NameComplexSc ript = "Arial"
sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.ParagraphFormat.Te xtDirection = ppDirectionRightToLeft
sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.RtlRun
Next sld




For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
With shp.TextFrame.TextRange
For L = 1 To .Characters.Count
If CharType(.Characters(L)) = "English" Then
With .Characters(L)
.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With

ElseIf CharType(.Characters(L)) = "Space" Then
If CharType(.Characters(L - 1)) = "English" And CharType(.Characters(L + 1)) = "English" Then
'Do Space Stuff on Character L
With .Characters(L)
.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With
End If
End If
Next L
End With
End If
End If
Next shp
Next sld










End Sub




Private Function CharType(Letter As String) As String
Select Case AscW(Letter)
Case Is < 48 'do nothing
Case Is < 58 '0-9
CharType = "English"
Case Is = 32
CharType = "Space"
Case Is < 65 'do nothing
Case Is < 91 '0-9
CharType = "English"
Case Is < 97 'do nothing
Case Is < 123 '0-9
CharType = "English"
Case Is = 174
CharType = "English"
Case Is = 8482
CharType = "English"
End Select
End Function

[SamT]

but space is not changed
How do you know? You can't "see" a space character, so it has no color.

The code looks good. I rewrote the Sub Baset for speed. I hope I put all the lines in the right loops.


I added some code lines to place a double underline on all Spaces worked on. See the Comments to see how to remove them after testing. Run this sub and look for double Underlines where Spaces are.
Sub Baset_PowerPoint_Language()

Dim sld As Slide
Dim shp As Shape
Dim L As Long

For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes

If shp.HasTextFrame Then
'Using "Wtih" is faster
With shp.TextFrame.TextRange
.Font.Name = "Arial"
.Font.NameComplexScript = "Arial"
.ParagraphFormat.TextDirection = ppDirectionRightToLeft
.RtlRun

For L = 1 To .Characters.Count
If CharType(.Characters(L)) = "English" Then
With .Characters(L)
.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With

ElseIf CharType(.Characters(L)) = "Space" Then
If CharType(.Characters(L - 1)) = "English" And CharType(.Characters(L + 1)) = "English" Then
'Do Space Stuff on Character L
With .Characters(L)

'X Line: Remove all X lines after testing
.Font.Underline = -4119 'X line: = Double under line
'X line: Uncomment next line to remove underlines
'.Font.Underline = -4142 'X line: = no underline

.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With
End If
End If
Next L

End With
End If
Next shp

With sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange
.Font.Name = "Arial"
.Font.NameComplexSc ript = "Arial"
.ParagraphFormat.Te xtDirection = ppDirectionRightToLeft
.RtlRun
End With
Next sld

End Sub


Private Function CharType(Letter As String) As String
Select Case AscW(Letter)
Case Is < 48 'do nothing
Case Is < 58 '0-9
CharType = "English"
Case Is = 32
CharType = "Space"
Case Is < 65 'do nothing
Case Is < 91 '0-9
CharType = "English"
Case Is < 97 'do nothing
Case Is < 123 '0-9
CharType = "English"
Case Is = 174
CharType = "English"
Case Is = 8482
CharType = "English"
End Select
End Function

[baset]

Dear SamT

You are the master; Thanks for re-writing the code in better way; kindly note that i tested it and i'm going crazy as the spaces still not changed/affected although the code seems perfect:

14875

[baset]

I changed some code on the Function and the below code is worked well:

Sub Baset_PowerPoint_Language()

Dim sld As Slide
Dim shp As Shape
Dim L As Long

For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes

If shp.HasTextFrame Then

With shp.TextFrame.TextRange
.Font.Name = "Arial"
.Font.NameComplexScript = "Arial"
.ParagraphFormat.TextDirection = ppDirectionRightToLeft
.RtlRun

For L = 1 To .Characters.Count
If CharType(.Characters(L)) = "English" Then
With .Characters(L)
.Font.Color = vbRed
.LanguageID = msoLanguageIDEnglishUS
End With

ElseIf CharType(.Characters(L)) = "Space" Then
If CharType(.Characters(L - 1)) = "English" And CharType(.Characters(L + 1)) = "English" Then
With .Characters(L)
'.Font.Underline = -4119
.LanguageID = msoLanguageIDEnglishUS
End With
End If
End If
Next L

End With
End If
Next shp

With sld.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange
.Font.Name = "Arial"
.Font.NameComplexScript = "Arial"
.ParagraphFormat.TextDirection = ppDirectionRightToLeft
.RtlRun
End With
Next sld

End Sub




Private Function CharType(Letter As String) As String
Select Case AscW(Letter)

Case Is = 32
CharType = "Space"

Case 48 To 57 '0-9
CharType = "English"

Case 65 To 90 'A-Z
CharType = "English"

Case 97 To 122 'a-z
CharType = "English"

Case Is = 174 '®
CharType = "English"

Case Is = 8482 '™
CharType = "English"

End Select
End Function

[baset]

Now the last request here:

How can i made the same "English" "Space" changes applied also for the Notes text ???

[baset]

I manged the Notes issue.

THANKS ALL HELPING ME TO DO THAT HARD REQUEST.