Hey everyone,
I developed an algorithm for all words in a paragraph. Each word will be determined by character, in where it's necessary. I wrote this process and algorithm, no problem with this. But I want to make this process without disturbing the fonts. I solved it as well, but the operation is quite slow...
If I made an arrangement to assign all the words the editing process, rate results are excellent. But this time, the styles will disabled.
For getting enabled the style, I need to use this command ".text.words". In this way, it makes the progressing of macro is rather slowly.
Many thanks in advance for your help.
Mahmut
' Method-1; editing text with reset style...
Sub addCharacterWithArray()
Dim s As Shape, sr As ShapeRange
Dim lenArray As Integer
Dim exArray() As String
Set sr = ActiveSelectionRange
For Each s In sr
If s.Type = cdrTextShape Then
exArray() = Split(s.Text.Story.Text, " ")
lenArray = UBound(exArray())
For wCount = 0 To lenArray ' for Word
For iCount = 1 To Len(exArray(wCount)) ' for Characters
Dim ch As String
ch = Mid(exArray(wCount), iCount, 1)
If chVowels(ch) Then
exArray(wCount) = Mid(exArray(wCount), 1, iCount) & "+" & Mid(exArray(wCount), iCount + 1, Len(exArray(wCount)))
'before Mid(exArray(wCount), 1, iCount)
'after Mid(exArray(wCount), iCount + 1, Len(exArray(wCount)))
End If
Next iCount
Next wCount
s.Text.Story.Text = Join(exArray(), " ")
Next s
End Sub
________________________________________________________________________________
' Method-2; editing text with s.text.story.characters (slowly) but i want this method...
Sub addCharacterWithStoryCharacters()
Dim iChr As Integer
ActiveDocument.BeginCommandGroup ("addCharacter")
iChr = s.Text.Story.Characters.Count
For i = 1 To Val(iChr / 100 * 25 + iChr)
If chVowels(s.Text.Story.Characters(i)) Then
s.Text.Story.Characters(i) = s.Text.Story.Characters(i) & "+"
Next i
ActiveDocument.EndCommandGroup
Function chVowels(ch As String) As Boolean
Select Case ch
Case "a", "e", "ı", "i", "o", "ö", "u", "ü", "î", "ê", "û", "A", "E", "I", "İ", "O", "Ö", "U", "Ü", "Î", "Ê"
chVowels = True
Case Else
chVowels = False
End Select
End Function
Instead of looping through every character of every shape that has text I would find only the text shapes that have a character you are looking for. Something like this:
Sub FindMyCharacters() Dim srSelection As ShapeRange, srText As ShapeRange, srContains As ShapeRange Dim s As Shape Dim iChr As Integer Set srSelection = ActiveSelectionRange Set srText = srSelection.Shapes.FindShapes(Type:=cdrTextShape) 'Create ShapeRange with only Text Shapes Set srContains = srText.Shapes.FindShapes(Query:="@com.text.story.text.RegContains('[aeiioöuüîêûAEIIOÖUÜÎÊ]')") 'Create ShapeRange of Text Shapes that Contain Characters we are looking for For Each s In srContains iChr = s.Text.Story.Characters.Count For i = 1 To iChr If chVowels(s.Text.Story.Characters(i)) Then s.Text.Story.Characters(i) = s.Text.Story.Characters(i) & "+" End If Next i Next s End Sub
Hope that helps speed things up,
-Shelby