שיתוף | מאקרו בדיקת מהירות הקלדה

[יהודי זה הכי]

חבר שלי בנה (עם בינה מלאכותית) בסיס למאקרו של בדיקת מהירות הקלדה
ואני שיפצתי את זה קצת (עם בינה אנושית)

לצערי אני לא יודע ליצור מקרואים לחילוץ עצמי וכו' אז מי שרוצה ויעשה את זה אני אשמח

בכ"א

זה הצהרות המשתנים

Option Explicit ' מחייב הצהרה על כל המשתנים, למניעת טעויות

' --- משתנים גלובליים (משותפים לכל הפונקציות במודול זה) ---
' משתנים אלו שומרים את מצב הבדיקה והנתונים הנאספים

' משתנים הקשורים לבדיקה עצמה
Public g_TargetDocument As Word.Document ' המסמך בו מתבצעת הבדיקה
Public g_TestIsActive As Boolean         ' האם הבדיקה פעילה כעת? (אמת/שקר)
Public g_TestStartTime As Date           ' מועד התחלת הבדיקה
Public g_TestStartTime1 As Date           'מועד הפעלת פונקציית הבדיקה
Public g_InitialCharCount As Long        ' מספר התווים במסמך בתחילת הבדיקה
Public g_LastCharCount As Long           ' מספר התווים במסמך בבדיקה הקודמת (לחישוב שינויים)
Public avi As Long 'סופר כמה בדיקות הקלדה בוצעו
Public totalTestDurationSeconds1 As Double 'סך זמן פעולת פונקציית הבדיקה
  Public lettersPerSecond1 As Double
  Public totalTestDurationSeconds2 As String 'מד זמן פעולת פונקציית הבדיקה
  Public totalTestDurationSeconds3 As String 'מד זמן פעולת העצירה
Public aa As String 'בחירה בהודעה קופצת
Public error_Shapes As Boolean 'כרגע אין צורך בכלום בעצירה כשאין תיבת טקסט
Public g_TestStartTime2 As Double 'זמן עצירת הבדיקה
Public stop_break As Boolean 'האם בדיקת ההקלדה נעצרה
Public routing As Boolean 'האם הופנה ממאקרו אחר
Public exit_err As Boolean 'האם הייתה שגיאה והופעלה הבדיקה מההתחלה

זה המאקרו להפעלה

' =========================================================================
' ===                    מאקרו להתחלת בדיקת ההקלדה                    ===
' =========================================================================

Public Sub StartTypingTest_Beta()
    ' נועד להפעלה על ידי המשתמש כדי להתחיל את סשן בדיקת ההקלדה


avi = 0 'מאפס כמות בדיקות
    ' בדיקה אם יש מסמך פתוח
    If Application.Documents.Count = 0 Then
        MsgBox "נא פתח או צור מסמך Word לפני התחלת הבדיקה.", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאה"
        Exit Sub ' יציאה מהמאקרו אם אין מסמך פתוח
    End If

    ' בדיקה אם כבר מתקיימת בדיקה
    If g_TestIsActive Then
aa = MsgBox("בדיקת ההקלדה כבר פעילה." & vbCrLf & "האם להציג דו""ח?", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading + vbYesNo, "בדיקה פעילה")
       If aa = vbYes Then StopTypingTest_Beta
        Exit Sub ' יציאה אם הבדיקה כבר רצה
    End If

    ' איפוס וקביעת ערכים התחלתיים למשתנים הגלובליים
    Set g_TargetDocument = ActiveDocument   ' קביעת המסמך הנוכחי כמסמך היעד לבדיקה
    g_TestStartTime = Now                   ' שמירת זמן התחלת הבדיקה
    g_InitialCharCount = g_TargetDocument.Characters.Count ' שמירת מספר התווים ההתחלתי במסמך
    g_LastCharCount = g_InitialCharCount    ' הגדרת מספר התווים האחרון למספר ההתחלתי

    g_TestIsActive = True                   ' סימון שהבדיקה החלה ופעילה
    error_Shapes = False 'כרגע אין צורך בכלום בעצירה כשאין תיבת טקסט

    ' הודעה למשתמש שהבדיקה החלה
MsgBox "בדיקת הקלדה החלה בעזרת השם." & vbCrLf & vbCrLf & _
           "לחץ על הצגת נתונים, כדי לקבל דו""ח מפורט.", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "התחלת בדיקת הקלדה"

End Sub

זה מאקרו להצגת דו"ח עם השהיה תוך כדי

