Mrrrr's Forum (VIEW ONLY)
Un forum care ofera solutii pentru unele probleme legate in general de PC. Pe langa solutii, aici puteti gasi si alte lucruri interesante // A forum that offers solutions to some PC related issues. Besides these, here you can find more interesting stuff.
|
Lista Forumurilor Pe Tematici
|
Mrrrr's Forum (VIEW ONLY) | Reguli | Inregistrare | Login
POZE MRRRR'S FORUM (VIEW ONLY)
Nu sunteti logat.
|
Nou pe simpatie:
Bby67 pe Simpatie.ro
 | Femeie
19 ani
Bucuresti
cauta Barbat
19 - 70 ani |
|
|
TRaP
Moderator
Inregistrat: acum 6 ani
Postari: 739
|
|
Source:
Batch convert DOC to DOCX
Sub ConvertDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = InputBox("Insert directory here")
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
'strFolder = "D:\Temp\" '##### USE THIS LINE IF YOU WANT TO DEFINE THE DIRECTORY IN VBA
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder &strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
.Close SaveChanges:=wdDoNotSaveChanges
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub
|
Batch convert DOCX to DOC
Sub ConvertDocxIntoDoc()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = InputBox("Insert directory here")
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
'strFolder = "D:\Temp\" '##### USE THIS LINE IF YOU WANT TO DEFINE THE DIRECTORY IN VBA
strFile = Dir(strFolder & "*.docx", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "docx", "doc"), FileFormat:=0
.Close SaveChanges:=wdDoNotSaveChanges
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub
|
Modificat de TRaP (acum 4 ani)
|
|
| pus acum 5 ani |
|
|
TRaP
Moderator
Inregistrat: acum 6 ani
Postari: 739
|
|
Batch convert DOCX and DOC to PDF
Sub BulkConvertDocxAndDocToPDF()
Dim oFileDlg As FileDialog
Dim strFolder As String
Dim strFileName As String
Dim oDoc As Document
Dim rsp As VbMsgBoxResult
' Tell user what's happening
rsp = MsgBox( _
Prompt:="Convert all documents in a folder to PDF format?" & _
vbCr & "If yes, select the folder in the next dialog.", _
Buttons:=vbYesNo + vbExclamation, _
Title:="Bulk Convert to PDF")
If rsp = vbYes Then
' Prepare and show folder picker dialog
Set oFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
With oFileDlg
.Title = "Bulk Convert to PDF"
.AllowMultiSelect = False
' Start in user's Documents folder
.InitialFileName = Application.Options.DefaultFilePath(wdDocumentsPath)
If .Show = -1 Then
' User clicked OK; get selected path
strFolder = .SelectedItems(1) & "\"
End If
End With
' Remove dialog object from memory
Set oFileDlg = Nothing
End If
If Not strFolder = "" Then
strFileName = Dir(pathname:=strFolder & "*.doc*")
WordBasic.DisableAutoMacros 1 'Disables auto macros
Application.ScreenUpdating = False
While strFileName <> ""
' Set an error handler
On Error Resume Next
' Attempt to open the document
Set oDoc = Documents.Open( _
FileName:=strFolder & strFileName, _
PasswordDocument:="?#nonsense@$")
' Check for error that indicates password protection
Select Case Err.Number
Case 0
' Document successfully opened
' Do nothing here
Case 5408
' Document is Password-protected and was NOT Opened
Debug.Print strFileName & " is password-protected " & _
"and was NOT processed."
' Clear Error Object and Disable Error Handler
Err.Clear
On Error GoTo 0
' Get Next Document
GoTo GetNextDoc
Case Else
' Another Error Occurred
MsgBox "Error " & Err.Number & vbCr & Err.Description
End Select
' Change extension from .docX* to .pdf
strFileName = Replace(strFileName, ".doc", ".pdf") 'Replace(LCase(strFileName), ".doc", ".pdf")
If Right(strFileName, 1) = "x" Or Right(strFileName, 1) = "m" Then
strFileName = Left(strFileName, Len(strFileName) - 1)
End If
' Save the file in PDF format
oDoc.SaveAs2 FileName:=strFolder & strFileName, FileFormat:=wdFormatPDF
' Close the document and clear the object
oDoc.Close SaveChanges:=wdDoNotSaveChanges
Set oDoc = Nothing
GetNextDoc:
' Get the next file name
strFileName = Dir()
Wend
End If
WordBasic.DisableAutoMacros 0 'Enables auto macros
Application.ScreenUpdating = True
End Sub
|
Modificat de TRaP (acum 4 ani)
|
|
| pus acum 5 ani |
|
|
TRaP
Moderator
Inregistrat: acum 6 ani
Postari: 739
|
|
Updated
The line
strFileName = Replace(strFileName, ".docx", ".pdf")
was
strFileName = Replace(LCase(strFileName), ".docx", ".pdf")
which was making the PDF files' names lowercase.
I removed LCase so they are named exactly as the Word files.
|
|
| pus acum 4 ani |
|
|
TRaP
Moderator
Inregistrat: acum 6 ani
Postari: 739
|
|
Updated
This line
.Close SaveChanges:=wdDoNotSaveChanges
was
.Close
which was prompting you to save the file.
I added SaveChanges:=wdDoNotSaveChanges so it doesn't ask you to save the doc/docx, but just closes it instead and moves to the next one.
|
|
| pus acum 4 ani |
|
Mrrrr
AdMiN
 Inregistrat: acum 17 ani
