שיתוף | ממיר קבצי וורד בסיומת DOC לסיומת DOCX עבור אוצריא

[סוקולובר]

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

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

[שליו]

@סוקולובר
מפנה אותך לשרשור הזה