Want to "batch" translate many word documents.
Tried to batch convert to docx and need to add translation.
Please see the code I am using below.
I don't know how to invoke the translation on the ActiveDocument.
'''VBA
Sub ConvertDocToDocx()
'Updated by ExtendOffice 20181128
Dim xDlg As FileDialog
Dim xFolder As Variant
Dim xFileName As String
Application.ScreenUpdating = False
Set xDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xDlg.Show <> -1 Then Exit Sub
xFolder = xDlg.SelectedItems(1) + "\"
xFileName = Dir(xFolder & "*.doc", vbNormal)
While xFileName <> ""
Documents.Open FileName:=xFolder & xFileName, _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto, XMLTransform:=""
'pseudo code ActiveDocument.MStranslateFromTo('EN','DA')
ActiveDocument.SaveAs xFolder & Replace(xFileName, "doc", "docx"), wdFormatDocumentDefault
ActiveDocument.Close
xFileName = Dir()
Wend
Application.ScreenUpdating = True
End Sub
'''
(code found here: https://www.extendoffice.com/documents/word/5601-word-batch-convert-doc-to-docx.html#a1 )
Not an answer
This could be done, but the record macro do not produce the result wanted. When running this the only code made is the part where I select the code, the part where I press translate etc. is not recorded - this looks like this:
Sub Makro1()
'
' Makro1 Makro
'
'
Selection.WholeStory
End Sub
```
Related
I have a macro that converts (exports) word documents inside a folder into PDF. The macro works, but WORD keeps on popping up the save dialog, which kills the idea of a batch operation. The command
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
that helped me on other ocasions, does not work for some reason. Any suggestion is welcomed.
Martin
Sub Loop_through_files()
Dim cDocuments As New Collection
Dim sPath As String, sFilter As String
Dim sCurrentDocName As String, sFullname As String
Dim i As Long
Dim xNewName As String
Dim xIndex As Integer
sPath = "C:\Users\xxxxxx\Desktop\ConvertPDF"
sFilter = "*.DOC*"
Set cDocuments = Nothing
sCurrentDocName = Dir(sPath & "\" & sFilter)
Do Until sCurrentDocName = ""
cDocuments.Add Item:=sCurrentDocName
sCurrentDocName = Dir
Loop
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = cDocuments.Count To 1 Step -1 '
sFullname = sPath & "\" & cDocuments(i)
xIndex = InStr(cDocuments(i), ".")
xNewName = Left(cDocuments(i), xIndex) + "pdf"
Documents.Open FileName:=sFullname, _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto, XMLTransform:=""
ActiveDocument.ExportAsFixedFormat OutputFileName:=sPath & "\" & xNewName, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
ActiveWindow.Close
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
In the Close method calls you need to specify the OriginalFormat parameter which is represented by the WdOriginalFormat enumeration:
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges, OriginalFormat:=wdOriginalDocumentFormat
I'm trying to solve a situation where I have a range of text that can vary considerably depending on the results returned by an array formula. Sometimes there may be 5 rows of data, other times there may be 2000.
I think I've found the chunks of individual VBA codes required for each stage of the task I want to complete, but I am a complete novice with VBA and I have no idea how to piece these together.
The following selects all the actual data on the page, and excludes any rows that contain a hidden formula:
Sub PickedActualUsedRange()
Range("A1").Resize(Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column).Select
End Sub
So far so good. This is the exact range I want to print.
I also want the row height to be adjusted automatically, as each cell may contain a string of text of varying lengths that may be wrapped. So again the following command needs to go in:
Selection.Rows.AutoFit
Not too much trouble so far.
However, for the next bit I would like the VBA to use the selection made above, and to set this as the new print range. However, the code I have found seems to require me to set an absolute range (as per below), whereas I need this to adjust in accordance to the first selection
Selection.PageSetup.PrintArea = "$A$1:$B$12"
Once this is in place, the next step I would like to incorporate is this code I found via from the contextures website for printing the current worksheet:
Sub PDFActiveSheet()
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Is anybody able to help me incorporate all of the above in to a single string of code please?
FURTHER EDIT
Still not sure what I'm doing with different chunks of code. What would be the exact text I would need to enter in Module1? I don't understand how to structure it:
'Function to give the actual data range from a given worksheet
Function PickedActualUsedRange(ws As Worksheet) As Range
Set PickedActualUsedRange = ws.Range("A1").Resize(Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
End Function
Sub PDFSheet(wsA As Worksheet) '<-- the sheet in question will be given as parameter
' Drop or change the following lines...
' Dim wsA As Worksheet '<-- drop
' Dim wbA As Workbook '<-- drop
...
strPath = wsA.Parent.Path ' <-- change
...
End Sub
Sub mySyb()
Sub PDFActiveSheet()
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
End Sub
Sub mySyb()
Dim ws As Worksheet: Set ws = Worksheets("report")
Dim r As Range: Set r = PickedActualUsedRange(ws)
r.Rows.AutoFit
ws.PageSetup.PrintArea = r.Address
PDFSheet (ws)
End Sub
To fit it the easiest way with your current code, here's how you would setup the print area:
ActiveSheet.PageSetup.PrintArea = Selection.address
And you can call your routines in order
PickedActualUsedRange
Selection.Rows.AutoFit
ActiveSheet.PageSetup.PrintArea = Selection.address
PDFActiveSheet
On a final note, your code uses unqualified ranges and counts a lot on Select, Selection, ActivateSheet etc... which is usually considered bad practice (code will be difficult to maintain). You'd better change it to get rid of these and use explicit sheet names and qualified ranges.
EDIT
' Function to give the actual data range from a given worksheet
Function PickedActualUsedRange(ws as Worksheet) as Range
Set PickedActualUsedRange = ws.Range("A1").Resize(ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
End Function
Sub PDFSheet(wsA As Worksheet)
'www.contextures.com
'for Excel 2010 and later
Dim strTime As String, strName As String, strPath As String, strFile As String, strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wsA.Parent.Path & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
myFile = Application.GetSaveAsFilename _
(InitialFileName:=strPathFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message with file info
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Sub myMacro
Dim ws as worksheet: Set ws = Worksheets("report")
Dim r as range: Set r = PickedActualUsedRange(ws)
r.Rows.AutoFit
ws.PageSetup.PrintArea = r.address
PDFSheet ws
End Sub
Put all this in a code module (i.e. Module1) and call the myMacro through ALT
+ F8
I have code that selects an array of sheets to be printed to a pdf document, however I am trying to implement a user form with a series of check boxes that correspond to a specific sheets.
The following code selects a predetermined array of sheets and prints them as a pdf
Sub PDFAllSheets_Click()
Dim ws As Worksheet
Dim strPath As String
Dim myfile As Variant
Dim strFile As String
Dim sheetstoprint As String
On Error GoTo errHandler
Set ws = ActiveSheet
strFile = "E_CALC_" & Worksheets("Contents").Range("H7").Text & ".pdf"
strFile = ThisWorkbook.Path & "\" & strFile
myfile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
title:="Select Folder and FileName to save")
If myfile <> "False" Then
ThisWorkbook.Sheets(Array("Engine", "CHP Layout", "Ventilation", "Exhaust", "Gas", "Hazardous Zoning", "Gas Ramp up", "Steam Boilers", _
"JW PU", "AC PU", "Combustion", "BREEAM NOx", "Pump P1", "Pump P2", "Pump P3", "Pump P4", "Pump P5")).Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=myfile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
MsgBox "PDF file has been created."
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file", vbRetryCancel, "Oops!"
Resume exitHandler
End Sub
I need the following UserForm's check boxes to define the sheets to include in the array.
UserForm1
If you have a UserForm with a ListBox and a CommandButton, this should work, assuming you have sheets named as you specified.
This code should of course be added to the UserForm code module.
Private Sub CommandButton1_Click()
Dim SheetArray() As Variant
Dim indx As Integer
Dim ws As Worksheet
Dim strPath As String
Dim myfile As Variant
Dim strFile As String
Dim sheetstoprint As String
On Error GoTo errHandler
Set ws = ActiveSheet
strFile = "E_CALC_" & Worksheets("Contents").Range("H7").Text & ".pdf"
strFile = ThisWorkbook.Path & "\" & strFile
myfile = Application.GetSaveAsFilename _
(InitialFileName:=strFile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
If myfile <> "False" Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
indx = 0
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
ReDim Preserve SheetArray(indx)
SheetArray(indx) = Sheets(ListBox1.List(i, 1)).Index
indx = indx + 1
End If
Next i
If indx > 0 Then
Sheets(SheetArray()).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=myfile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
'.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
End If
End If
exitHandler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
errHandler:
MsgBox "Could not create PDF file", vbRetryCancel, "Oops!"
Resume exitHandler
End Sub
Private Sub UserForm_Initialize()
Dim wks() As Variant
wks = Array("Engine", "CHP Layout", "Ventilation", "Exhaust", "Gas", "Hazardous Zoning", "Gas Ramp up", "Steam Boilers", _
"JW PU", "AC PU", "Combustion", "BREEAM NOx", "Pump P1", "Pump P2", "Pump P3", "Pump P4", "Pump P5")
'Debug.Print wks(16)
For i = 0 To UBound(wks)
ListBox1.AddItem wks(i)
ListBox1.List(ListBox1.ListCount - 1, 1) = wks(i)
Next i
End Sub
Remember to allow listbox multiselect in the listbox properties window.
Edit:
During my testing, it seems that the Excel application freezes after exporting the PDF. I don't know if it has anything to do with the OpenAfterPublish property being set to True as I've always set it to False.
Edit2:
My mistake, It's simply because the UserForm is still open ...
I have the following code:
Sub WordtoTxtwLB()
'
' WordtoTxtwLB Macro
'
'
Dim fileName As String
myFileName = ActiveDocument.Name
ActiveDocument.SaveAs2 fileName:= _
"\\FILE\" & myFileName & ".txt", FileFormat:= _
wdFormatText, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, Encoding:=1252, InsertLineBreaks:=True, AllowSubstitutions:=False, _
LineEnding:=wdCRLF, CompatibilityMode:=0
End Sub
I want to loop this sub through all of the word (.doc) files in a directory. I have the following code:
Sub LoopDirectory()
vDirectory = "C:\programs2\test"
vFile = Dir(vDirectory & "\" & "*.*")
Do While vFile <> ""
Documents.Open fileName:=vDirectory & "\" & vFile
ActiveDocument.WordtoTxtwLB
vFile = Dir
Loop
End Sub
But it is not working. How do I get this to work either by altering the current code or using new code?
You don't actually need the WordtoTxtwLB Macro. You can combine both the codes. see this example
Sub LoopDirectory()
Dim vDirectory As String
Dim oDoc As Document
vDirectory = "C:\programs2\test\"
vFile = Dir(vDirectory & "*.*")
Do While vFile <> ""
Set oDoc = Documents.Open(fileName:=vDirectory & vFile)
ActiveDocument.SaveAs2 fileName:="\\FILE\" & oDoc.Name & ".txt", _
FileFormat:=wdFormatText, _
LockComments:=False, _
Password:="", _
AddToRecentFiles:=True, _
WritePassword:="", _
ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, _
SaveFormsData:=False, _
SaveAsAOCELetter:=False, _
Encoding:=1252, _
InsertLineBreaks:=True, _
AllowSubstitutions:=False, _
LineEnding:=wdCRLF, _
CompatibilityMode:=0
oDoc.Close SaveChanges:=False
vFile = Dir
Loop
End Sub
BTW, are you sure you want to use the *.* wildcard? What if there are Autocad files in the folder? Also ActiveDocument.Name will give you the file name with the Extension.
To edit all the word documents in a directory I built this simple subroutine.
The subRoutine loops through the directory and
opens each *.doc file it finds. Then on the open document file it calls
the second subRoutine. After the second subRoutine is finished the document
is saved and then closed.
Sub DoVBRoutineNow()
Dim file
Dim path As String
path = "C:\Documents and Settings\userName\My Documents\myWorkFolder\"
file = Dir(path & "*.doc")
Do While file <> ""
Documents.Open FileName:=path & file
Call secondSubRoutine
ActiveDocument.Save
ActiveDocument.Close
file = Dir()
Loop
End Sub
~~~~~~
Here's my solution. I think it's easy to understand and straight forward for newbies like me that I will post my code here. Because I searched around and the codes I saw were kind of complicated. Let's go.
Sub loopDocxs()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim mySource As Object
Set obj = CreateObject("Scripting.FileSystemObject")
Set mySource = obj.GetFolder("D:\docxs\")
For Each file In mySource.Files 'loop through the directory
If Len(file.Name) > 0 And InStr(1, file.Name, "$") = 0 Then '$ is temp file mask
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
'Word.Application doesn't recognize file here event if it's a word file.
'fortunately we have the file name which we can use.
Set wDoc = wApp.Documents.Open(mySource & "\" & file.Name, , ReadOnly)
'Do your things here which will be a lot of code
wApp.Quit
Set wApp = Nothing
End If
Next file
In the code below the file name is hard coded, but I want the user to be able to pick it.
I was reading about GetSaveAsFilename but I get an error when using it: "method or member not found".
fileSaveName = Application.GetSaveAsFilename _
(fileFilter:="Excel Files (*.txt), *.txt")
This is written for Word 2010. Am I wrong in thinking GetSaveAsFilename is available in word VBA?
Sub Macro3()
'
' Macro3 Macro
'
'
ActiveDocument.SaveAs2 FileName:="Questionnaire01-05-20122.txt", _
FileFormat:=wdFormatText, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=True, SaveAsAOCELetter:=False, Encoding:=1252, InsertLineBreaks:=False, _
AllowSubstitutions:=False, LineEnding:=wdCRLF, CompatibilityMode:=0
End Sub
I didn't realize that Word doesn't have GetSaveAsFileName or GetOpenFileName methods (which Excel has). But it doesn't. Instead you can try the SaveAs FileDialog (2003, 2007, 2010):
Sub ShowSaveAsDialog()
Dim dlgSaveAs As FileDialog
Set dlgSaveAs = Application.FileDialog(FileDialogType:=msoFileDialogSaveAs)
dlgSaveAs.Show
End Sub
You can provide a default path including filename like so to the dialog, ie
Sub SaveName()
Dim strFileName As String
Dim StrPath As String
'provide default filename
StrPath = "c:\temp\test.docx"
With Dialogs(wdDialogFileSaveAs)
.Name = StrPath
If .Display <> 0 Then
strFileName = .Name
Else
strFileName = "User Cancelled"
End If
End With
MsgBox strFileName
End Sub
Dim strFilePath, strFileName
strFilePath = "C:\Users\Public\Documents\"
strFileName = "put-filename-here.docx"
With Dialogs(wdDialogFileSaveAs)
.Name = strFilePath & strFileName
.Show
End With