' =========================================================================
' ===             מאקרו לעצירת בדיקת ההקלדה והצגת דו"ח               ===
' =========================================================================
Public Sub StopTypingTest_Beta()
    ' נועד להפעלה על ידי המשתמש כדי לסיים את סשן בדיקת ההקלדה ולהציג את הדו"ח

Dim n As String
    Dim finalCharCount As Long
    Dim netCharsTyped As Long
    Dim totalTestDurationSeconds As Double
    Dim lettersPerSecond As Double
    Dim lettersPerMinute As Double
    Dim timeFor1000Letters As Double
    Dim previousLPS As Double
    Dim ImprovementText As String
    Dim reportRange As Word.Range
    Dim reportTable As Word.Table
    Dim tempVal As String ' משתנה עזר לקריאת נתונים שמורים
    Dim total_Char As Long
    Dim effectiveTypingM As Double
exit_err = False 'מאפס את מצב השגיאה
If stop_break = True Then 'אם הבדיקה כבר בהשהייה שיציג ישר נתונים
Else 'אחרת
 routing = True 'מגדיר שמנותב למאקרו אחר
stop_test_Beta 'מעביר להשהיית הבדיקה
 routing = False 'מסיים את מצב הניתוב
 End If
 If exit_err = True Then Exit Sub 'אם הופעל פה התחלת הבדיקה שייצא מהמאקרו
'g_TestStartTime1 = Now 'לוקח את זמן התחלת הבדיקה




    finalCharCount = g_TargetDocument.Characters.Count ' קריאת מספר התווים הסופי
  

    On Error GoTo 0




 avi = avi + 1 'מוסיף בדיקה נוספת שבוצעה



 


    netCharsTyped = finalCharCount - g_InitialCharCount ' סך כל התווים שהוקלדו (נטו)
    totalTestDurationSeconds = DateDiff("s", g_TestStartTime, Now) ' משך הזמן הכולל של הבדיקה בשניות
    totalTestDurationSeconds = totalTestDurationSeconds - totalTestDurationSeconds1 'פחות הזמן של הבדיקה
    ' חישוב אותיות לשנייה
    If totalTestDurationSeconds > 0 And netCharsTyped > 0 Then
        lettersPerSecond = netCharsTyped / totalTestDurationSeconds
         lettersPerSecond1 = netCharsTyped / totalTestDurationSeconds
    Else
        lettersPerSecond = 0
    End If

    ' חישוב אותיות לדקה
    lettersPerMinute = lettersPerSecond * 60

    ' חישוב זמן להקלדת 1000 אותיות
    If lettersPerSecond > 0 Then
        timeFor1000Letters = 1000 / lettersPerMinute
    Else
        timeFor1000Letters = 0 ' אם אין קצב, לא ניתן לחשב
    End If
    
    'זמן כולל בדקות
   effectiveTypingM = totalTestDurationSeconds / 60
   
   'חישוב תווים כולל במסמך
   total_Char = g_TargetDocument.Characters.Count - 1


    ' עדכון הטקסט בחלון התצוגה
    MsgBox "                 סטטיסטיקה:" & vbCrLf & vbCrLf & _
                            "תווים בשנייה:                   " & Format(lettersPerSecond, "0.0") & vbCrLf & _
                            "תווים בדקה:                     " & Format(lettersPerMinute, "0.0") & vbCrLf & _
                            "ממוצע ל-1000 תווים:       " & Format(timeFor1000Letters, "0.0") & " דקות" & vbCrLf & vbCrLf & _
                            "תווים שהוקלדו נטו:          " & Format(netCharsTyped, "0") & vbCrLf & _
                            "סה''כ תווים במסמך:        " & Format(total_Char, "0") & vbCrLf & _
                            "זמן פעיל:                         " & Format(effectiveTypingM, "0.00") & " דקות" & vbCrLf & vbCrLf & _
                            "בדיקה מס':                      " & avi & vbCrLf & _
                            "                    בהצלחה!!!", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "מדידת מהירות הקלדה"
If stop_break = True Then 'אם הבדיקה הייתה בהשהיה לפני הצגת הנתונים
'אל תעשה כלום
Else 'אחרת
  routing = True 'תגדיר מצב ניתוב
start_test_Beta 'תפעיל את חידוש ההקלדה
 routing = False 'מסיים מצב ניתוב
 End If
End Sub

Spoiler

