שינוי בין הקלטת מאקרו לבין ביצועה

חוות דעת

@pcinfogmach אני חושב שהבנתי הבעיה. כי א"א לשים הקוד של שמירת הנתיב כמה פעמים באותו מאקרו. האם זה נכון? כי הוא מצביע לי תמיד על הפעם השני שזה מופיע. (כזכור, הקוד שלי אמור לייצר 4 מסמכים, במשך ההרצה)

pcinfogmach

@חוות-דעת
פשוט תשנה את השם של המשתנים עבור כל פעם

אם עדיין יש בעיות תעלה את הקוד ואנסה לראות מה הבעיה

חוות דעת

@pcinfogmach אני לא יודע מה פי' 'לשנות את המשתנים'.

חוץ מזה, פתאום, שוב, הקוד של @דאנציג הפסיק לעבוד, אני שוב מקבל את אותה שגיאה כמו שכתבתי למעלה.

ייש"כ על הסבלנות והעזרה!

אני מעתיק את הקוד, כמו שהוא עכשיו:

Sub פירוק_טקסטים_עם_סימונים_לעימוד_זמני()

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

' שומר עותק גיבוי למקרה של טעויות
'
Dim docpath As String
docpath = ActiveDocument.Path

    Selection.WholeStory
    Selection.Copy
    Documents.Add DocumentType:=wdNewBlankDocument
    Selection.PasteAndFormat (wdUseDestinationStylesRecovery)
    ActiveDocument.SaveAs2 FileName:="שמירת עותק גיבוי.docx", FileFormat:= _
        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False, CompatibilityMode:=15
    ActiveDocument.Save
    ActiveDocument.Close

'מכניס סימונים במקום הערות שוליים והערות סיום
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^f"
        .Replacement.Text = "*^&"
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^e"
        .Replacement.Text = "%^&"
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

'מייצא הערות שוליים
    ActiveWindow.View.SeekView = wdSeekFootnotes
    Selection.WholeStory
    Selection.Copy
'הקוד לא פעיל זמנית כדי לנסות לשמור המסמך בנתיב הקובץ המקורי
'Documents.Add DocumentType:=wdNewBlankDocument
    Dim newDoc As Document
    Set newDoc = Documents.Add
    Selection.PasteAndFormat (wdUseDestinationStylesRecovery)

'מכניס סימונים במקום מספור
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Superscript = True
        .Subscript = False
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = "*"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
'הקוד לא פעיל זמנית כדי לנסות לשמור המסמך בנתיב הקובץ המקורי
'    ActiveDocument.Save
'    ActiveDocument.SaveAs2 FileName:="הערות שוליים.rtf", FileFormat:= _
'        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
'        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
'        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
'        SaveAsAOCELetter:=False, CompatibilityMode:=15
'    ActiveWindow.Close
     newDoc.SaveAs2 docpath & "\" & "הערות שוליים.rtf"
     newDoc.Close

'מייצא הערות סיום
    ActiveWindow.View.SeekView = wdSeekEndnotes
    Selection.WholeStory
    Selection.Copy
'הקוד לא פעיל זמנית כדי לנסות לשמור המסמך בנתיב הקובץ המקורי
'   Documents.Add DocumentType:=wdNewBlankDocument
    Dim newDoc As Document
    Set newDoc = Documents.Add
    Selection.PasteAndFormat (wdUseDestinationStylesRecovery)

'מכניס סימונים במקום מספור
    Selection.Find.ClearFormatting
    With Selection.Find.Font
        .Superscript = True
        .Subscript = False
    End With
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = "%"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    newDoc.SaveAs2 docpath & "\" & "הערות סיום.rtf"
    newDoc.Close
'הקוד לא פעיל זמנית כדי לנסות לשמור המסמך בנתיב הקובץ המקורי
'    ActiveDocument.Save
'    ActiveDocument.SaveAs2 FileName:="הערות סיום.rtf", FileFormat:= _
'        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
'        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
'        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
'        SaveAsAOCELetter:=False, CompatibilityMode:=15
'    ActiveWindow.Close

'מוחק ההפניות של הערות שוליים וסיום שבתוך הטקסט הראשי
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=1, Name:=""
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^?"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
    End With
    With Selection.Find
        .Text = "^e"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^f"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

'מייצא הטקסט הראשי למסמך נפרד
    Selection.WholeStory
    Selection.Copy
'   Documents.Add DocumentType:=wdNewBlankDocument
    Dim newDoc As Document
    Set newDoc = Documents.Add
    Selection.PasteAndFormat (wdUseDestinationStylesRecovery)
    
    newDoc.SaveAs2 docpath & "\" & "טקסט ראשי.rtf"
    newDoc.Close

'    ActiveDocument.Save
'    ActiveDocument.SaveAs2 FileName:="טקסט ראשי.rtf", FileFormat:= _
'        wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
'        :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
'        :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
'        SaveAsAOCELetter:=False, CompatibilityMode:=15
'    ActiveWindow.Close
    ActiveDocument.Close SaveChanges:=False
