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

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

הפרופיל קיים בכתובת זו
"C:\Users\USER\AppData\Local\Google"
שים לב שUSER זה לפי שם המשתמש שלך
ניסיתי והצלחתי להעתיק פרופיל אבל זה בקש כניסה חוזרת לחשבון הגוגל הקבוע בשביל סנכרון וכדו'
כנראה שהוא מזהה מעבר למשתמש אחר
או שהסיסמאות מאוחסנות במקום אחר

@א.מ. תודה רבה זה מה שרציתי אך אני העדפתי שיהיה תוכנה למחשב ולא רק אפליקציה אבל אולי אין ברירה רק באימולטור

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

Private Sub SearchReplaceAllDocuments()
    Dim FileDialog As FileDialog
    Dim FilePaths As Variant
    Dim fileName As Variant
    Dim doc As Document, counter As Long
    Dim FirstLoop As Boolean
    FirstLoop = True
    Application.ScreenUpdating = False
    ' Open the file picker dialog
    Set FileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With FileDialog
        .Title = "בחר קבצים (חיפוש בקבצים מרובים לפי בחירת קבצים)"
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Word Documents", "*.doc"
        If .Show = -1 Then
'            FilePaths = .SelectedItems
           
    ' Initialize counter
    counter = 0
    
    ' Loop through each selected file
    For Each fileName In .SelectedItems
        ' Open the document
        Set doc = Documents.Open(fileName:=fileName)
        
Dim A, b As String
A = ActiveDocument.Name
b = ActiveDocument.Path & "\" & A
If Not InStr(A, "docx") > 0 Then
A = Replace(A, "doc", "docx")
    ActiveDocument.SaveAs2 fileName:=b & "x", FileFormat:= _
        wdFormatXMLDocument
       
        End If

        ' Save and close the document
        doc.Close SaveChanges:=True
         Kill (b)
        ' Increment counter
        counter = counter + 1
    Next fileName
    
    ' Enable screen updating
    Application.ScreenUpdating = True
    
    ' Display results
     
      MsgBox "פעולת ההחלפה הסתיימה." & vbCrLf & vbCrLf & _
        "מספר המסמכים שבוצעה בהם החלפה הם: " & counter, vbMsgBoxRight, "Operation Result"
        
        End If
    End With
    
End Sub

Private Sub SearchReplaceAllDocumentsInFolder()
    Dim folderPath, fileName, DocumentPath As String, _
    doc As Document, counter As Long, FirstLoop As Boolean, respnse As VbMsgBoxResult
    Application.ScreenUpdating = False
         On Error Resume Next
 
    ' Select the folder containing the documents
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "בחר תיקייה (חיפוש בקבצים מרובים לפי תיקיות)"
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    respnse = MsgBox("האם ברצונך לחפש גם בתת תיקיות?", vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading)

'     Initialize counters
    counter = 0
    
    ' Loop through each file in the folder
    fileName = Dir(folderPath & "*.doc")
    Do While fileName <> ""
        ' Construct the full path of the document
        DocumentPath = folderPath & fileName
        
        ' Open the document
     
        
 fileName = DocumentPath
                    If InStr(fileName, "doc") > 0 And Len(fileName) - InStrRev(fileName, ".doc") = 3 Then
                     Set doc = Documents.Open(fileName)

A = ActiveDocument.Name
b = ActiveDocument.Path & "\" & A


    ActiveDocument.SaveAs2 fileName:=b & "x", FileFormat:= _
        wdFormatXMLDocument
       
       

        ' Save and close the document
        doc.Close SaveChanges:=True
         Kill (b)
         If Err.Number = 70 Then
         FileErr = FileErr & Chr(13) & b
         Err.Number = 0
         End If
        counter = counter + 1
        End If
        ' Move to the next file
        fileName = Dir
    Loop
            
nd:


'subfolders
If respnse = vbYes Then

    Dim FSO As Object, fld As Object, Fil As Object
    Dim fsoFile As Object
    Dim fsoFol As Object
    