זה מאקרו שבעיקרון מוסיף תיבת טקסט עם הנתונים בסוף המסמך אבל לצערי הוא עושה השהיות לא מדוייקות ויש לו בעייה שאם לא נוצרה לפני זה תיבת טקסט במסמך אז זה לא מצליח

זה הקוד
אם מישהו ישפץ אותו אני אשמח

Sub print_all_Beta()


    Dim finalCharCount As Long
    Dim netCharsTyped As Long
    Dim totalTestDurationSeconds As Double
    Dim lettersPerSecond As Double
    Dim lettersPerMinute As Double
    Dim timeFor1000Letters As Double
    Dim previousLPS As Double
    Dim ImprovementText As String
    Dim reportRange As Word.Range
    Dim reportTable As Word.Table
    Dim tempVal As String ' משתנה עזר לקריאת נתונים שמורים
    Dim total_Char As Long
    Dim effectiveTypingM As Double
    Dim n As String
    Dim m As String
    Dim s As String
Application.ScreenUpdating = False 'מסתיר פעולות עד לסיום

If error_Shapes = False Then g_TestStartTime1 = Now   'לוקח את זמן התחלת הבדיקה




    ' בדיקה אם הבדיקה בכלל התחילה
    If Not g_TestIsActive Then
        n = MsgBox("לא מתקיימת כעת בדיקת הקלדה. האם להפעיל בדיקה חדשה?'.", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading + vbYesNo, "בדיקה לא פעילה")
        If n = vbYes Then StartTypingTest_Beta 'הפעלת בדיקה
        Exit Sub ' יציאה אם אין בדיקה פעילה
    End If
    
    ' בדיקה שהמסמך עדיין קיים וזמין
    On Error Resume Next
    If g_TargetDocument Is Nothing Then
        MsgBox "שגיאה: המסמך שעליו התבצעה הבדיקה נסגר או אינו זמין. לא ניתן להפיק דו""ח.", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"
        Exit Sub
    End If
    finalCharCount = g_TargetDocument.Characters.Count ' קריאת מספר התווים הסופי
    If Err.Number <> 0 Then
        MsgBox "שגיאה בגישה למסמך הנבדק בעת עצירת הבדיקה. לא ניתן להפיק דו""ח. " & Err.Description, vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0


Beep
m = MsgBox("הפונקצייה בפיתוח ובדיקת באגים" & vbCrLf & _
    "ייתכנו תקלות" & vbCrLf & vbCrLf & _
        "הפעלת הפונקצייה תיצור תיבת טקסט בסוף המסמך עם פרטי הבדיקה" & vbCrLf & vbCrLf & _
"כמו כן הפונקצייה מוחקת תיבות טקסט על תוכנם" & vbCrLf & vbCrLf & _
"שגיאה נוספת שידועה" & vbCrLf & "במקרה ולא נפתחה תיבת טקסט כלל במסמך" & vbCrLf & "ייתכן שתופיע שגיאה." & vbCrLf & "במקרה כזה יש ליצור תיבת טקסט פשוטה ולהפעיל את הפונקצייה מחדש" & vbCrLf & vbCrLf & _
"האם להפעיל את הפונקצייה?", vbYesNo + vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "שים לב")
    If m = vbNo Then Exit Sub
    ' --- חישובים סטטיסטיים ---
On Error GoTo Err





ll:
    netCharsTyped = finalCharCount - g_InitialCharCount ' סך כל התווים שהוקלדו (נטו)
    totalTestDurationSeconds = DateDiff("s", g_TestStartTime, Now) ' משך הזמן הכולל של הבדיקה בשניות
     totalTestDurationSeconds = totalTestDurationSeconds - totalTestDurationSeconds1 'פחות הזמן של הבדיקה
   
    ' חישוב אותיות לשנייה
    If totalTestDurationSeconds > 0 And netCharsTyped > 0 Then
        lettersPerSecond = netCharsTyped / totalTestDurationSeconds
    Else
        lettersPerSecond = 0
    End If

    ' חישוב אותיות לדקה
    lettersPerMinute = lettersPerSecond * 60

    ' חישוב זמן להקלדת 1000 אותיות
    If lettersPerSecond > 0 Then
        timeFor1000Letters = 1000 / lettersPerMinute
    Else
        timeFor1000Letters = 0 ' אם אין קצב, לא ניתן לחשב
    End If
    
    'זמן כולל בדקות
   effectiveTypingM = totalTestDurationSeconds / 60
   
   'חישוב תווים כולל במסמך
   total_Char = g_TargetDocument.Characters.Count - 1