End Sub

pcinfogmach

הנה גירסה שלי של הקוד למי שמעוניין

Option Explicit


Sub פירוק_טקסטים_עם_סימונים_לעימוד_זמני()

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

'בחר קובץ
Dim FileDialog As FileDialog
Dim mainDoc As Document
Dim docpath As String

    Set FileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With FileDialog
        .Title = "בחר קובץ"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Word Documents", "*.doc*"
      If .Show = -1 Then
        Set mainDoc = Documents.Open(.SelectedItems(1))
        docpath = mainDoc.Path
      Else
        MsgBox "לא בחרתם שום מסמך."
        Exit Sub
      End If
    End With
    
' שומר עותק גיבוי למקרה של טעויות
    mainDoc.Content.Copy
    
    Dim newDoc As Document
    Set newDoc = Documents.Add
    Selection.Paste
    
    newDoc.SaveAs2 docpath & "/" & mainDoc.Name & "-" & "עותק גיבוי.docx"
    newDoc.Close
    
    mainDoc.Activate
    
'בודק אם יש הערות שוליים במסמך
 If mainDoc.Footnotes.Count = 0 Then GoTo skp
 
'מכניס סימונים במקום הערות שוליים

    Selection.find.ClearFormatting
    Selection.find.Replacement.ClearFormatting
    With Selection.find
        .text = "^f"
        .Replacement.text = "*^&"
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = False
    End With
    Selection.find.Execute Replace:=wdReplaceAll
    
'מייצא הערות שוליים
     mainDoc.StoryRanges(wdFootnotesStory).Copy

    Dim newDoc1 As Document
    Set newDoc1 = Documents.Add
    Selection.PasteAndFormat (wdFormatPlainText)

'מכניס סימונים במקום מספור
    Selection.find.ClearFormatting
    With Selection.find.font
        .Superscript = True
        .Subscript = False
    End With
    Selection.find.Replacement.ClearFormatting
    With Selection.find
        .text = ""
        .Replacement.text = "*"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
    End With
    Selection.find.Execute Replace:=wdReplaceAll

    newDoc1.SaveAs2 docpath & "\" & mainDoc.Name & "-" & "הערות שוליים.rtf"
    newDoc1.Close
    
skp:

'בודק אם יש הערות סיום במסמך
    mainDoc.Activate
    If mainDoc.endnotes.Count = 0 Then GoTo skp2
  
' מכניס סימונים במקום הערות סיום
    
    Selection.find.ClearFormatting
    Selection.find.Replacement.ClearFormatting
    With Selection.find
        .text = "^e"
        .Replacement.text = "%^&"
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.find.Execute Replace:=wdReplaceAll
    
    
'מייצא הערות סיום
 mainDoc.StoryRanges(wdEndnotesStory).Copy
    Dim newDoc2 As Document
    Set newDoc2 = Documents.Add
    Selection.PasteAndFormat (wdFormatPlainText)

'מכניס סימונים במקום מספור
    Selection.find.ClearFormatting
    With Selection.find.font
        .Superscript = True
        .Subscript = False
    End With
    Selection.find.Replacement.ClearFormatting
    With Selection.find
        .text = ""
        .Replacement.text = "%"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
    End With
    Selection.find.Execute Replace:=wdReplaceAll

    newDoc2.SaveAs2 docpath & "\" & mainDoc.Name & "-" & "הערות סיום.rtf"
    newDoc2.Close
    
skp2:


'מוחק ההפניות של הערות שוליים וסיום שבתוך הטקסט הראשי
mainDoc.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1, Name:=""
    
    Selection.find.ClearFormatting
    With Selection.find
        .text = "^?"
        .Replacement.text = ""
        .Forward = True
        .Wrap = wdFindAsk
    End With
    
    With Selection.find
        .text = "^e"
        .Replacement.text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.find.Execute Replace:=wdReplaceAll
    
    Selection.find.ClearFormatting
    Selection.find.Replacement.ClearFormatting
    With Selection.find
        .text = "^f"
        .Replacement.text = ""
        .Forward = True
        .Wrap = wdFindContinue
    End With
    Selection.find.Execute Replace:=wdReplaceAll

'מייצא הטקסט הראשי למסמך נפרד
    Selection.WholeStory
    Selection.Copy
    
    Dim newDoc3 As Document
    Set newDoc3 = Documents.Add
    newDoc3.Content.Paste

    newDoc3.SaveAs2 docpath & "\" & mainDoc.Name & "-" & "טקסט ראשי.rtf"
    newDoc3.Close

    mainDoc.Close SaveChanges:=False
    
    Shell "explorer.exe " & docpath, vbNormalFocus
End Sub

חוות דעת

@pcinfogmach זה מה שקורה כאשר אני מפעיל את המאקרו: (אולי לא שמתי את זה במקום הנכון???)
שגיאת מאקרו חדש.jpg

pcinfogmach

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

חוות דעת