Postari: 2186
|
|
The code below will convert the current (active) document to docx and save in the document's folder, then close Word entirely and delete original file (the one that was not docx). Use carefully, you don't want to lose any data!
Sub Current_To_Docx()
Dim CurrentFolder As String
Dim FileName As String
Dim myPath As String
Dim DelPath As String
Dim FileExt As String
DelPath = ActiveDocument.FullName
myPath = ActiveDocument.FullName
CurrentFolder = ActiveDocument.Path & "\"
FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
Set fso = CreateObject("Scripting.FileSystemObject")
FileExt = fso.GetExtensionName(myPath)
Debug.Print FileExt
If FileExt = "docx" Then
MsgBox "File is already docx. Exiting..."
ActiveDocument.Close False
Application.Quit
Else
ActiveDocument.SaveAs2 FileName:=CurrentFolder & 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 False
Kill (DelPath)
End If
Application.Quit
End Sub
|
_______________________________________
|
|
| pus acum 2 ani |
|
Mrrrr
AdMiN
Inregistrat: acum 17 ani
Postari: 2186
|
|
Added the green colored text in the code above to correct an issue of the code and prevent deleting the file if it was already docx and you would click the run button by mistake.
Apparently it would permanently delete (!!!) the file if it was already docx. I would have expected at least an error or a delete to recycle bin, I mean WTF? No, apparently it's permanently deleted (seriously?). Took a couple of docx files to realize what was happening. :uimit:
More info:
In order to recycle instead of permanently delete with Kill, check:
_______________________________________
|
|
| pus acum 2 ani |
|
Mrrrr
AdMiN
Inregistrat: acum 17 ani
Postari: 2186
|
|
My last code from above worked fine roughly 2 years ago, but now I receive the following error on the Kill (DelPath) line:
Run-time error '70' Permission denied
I wasn't able to find a solution to this by searching on google and various forums / blogs with Word VBA answers. So I asked ChatGPT to help, and here is the last code which is very much similar to the last one above, but uses a powershell command to delete the .doc file:
Sub Current_To_Docx()
Dim CurrentFolder As String
Dim FileName As String
Dim myPath As String
Dim DelPath As String
Dim FileExt As String
Dim DelDoc As Document
Dim x As Variant
DelPath = ActiveDocument.FullName
Set DelDoc = ActiveDocument
myPath = ActiveDocument.FullName
CurrentFolder = ActiveDocument.Path & "\"
FileName = Mid(myPath, InStrRev(myPath, "\") + 1, _
InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
Set fso = CreateObject("Scripting.FileSystemObject")
FileExt = fso.GetExtensionName(myPath)
If FileExt = "docx" Then
MsgBox "File is already docx. Exiting..."
ActiveDocument.Close False
Application.Quit
Else
ActiveDocument.SaveAs2 FileName:=CurrentFolder & FileName & ".docx" _
, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
DelDoc.Close SaveChanges:=False
Set DelDoc = Nothing
Dim escapedPath As String
escapedPath = Replace(DelPath, "\", "\\") ' Replace backslashes with double backslashes
escapedPath = Replace(escapedPath, "'", "''") ' Replace single quotes with double single quotes
x = Shell("powershell.exe -ExecutionPolicy Bypass -command ""Stop-Process -Name WINWORD -Force; Remove-Item -LiteralPath '" & escapedPath & "' -Force""", 1)
End If
Application.Quit
End Sub[/color]
End Sub |
The lines in gold are ChatGPT's solution, thanks ChatGPT!
escapedPath is used to fix some issues with .doc names containing characters such as [ ] etc.
Source for the original just-kill Word with powershell command:
_______________________________________
|
|
| pus acum 7 luni |
|