'    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(folderPath)
    If FSO.folderExists(fld) Then
    
    
        For Each fsoFol In FSO.GetFolder(folderPath).subfolders
            For Each fsoFile In fsoFol.Files
                    fileName = fsoFile.Path
                    If InStr(fileName, ".doc") > 0 And Len(fileName) - InStrRev(fileName, ".doc") = 3 Then
                     Set doc = Documents.Open(fileName)

A = ActiveDocument.Name
b = ActiveDocument.Path & "\" & A


    ActiveDocument.SaveAs2 fileName:=b & "x", FileFormat:= _
        wdFormatXMLDocument
       
       

        ' Save and close the document
        doc.Close SaveChanges:=True
         Kill (b)
         If Err.Number = 70 Then
         FileErr = FileErr & Chr(13) & b
         Err.Number = 0
         End If
        counter = counter + 1
                     End If
            Next
               folderPathA = fsoFol & "\"
       Set fldA = FSO.GetFolder(folderPathA)
    If FSO.folderExists(fldA) Then
    
 
        For Each fsoFolA In FSO.GetFolder(folderPathA).subfolders
            For Each fsoFileA In fsoFolA.Files
                    fileName = fsoFileA.Path
                    If InStr(fileName, ".doc") > 0 And Len(fileName) - InStrRev(fileName, ".doc") = 3 Then
                     Set doc = Documents.Open(fileName)

A = ActiveDocument.Name
b = ActiveDocument.Path & "\" & A


    ActiveDocument.SaveAs2 fileName:=b & "x", FileFormat:= _
        wdFormatXMLDocument
       
       

        ' Save and close the document
        doc.Close SaveChanges:=True
         Kill (b)
         If Err.Number = 70 Then
         FileErr = FileErr & Chr(13) & b
         Err.Number = 0
         End If
        counter = counter + 1
                     End If
            Next
            folderPathB = fsoFolA & "\"
          Set fldB = FSO.GetFolder(folderPathB)
    If FSO.folderExists(fldB) Then
    
 
        For Each fsoFolB In FSO.GetFolder(folderPathB).subfolders
            For Each fsoFileB In fsoFolB.Files
                    fileName = fsoFileB.Path
                    If InStr(fileName, ".doc") > 0 And Len(fileName) - InStrRev(fileName, ".doc") = 3 Then
                     Set doc = Documents.Open(fileName)

A = ActiveDocument.Name
b = ActiveDocument.Path & "\" & A


    ActiveDocument.SaveAs2 fileName:=b & "x", FileFormat:= _
        wdFormatXMLDocument
       
       

        ' Save and close the document
        doc.Close SaveChanges:=True
         Kill (b)
         If Err.Number = 70 Then
         FileErr = FileErr & Chr(13) & b
         Err.Number = 0
         End If
        counter = counter + 1
                     End If
            Next
        Next
 End If
        Next
 End If
        Next
    End If
    End If
    
    ' Enable screen updating
    Application.ScreenUpdating = True
    
    ' Display results
    If Len(FileErr) > 2 Then FileErr = vbNewLine & "שגיאה במחיקת הקבצים" & FileErr
      MsgBox "פעולת ההחלפה הסתיימה." & vbCrLf & vbCrLf & _
        "מספר המסמכים שבוצעה בהם החלפה הם: " & counter & FileErr, vbMsgBoxRight + vbMsgBoxRtlReading, "Operation Result"

End Sub

עם אשף מיזוג דואר זה היה ממש קלי קלות לעשות את זה ויצאו מדבקות מעולות

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

הורדתי קובץ פתחתי ואפשרתי עריכה
אח"כ אשרתי עריכה בצד שמאל למעלה
הצגה- אפשר עריכה

אח"כ הפכתי לשפה עברית ושיניתי כיוון כתב מימין לשמאל
והוספתי עוד טור לטבלה מימין בעמידה על טור שמאלי (כנראה שזה הפטנט שלי)

אח"כ התחל מיזוג דואר - תויות

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