ActiveDocument.Shapes.SelectAll
Selection.Delete

    Selection.MoveUp Unit:=wdScreen, Count:=24
    Selection.WholeStory
    Selection.MoveDown Unit:=wdScreen, Count:=1
    

    Application.Templates( _
        "C:\Users\יד-סופרים\AppData\Roaming\Microsoft\Document Building Blocks\1037\16\Built-In Building Blocks.dotx" _
        ).BuildingBlockEntries(" תיבת טקסט פשוטה").Insert Where:=Selection.Range, _
            RichText:=True
            If error_Shapes = True Then
            error_Shapes = False
            GoTo ll
            End If
            ActiveDocument.Shapes.Range(Array("תיבת טקסט 2")).Select

    Selection.TypeText Text:="סיכום מהירות הקלדה"
    Selection.TypeParagraph
     Selection.TypeText Text:="תווים בשנייה: " & Format(lettersPerSecond, "0.0")

   Selection.TypeParagraph
     Selection.TypeText Text:="תווים בדקה: " & Format(lettersPerMinute, "0.0")
Selection.TypeParagraph
     Selection.TypeText Text:="ממוצע ל-1000 תווים: " & Format(timeFor1000Letters, "0.0") & " דקות"
Selection.TypeParagraph
     Selection.TypeText Text:="תווים שהוקלדו נטו: " & Format(netCharsTyped, "0")
Selection.TypeParagraph
     Selection.TypeText Text:="סה''כ תווים במסמך: " & Format(total_Char, "0")
     Selection.TypeParagraph
     Selection.TypeText Text:="זמן פעיל: " & Format(effectiveTypingM, "0.00") & " דקות"
Selection.TypeParagraph
     Selection.TypeText Text:="כמות בדיקות: " & avi
     
                         totalTestDurationSeconds2 = DateDiff("s", g_TestStartTime1, Now) 'שמירת זמן הבדיקה הנוכחי
                        totalTestDurationSeconds1 = totalTestDurationSeconds1 + totalTestDurationSeconds2 'הוספה להיסטוריית הבדיקות
Exit Sub
Err:
If error_Shapes = True Then
MsgBox "השגיאה חזרה על עצמה" & vbCrLf & "יש לנסות שוב", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"

