Select English text only

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

Does this code work for you?

Code:

---

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

---

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.

You can try

Code:

---

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

Code:

---

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.

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

Code:

---

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

---

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 ?

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.

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 ?

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

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"

Code:

---

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

---

Thanks for providing more professional code.

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

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

Code:

---

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

Code:

---

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

---

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

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

Quote:

---

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.

Code:

---

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

---

Code:

---

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

---

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:

Attachment 14875

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

Now the last request here:

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

I manged the Notes issue.

THANKS ALL HELPING ME TO DO THAT HARD REQUEST.