@pcinfogmach כתב בשינוי בין הקלטת מאקרו לבין ביצועה:

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

מה זה 'בחר קובץ' ששתלת בהתחלה??
איזה קובץ אני אמור לבחור שם, ומה מטרתו??

pcinfogmach

@חוות-דעת
בחר קובץ שברצונך לפרק
במקום לפרק את הקובץ הפתוח
בוחרים קובץ והמאקרו מפרק את הקובץ שבחרתם
אם ברצונך לפרק את הקובץ הפתוח פשוט תבחר אותו בתפריט זה

חוות דעת

@pcinfogmach כתב בשינוי בין הקלטת מאקרו לבין ביצועה:

@חוות-דעת
בחר קובץ שברצונך לפרק
במקום לפרק את הקובץ הפתוח
בוחרים קובץ והמאקרו מפרק את הקובץ שבחרתם
אם ברצונך לפרק את הקובץ הפתוח פשוט תבחר אותו בתפריט זה

אוקיי, אבל עדיין יש מניעות...
זה השגיאה שקבלתי, וכמובן המאקרו לא עשה כלום.
שגיאה מאקרו פירוק טקסטים.jpg

pcinfogmach

@חוות-דעת
בתוסף זה גם עושה בעיות?
האם בחרת קובץ אחד או שנים?

חוות דעת

@pcinfogmach כתב בשינוי בין הקלטת מאקרו לבין ביצועה:

@חוות-דעת
בתוסף זה גם עושה בעיות?
האם בחרת קובץ אחד או שנים?

לא הבנתי. יש שם את הפקודה של פירוק טקסט??
בחרתי כמובן קובץ אחד (אבל אם אתה שואל אני ינסה שוב).

נ.ב. אגב, מדוע אתה לא משלב כוחות בינך לבין @האדם-החושב? מדוע כל אחד עושה תוסף אחר לוורד??

חוות דעת

@pcinfogmach אוקיי, עיינתי בתוסף שם, ונסיתי, והפלא ופלא!! עובד מצויין!!!

אין מילים!!

רק... עדיין יש שם שני דברים שצריך תיקון:
א. בקבצי ההערות המיוצאים לא מופיעים הסימונים שאמורים לקשר בינן לבין הטקסט הראשי.
ב. כל העיצוב נמחק. זה אמור להישאר כמו בקובץ הטקסט הראשי, עם העיצוב.

ושוב, תודה רבה על העזרה והמסירות!

pcinfogmach

@חוות-דעת כתב בשינוי בין הקלטת מאקרו לבין ביצועה:

א. בקבצי ההערות המיוצאים לא מופיעים הסימונים שאמורים לקשר בינן לבין הטקסט הראשי.

איזה סימונים אמורים להיות?

@חוות-דעת כתב בשינוי בין הקלטת מאקרו לבין ביצועה:

ב. כל העיצוב נמחק. זה אמור להישאר כמו בקובץ הטקסט הראשי, עם העיצוב.

למה צריך את העיצוב? חשבתי שזה לצורך עימוד אז אמרתי לעצמי שעדיף להסיר את העיצוב? לא?

@חוות-דעת כתב בשינוי בין הקלטת מאקרו לבין ביצועה:

ושוב, תודה רבה על העזרה והמסירות!

תודה

אגב אם תרצה תוכל להעתיק את הקוד מתוך התוסף מהגרסה של הקוד פתוח אולי ככה יעבוד יותר טוב (למרות שהקוד כאן כמעט זהה למה שיש שם).

חוות דעת

@pcinfogmach כתב בשינוי בין הקלטת מאקרו לבין ביצועה:

@חוות-דעת כתב בשינוי בין הקלטת מאקרו לבין ביצועה:

א. בקבצי ההערות המיוצאים לא מופיעים הסימונים שאמורים לקשר בינן לבין הטקסט הראשי.

איזה סימונים אמורים להיות?

הסימונים שניתוספו בטקסט ראשי (*להערות שוליים ו-%להערות סימון) שזהו כל המקומות ששם אמורים להתקשר ההערות. אז אותו סימן שיש בטקסט ראשי, צריך בטקסט ההערות המיוצאות.

@חוות-דעת כתב בשינוי בין הקלטת מאקרו לבין ביצועה:

ב. כל העיצוב נמחק. זה אמור להישאר כמו בקובץ הטקסט הראשי, עם העיצוב.

למה צריך את העיצוב? חשבתי שזה לצורך עימוד אז אמרתי לעצמי שעדיף להסיר את העיצוב? לא?

אני צריך את זה כי אני לא מכניס קודים לטקסט לפני שאני מייבא לאינדיזיין, אז אני צריך לדעת איזה מילה מודגשת וכדו'.

חוות דעת

@pcinfogmach ואולי בכלל כדאי להוסיף אפשרות לבחור האם להעתיק ללא עיצוב או עם עיצוב.

pcinfogmach

גירסה חדשה
תבנית עם מאקרו לפירוק טקסטים.dotm