Else
      s = MsgBox("לא נפתחה תיבת טקסט במסמך" & vbCrLf & "יש לפתוח תיבת טקסט חדשה ולאחר מכן להפעיל את הפונקצייה שוב" & vbCrLf & vbCrLf & "האם להשהות את הבדיקה עד לסידור העניין?", vbYesNo + vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך")
If s = vbYes Then error_Shapes = True
End If
End Sub

וזה פונקציית העצירה וההמשך

  Sub stop_test_Beta()
   Dim n As String 'משתנה חלונית הודעה קופצת
   Dim finalCharCount As Long 'מספר התווים הסופי
       ' בדיקה אם הבדיקה בכלל התחילה
    If Not g_TestIsActive Then
        n = MsgBox("לא מתקיימת כעת בדיקת הקלדה. האם להפעיל בדיקה חדשה?'.", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading + vbYesNo, "בדיקה לא פעילה")
        If n = vbYes Then StartTypingTest_Beta 'הפעלת בדיקה
       exit_err = True 'מגדיר שנותב בגלל שגיאה
        Exit Sub ' יציאה אם אין בדיקה פעילה
    End If
    
    ' בדיקה שהמסמך עדיין קיים וזמין
    On Error Resume Next
    If g_TargetDocument Is Nothing Then
        MsgBox "שגיאה: המסמך שעליו התבצעה הבדיקה נסגר או אינו זמין. לא ניתן להפיק דו""ח.", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"
        Exit Sub
    End If
    finalCharCount = g_TargetDocument.Characters.Count ' קריאת מספר התווים הסופי
    If Err.Number <> 0 Then
        MsgBox "שגיאה בגישה למסמך הנבדק בעת עצירת הבדיקה. לא ניתן להפיק דו""ח. " & Err.Description, vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"
        Err.Clear
        Exit Sub
    End If
    If stop_break = True Then 'אם כבר פועלת בדיקה
   
    MsgBox "לא ניתן לעצור לפני חידוש הבדיקה", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "הבדיקה כבר נעצרה" 'מודיע שהיא פועלת
    Exit Sub 'ויוצא מהמאקרו
    End If
g_TestStartTime2 = Now 'לוקח את זמן תחילת הבדיקה
If routing = True Then Exit Sub 'אם מנותב ממאקרו אחר שיחזור לשם

MsgBox "הפעולה בוצעה בהצלחה" & vbCrLf & "אל תשכח להמשיך את הבדיקה", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "עצירת הקלדה" 'מודיע שהפעולה נעצרה

   stop_break = True 'מצב עצירת הבדיקה הופעל

   End Sub
   Sub start_test_Beta()
  Dim n As String 'משתנה הודעה קופצת
  Dim finalCharCount As Long 'מספר התווים במסמך
Dim effectiveTypingM1 As Double 'זמן העצירה
Dim min  As Integer, sec As Long
          ' בדיקה אם הבדיקה בכלל התחילה
    If Not g_TestIsActive Then
        n = MsgBox("לא מתקיימת כעת בדיקת הקלדה. האם להפעיל בדיקה חדשה?'.", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading + vbYesNo, "בדיקה לא פעילה") 'מודיע שלא הופעל ושואל אם להפעיל
        If n = vbYes Then StartTypingTest_Beta 'אם בחר להפעיל - הפעלת בדיקה
       exit_err = True 'מגדיר שהופעל בעקבות שגיאה
        Exit Sub ' יציאה אם אין בדיקה פעילה
    End If
    
    ' בדיקה שהמסמך עדיין קיים וזמין
    On Error Resume Next
    If g_TargetDocument Is Nothing Then
        MsgBox "שגיאה: המסמך שעליו התבצעה הבדיקה נסגר או אינו זמין. לא ניתן להפיק דו""ח.", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"
        Exit Sub
    End If
    finalCharCount = g_TargetDocument.Characters.Count ' קריאת מספר התווים הסופי
    If Err.Number <> 0 Then
        MsgBox "שגיאה בגישה למסמך הנבדק בעת עצירת הבדיקה. לא ניתן להפיק דו""ח. " & Err.Description, vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"
        Err.Clear
        Exit Sub
    End If
   If stop_break Or routing Then   'אם הבדיקה כבר נעצרה או שמנותב ממאקרו אחר
                    totalTestDurationSeconds3 = DateDiff("s", g_TestStartTime2, Now) 'שמירת זמן הבדיקה הנוכחי
                        totalTestDurationSeconds1 = totalTestDurationSeconds1 + totalTestDurationSeconds3 'הוספה להיסטוריית הבדיקות
If routing Then Exit Sub 'אם מנותב ממאקרו אחר שיחזור אליו
stop_break = False 'מבטל את מצב העצירה
'If totalTestDurationSeconds3 < 60 Then
'min = 0
'Else
Do Until totalTestDurationSeconds3 < 60 'משאיר שניות (ע"י הפעולת במהלך הלולאה) הוספת דקה למשתנה הדקות והסרת 60 שניות ממשתנה השניות ואם לא עברה דקה או שבמשתנה השניות נשאר פחות מדקה ממשיך הלאה
min = min + 1 'מוסיף דקה למשתנה הדקות
totalTestDurationSeconds3 = totalTestDurationSeconds3 - 60 'מוריד 60 שניות ממשתנה השניות
Loop
'End If
sec = totalTestDurationSeconds3 'משתנה השניות
MsgBox "זמן העצירה: " & min & "." & sec & " דקות" & vbCrLf & vbCrLf & "ניתן להמשיך להקליד" & vbCrLf & vbCrLf & "בהצלחה!", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "הבדיקה חודשה"  'מודיע שהבדיקה חודשה
Else 'אחרת
MsgBox "איך אתה רוצה להמשיך?", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, "הפעולה לא נעצרה" 'מודיע שהפעולה לא נעצרה
End If
   End Sub

שימו לב שחייבים את כל הקודים בשביל שזה יעבוד

הקוד המלא להעתקה בספויילר

Spoiler

Option Explicit ' מחייב הצהרה על כל המשתנים, למניעת טעויות

' --- משתנים גלובליים (משותפים לכל הפונקציות במודול זה) ---
' משתנים אלו שומרים את מצב הבדיקה והנתונים הנאספים

' משתנים הקשורים לבדיקה עצמה
Public g_TargetDocument As Word.Document ' המסמך בו מתבצעת הבדיקה
Public g_TestIsActive As Boolean         ' האם הבדיקה פעילה כעת? (אמת/שקר)
Public g_TestStartTime As Date           ' מועד התחלת הבדיקה
Public g_TestStartTime1 As Date           'מועד הפעלת פונקציית הבדיקה
Public g_InitialCharCount As Long        ' מספר התווים במסמך בתחילת הבדיקה
Public g_LastCharCount As Long           ' מספר התווים במסמך בבדיקה הקודמת (לחישוב שינויים)
Public avi As Long 'סופר כמה בדיקות הקלדה בוצעו
Public totalTestDurationSeconds1 As Double 'סך זמן פעולת פונקציית הבדיקה
  Public lettersPerSecond1 As Double
  Public totalTestDurationSeconds2 As String 'מד זמן פעולת פונקציית הבדיקה
  Public totalTestDurationSeconds3 As String 'מד זמן פעולת העצירה
Public aa As String 'בחירה בהודעה קופצת
Public error_Shapes As Boolean 'כרגע אין צורך בכלום בעצירה כשאין תיבת טקסט
Public g_TestStartTime2 As Double 'זמן עצירת הבדיקה
Public stop_break As Boolean 'האם בדיקת ההקלדה נעצרה
Public routing As Boolean 'האם הופנה ממאקרו אחר
Public exit_err As Boolean 'האם הייתה שגיאה והופעלה הבדיקה מההתחלה



' =========================================================================
' ===                    מאקרו להתחלת בדיקת ההקלדה                    ===
' =========================================================================

Public Sub StartTypingTest_Beta()
    ' נועד להפעלה על ידי המשתמש כדי להתחיל את סשן בדיקת ההקלדה


avi = 0 'מאפס כמות בדיקות
    ' בדיקה אם יש מסמך פתוח
    If Application.Documents.Count = 0 Then
        MsgBox "נא פתח או צור מסמך Word לפני התחלת הבדיקה.", vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאה"
        Exit Sub ' יציאה מהמאקרו אם אין מסמך פתוח
    End If

    ' בדיקה אם כבר מתקיימת בדיקה
    If g_TestIsActive Then
aa = MsgBox("בדיקת ההקלדה כבר פעילה." & vbCrLf & "האם להציג דו""ח?", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading + vbYesNo, "בדיקה פעילה")
       If aa = vbYes Then StopTypingTest_Beta
        Exit Sub ' יציאה אם הבדיקה כבר רצה
    End If

    ' איפוס וקביעת ערכים התחלתיים למשתנים הגלובליים
    Set g_TargetDocument = ActiveDocument   ' קביעת המסמך הנוכחי כמסמך היעד לבדיקה
    g_TestStartTime = Now                   ' שמירת זמן התחלת הבדיקה
    g_InitialCharCount = g_TargetDocument.Characters.Count ' שמירת מספר התווים ההתחלתי במסמך
    g_LastCharCount = g_InitialCharCount    ' הגדרת מספר התווים האחרון למספר ההתחלתי

    g_TestIsActive = True                   ' סימון שהבדיקה החלה ופעילה
    error_Shapes = False 'כרגע אין צורך בכלום בעצירה כשאין תיבת טקסט

    ' הודעה למשתמש שהבדיקה החלה
MsgBox "בדיקת הקלדה החלה בעזרת השם." & vbCrLf & vbCrLf & _
           "לחץ על הצגת נתונים, כדי לקבל דו""ח מפורט.", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "התחלת בדיקת הקלדה"

End Sub

' =========================================================================
' ===             מאקרו לעצירת בדיקת ההקלדה והצגת דו"ח               ===
' =========================================================================
Public Sub StopTypingTest_Beta()
    ' נועד להפעלה על ידי המשתמש כדי לסיים את סשן בדיקת ההקלדה ולהציג את הדו"ח

Dim n As String
    Dim finalCharCount As Long
    Dim netCharsTyped As Long
    Dim totalTestDurationSeconds As Double
    Dim lettersPerSecond As Double
    Dim lettersPerMinute As Double
    Dim timeFor1000Letters As Double
    Dim previousLPS As Double
    Dim ImprovementText As String
    Dim reportRange As Word.Range
    Dim reportTable As Word.Table
    Dim tempVal As String ' משתנה עזר לקריאת נתונים שמורים
    Dim total_Char As Long
    Dim effectiveTypingM As Double
exit_err = False 'מאפס את מצב השגיאה
If stop_break = True Then 'אם הבדיקה כבר בהשהייה שיציג ישר נתונים
Else 'אחרת
 routing = True 'מגדיר שמנותב למאקרו אחר
stop_test_Beta 'מעביר להשהיית הבדיקה
 routing = False 'מסיים את מצב הניתוב
 End If
 If exit_err = True Then Exit Sub 'אם הופעל פה התחלת הבדיקה שייצא מהמאקרו
'g_TestStartTime1 = Now 'לוקח את זמן התחלת הבדיקה




    finalCharCount = g_TargetDocument.Characters.Count ' קריאת מספר התווים הסופי
  

    On Error GoTo 0




 avi = avi + 1 'מוסיף בדיקה נוספת שבוצעה



 


    netCharsTyped = finalCharCount - g_InitialCharCount ' סך כל התווים שהוקלדו (נטו)
    totalTestDurationSeconds = DateDiff("s", g_TestStartTime, Now) ' משך הזמן הכולל של הבדיקה בשניות
    totalTestDurationSeconds = totalTestDurationSeconds - totalTestDurationSeconds1 'פחות הזמן של הבדיקה
    ' חישוב אותיות לשנייה
    If totalTestDurationSeconds > 0 And netCharsTyped > 0 Then
        lettersPerSecond = netCharsTyped / totalTestDurationSeconds
         lettersPerSecond1 = netCharsTyped / totalTestDurationSeconds
    Else
        lettersPerSecond = 0
    End If

    ' חישוב אותיות לדקה
    lettersPerMinute = lettersPerSecond * 60

    ' חישוב זמן להקלדת 1000 אותיות
    If lettersPerSecond > 0 Then
        timeFor1000Letters = 1000 / lettersPerMinute
    Else
        timeFor1000Letters = 0 ' אם אין קצב, לא ניתן לחשב
    End If
    
    'זמן כולל בדקות
   effectiveTypingM = totalTestDurationSeconds / 60
   
   'חישוב תווים כולל במסמך
   total_Char = g_TargetDocument.Characters.Count - 1


    ' עדכון הטקסט בחלון התצוגה
    MsgBox "                 סטטיסטיקה:" & vbCrLf & vbCrLf & _
                            "תווים בשנייה:                   " & Format(lettersPerSecond, "0.0") & vbCrLf & _
                            "תווים בדקה:                     " & Format(lettersPerMinute, "0.0") & vbCrLf & _
                            "ממוצע ל-1000 תווים:       " & Format(timeFor1000Letters, "0.0") & " דקות" & vbCrLf & vbCrLf & _
                            "תווים שהוקלדו נטו:          " & Format(netCharsTyped, "0") & vbCrLf & _
                            "סה''כ תווים במסמך:        " & Format(total_Char, "0") & vbCrLf & _
                            "זמן פעיל:                         " & Format(effectiveTypingM, "0.00") & " דקות" & vbCrLf & vbCrLf & _
                            "בדיקה מס':                      " & avi & vbCrLf & _
                            "                    בהצלחה!!!", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "מדידת מהירות הקלדה"
If stop_break = True Then 'אם הבדיקה הייתה בהשהיה לפני הצגת הנתונים
'אל תעשה כלום
Else 'אחרת
  routing = True 'תגדיר מצב ניתוב
start_test_Beta 'תפעיל את חידוש ההקלדה
 routing = False 'מסיים מצב ניתוב
 End If
End Sub

   
   Sub stop_test_Beta()
   Dim n As String 'משתנה חלונית הודעה קופצת
   Dim finalCharCount As Long 'מספר התווים הסופי
       ' בדיקה אם הבדיקה בכלל התחילה
    If Not g_TestIsActive Then
        n = MsgBox("לא מתקיימת כעת בדיקת הקלדה. האם להפעיל בדיקה חדשה?'.", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading + vbYesNo, "בדיקה לא פעילה")
        If n = vbYes Then StartTypingTest_Beta 'הפעלת בדיקה
       exit_err = True 'מגדיר שנותב בגלל שגיאה
        Exit Sub ' יציאה אם אין בדיקה פעילה
    End If
    
    ' בדיקה שהמסמך עדיין קיים וזמין
    On Error Resume Next
    If g_TargetDocument Is Nothing Then
        MsgBox "שגיאה: המסמך שעליו התבצעה הבדיקה נסגר או אינו זמין. לא ניתן להפיק דו""ח.", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"
        Exit Sub
    End If
    finalCharCount = g_TargetDocument.Characters.Count ' קריאת מספר התווים הסופי
    If Err.Number <> 0 Then
        MsgBox "שגיאה בגישה למסמך הנבדק בעת עצירת הבדיקה. לא ניתן להפיק דו""ח. " & Err.Description, vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"
        Err.Clear
        Exit Sub
    End If
    If stop_break = True Then 'אם כבר פועלת בדיקה
   
    MsgBox "לא ניתן לעצור לפני חידוש הבדיקה", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "הבדיקה כבר נעצרה" 'מודיע שהיא פועלת
    Exit Sub 'ויוצא מהמאקרו
    End If
g_TestStartTime2 = Now 'לוקח את זמן תחילת הבדיקה
If routing = True Then Exit Sub 'אם מנותב ממאקרו אחר שיחזור לשם

MsgBox "הפעולה בוצעה בהצלחה" & vbCrLf & "אל תשכח להמשיך את הבדיקה", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "עצירת הקלדה" 'מודיע שהפעולה נעצרה

   stop_break = True 'מצב עצירת הבדיקה הופעל

   End Sub
   Sub start_test_Beta()
  Dim n As String 'משתנה הודעה קופצת
  Dim finalCharCount As Long 'מספר התווים במסמך
Dim effectiveTypingM1 As Double 'זמן העצירה
Dim min  As Integer, sec As Long
          ' בדיקה אם הבדיקה בכלל התחילה
    If Not g_TestIsActive Then
        n = MsgBox("לא מתקיימת כעת בדיקת הקלדה. האם להפעיל בדיקה חדשה?'.", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading + vbYesNo, "בדיקה לא פעילה") 'מודיע שלא הופעל ושואל אם להפעיל
        If n = vbYes Then StartTypingTest_Beta 'אם בחר להפעיל - הפעלת בדיקה
       exit_err = True 'מגדיר שהופעל בעקבות שגיאה
        Exit Sub ' יציאה אם אין בדיקה פעילה
    End If
    
    ' בדיקה שהמסמך עדיין קיים וזמין
    On Error Resume Next
    If g_TargetDocument Is Nothing Then
        MsgBox "שגיאה: המסמך שעליו התבצעה הבדיקה נסגר או אינו זמין. לא ניתן להפיק דו""ח.", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"
        Exit Sub
    End If
    finalCharCount = g_TargetDocument.Characters.Count ' קריאת מספר התווים הסופי
    If Err.Number <> 0 Then
        MsgBox "שגיאה בגישה למסמך הנבדק בעת עצירת הבדיקה. לא ניתן להפיק דו""ח. " & Err.Description, vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "שגיאת מסמך"
        Err.Clear
        Exit Sub
    End If
   If stop_break Or routing Then   'אם הבדיקה כבר נעצרה או שמנותב ממאקרו אחר
                    totalTestDurationSeconds3 = DateDiff("s", g_TestStartTime2, Now) 'שמירת זמן הבדיקה הנוכחי
                        totalTestDurationSeconds1 = totalTestDurationSeconds1 + totalTestDurationSeconds3 'הוספה להיסטוריית הבדיקות
If routing Then Exit Sub 'אם מנותב ממאקרו אחר שיחזור אליו
stop_break = False 'מבטל את מצב העצירה
'If totalTestDurationSeconds3 < 60 Then
'min = 0
'Else
Do Until totalTestDurationSeconds3 < 60 'משאיר שניות (ע"י הפעולת במהלך הלולאה) הוספת דקה למשתנה הדקות והסרת 60 שניות ממשתנה השניות ואם לא עברה דקה או שבמשתנה השניות נשאר פחות מדקה ממשיך הלאה
min = min + 1 'מוסיף דקה למשתנה הדקות
totalTestDurationSeconds3 = totalTestDurationSeconds3 - 60 'מוריד 60 שניות ממשתנה השניות
Loop
'End If
sec = totalTestDurationSeconds3 'משתנה השניות
MsgBox "זמן העצירה: " & min & "." & sec & " דקות" & vbCrLf & vbCrLf & "ניתן להמשיך להקליד" & vbCrLf & vbCrLf & "בהצלחה!", vbInformation + vbMsgBoxRight + vbMsgBoxRtlReading, "הבדיקה חודשה"  'מודיע שהבדיקה חודשה
Else 'אחרת
MsgBox "איך אתה רוצה להמשיך?", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, "הפעולה לא נעצרה" 'מודיע שהפעולה לא נעצרה
End If
   End Sub

[מים אחרונים]

@יהודי-זה-הכי מכניסים הכל במאקרו אחד?
(המאקרו שימושי ביותר!)

[יהודי זה הכי]

@מים-אחרונים כן
אתה יכול גם ליצור את זה בכרטיסיה
מייד אכתוב על זה הדרכה