تشكيل آلي:

[أبو عاصم المصري]

هذا ماكرو للتشكيل الآلي، بحيث يفتح الباحث ملفين، أحدهما الذي يريد تشكيله، والآخر يأخذ منه التشكيل، وينبغي أن يسمى الملف الذي يأخذ منه التشكيل (----).

ولك أن تطلب تشكيل 6 أو 5 أو 4 أو 3 أو 2 أو 1 يعني ست كلمات أو خمس، أو....

فيقوم الماكرو بنسخ الكلمات المطلوب تشكيلها، ويبحث بها في الملف المشكول، فإن وجدها رجل إلى الملف المطلوب تشكيل ويقوم بعملية استبدال لهذه الكلمات، فيضع الكلمات المشكولة مكان غير المشكولة.

ويفضل بشدة لمن أراد الدقة في التشكيل أن يعتمد على نص مشكول في نفس موضوع الملف المراد تشكيله.

كما ينبغي أن يبدأ بالعدد الأعلى ثم الأدنى، فيبدأ بـ(6) كلمات، ثم (5) ثم (4)، وهكذا حتى يصل لكلمة واحدة.

ويفضل أن تحذف علامات الترقيم والأقواس ونحوها من النص المشكول.

والماكرو يطلب منك عدد مرات التنفيذ، والمدة المطلوبة في إجراء العملية، وهذا بغرض منع الجهاز من التهنيج.

وهذا الماكرو لمن أراد:

On Error Resume Next
    Dim x, a, b, c, y As Integer
    Dim sPrompt As String
    Dim sUserResp As String
    Dim iUR As Integer
    Dim t As Date
   t = Now
   Dim StartTime As Date
   StartTime = Now
   Do

    sPrompt = "1. تشكيل كلمة واحدة" & vbCrLf
    sPrompt = sPrompt & "2. تشكيل كلمتين" & vbCrLf
    sPrompt = sPrompt & "3. تشكيل ثلاث كلمات" & vbCrLf
    sPrompt = sPrompt & "4. تشكيل أربع كلمات" & vbCrLf
    sPrompt = sPrompt & "5. تشكيل خمس كلمات" & vbCrLf
    sPrompt = sPrompt & "6. تشكيل ثلاث كلمات" & vbCrLf
    iUR = 0   '''''''''''''''''
    While iUR < 1 Or iUR > 6
        sUserResp = InputBox(sPrompt, "اختر واحدًا مما يلي")
        iUR = Val(sUserResp)
        
        ''''''''''''''''' لإمكانية إلغاء جميع الاختيارات وقفل الكود
        If iUR = False Then
Exit Sub

End If
'''''''''''''''''''''' لعمل case لعدة خيارات في  InputBox
    Wend
    Select Case iUR
        Case 1

   aa = (" <[!ًٍَُِّْ ]@> ")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
    y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   Case 2
   
   aa = (" <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> ")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
    y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   
   Case 3

   aa = (" <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> ")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))

   Case 4

   aa = (" <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> ")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))

   Case 5

   aa = (" <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> ")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   Case 6

   aa = (" <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> ")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   End Select
   
   For i = 1 To x
  If DateDiff("n", StartTime, Now, endTime) = y Then
    
    ' s =عدد الثواني
    ' n =الدقائق
    ' h =ساعة
    
    MsgBox "تم تشكيل الكلمات غير المشكولة وتلوينها باللون البرتقالي" & Format(Now - t, " والوقت المستغرق = h:n:s  ")
        
    Exit Do
         
    Exit Sub
    ActiveDocument.Save
    End If
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .text = aa
        .Replacement.text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute
   If Selection.Find.Found = False Then
    Exit Sub
   Else
   End If
   a = Selection.text
    Selection.MoveRight Unit:=wdCharacter, count:=1
    Selection.MoveLeft Unit:=wdCharacter, count:=1
    Windows(1).Activate
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .text = a
        .Replacement.text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = True
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
   If Selection.Find.Found = False Then
    Windows(2).Activate
    Selection.MoveLeft Unit:=wdCharacter, count:=2
 
   Else
   
   b = Selection.text
    Selection.MoveRight Unit:=wdCharacter, count:=1
    Windows(2).Activate
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Color = 49407     ' اللون البرتقالي
    With Selection.Find
        .text = a
        .Replacement.text = b
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = True
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
   End If
    Selection.Find.Execute Replace:=wdReplaceAll

Next i
 Beep

   MsgBox "تم تشكيل الكلمات غير المشكولة وتلوينها باللون البرتقالي" & Format(Now - t, " والوقت المستغرق = h:n:s  ")
        
    Exit Do
    Exit Sub
    Loop
ActiveDocument.Save
Beep

End Sub
 

[أبو عاصم المصري]

هذا أحدث:

On Error Resume Next
    Dim x, a, b, c, y As Integer
    Dim sPrompt As String
    Dim sUserResp As String
    Dim iUR As Integer
    Dim t As Date
   t = Now
   Dim StartTime As Date
   StartTime = Now
   Do

    sPrompt = "1. تشكيل كلمة واحدة" & vbCrLf
    sPrompt = sPrompt & "2. تشكيل كلمتين" & vbCrLf
    sPrompt = sPrompt & "3. تشكيل ثلاث كلمات" & vbCrLf
    sPrompt = sPrompt & "4. تشكيل أربع كلمات" & vbCrLf
    sPrompt = sPrompt & "5. تشكيل خمس كلمات" & vbCrLf
    sPrompt = sPrompt & "6. تشكيل ثلاث كلمات" & vbCrLf
    iUR = 0   '''''''''''''''''
    While iUR < 1 Or iUR > 6
        sUserResp = InputBox(sPrompt, "اختر واحدًا مما يلي")
        iUR = Val(sUserResp)
        
        ''''''''''''''''' لإمكانية إلغاء جميع الاختيارات وقفل الكود
        If iUR = False Then
Exit Sub

End If
'''''''''''''''''''''' لعمل case لعدة خيارات في  InputBox
    Wend
    Select Case iUR
        Case 1

   aa = (" <[!ًٍَُِّْ ]@> ")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
    y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   Case 2
   
   aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
    y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   
   Case 3

   aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))

   Case 4

   aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))

   Case 5

   aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   Case 6

   aa = ("<[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@> <[!ًٍَُِّْ ]@>")
   x = (InputBox("اكتب عدد مرات التنفيذ"))
   y = (InputBox("حدد مدة تشغيل الماكرو بالدقائق"))
   End Select
   
   For i = 1 To x
  If DateDiff("n", StartTime, Now, endTime) = y Then
    
    ' s =عدد الثواني
    ' n =الدقائق
    ' h =ساعة
    
    MsgBox "تم تشكيل الكلمات غير المشكولة وتلوينها باللون البرتقالي" & Format(Now - t, " والوقت المستغرق = h:n:s  ")
        
    Exit Do
         
    Exit Sub
    ActiveDocument.Save
    End If
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = aa
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute
   If Selection.Find.Found = False Then
    Exit Sub
   Else
   End If
   a = Selection.Text
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Windows(1).Activate
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = a
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = True
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
   If Selection.Find.Found = False Then
    Windows(2).Activate
  Selection.MoveRight Unit:=wdWord, Count:=2

 
   Else
   
   b = Selection.Text
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Windows(2).Activate
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Font.Color = 49407     ' اللون البرتقالي
    With Selection.Find
        .Text = a
        .Replacement.Text = b
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = True
        .MatchAlefHamza = True
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    End If
Selection.MoveRight Unit:=wdWord, Count:=2

Next i
 Beep

   MsgBox "تم تشكيل الكلمات غير المشكولة وتلوينها باللون البرتقالي" & Format(Now - t, " والوقت المستغرق = h:n:s  ")
        
    Exit Do
    Exit Sub
    Loop
ActiveDocument.Save
Beep

End Sub