Simple code to loop paste .emf files into word:
Sub LoopEMF()
Dim sPic As String
Dim sPath As String
sPath = "C:\Users\me\Desktop\Test2\"
sPic = Dir(sPath & "*.emf")
Do While sPic <> ""
Selection.TypeParagraph
Selection.InlineShapes.AddPicture _
FileName:=sPath & sPic, _
LinkToFile:=False, SaveWithDocument:=True
sPic = Dir
Selection.TypeParagraph
Loop
End Sub
Rather than a specified directory, I simply want to look in the active directory in which the word file (that is open) is located. Much searching has yielded no clue - which is surprising, embarrassing and probably means I'm not using the right key words.
Help?
When I open an Excel document D:\db\tmp\test1.xlsm:
CurDir() returns C:\Users\[username]\Documents
ActiveWorkbook.Path returns D:\db\tmp
So CurDir() has a system default and can be changed.
ActiveWorkbook.Path does not change for the same saved Workbook.
For example, CurDir() changes when you do "File/Save As" command, and select a random directory in the File/Directory selection dialog. Then click on Cancel to skip saving. But CurDir() has already changed to the last selected directory.
From:
How to get current working directory using vba?
Even more embarrassing - I had been using the correct code:
Sub NewLoopEMF()
Dim sPic As String
Dim sPath As String
sPath = ActiveDocument.path & "\"
sPic = Dir(sPath & "*.emf")
Do While sPic <> ""
Selection.TypeParagraph
Selection.InlineShapes.AddPicture _
FileName:=sPath & sPic, _
LinkToFile:=False, SaveWithDocument:=True
sPic = Dir
Selection.TypeParagraph
Loop
End Sub
Unfortunately, the active directory is in a synced SharePoint folder, so the returned name is in hypertext (http://all the rest/) and with this, all you know what breaks loose. I figured this out by using this code:
Sub GetActiveDocumentPath()
MsgBox ActiveDocument.path
End Sub
So it seems the simple solution is to not use a sharepoint folder to store the items. Anyone have a clever solution for those of us working in the SharePoint environment?
Related
Somewhere on the internet I found this code to easily save a .docx file out of a .dotx file into the desired folder:
Sub SaveFileInTheCorrectDirectory()
ActiveDocument.SaveAs2 "[the correct directory, put in manually by me in the VBA code]" & InputBox("Type the desired file name", "Save As")
End Sub
However, this code automatically overwrites an already existing file with the same name (and in the same directory, of course). I've tried looking for code to fix this, and found a few suggestions:
Trying to save word file, from excel vba, without over-writing any existing files
https://answers.microsoft.com/en-us/msoffice/forum/all/vba-macro-saveas-overights-exsiting-file-without/e6fce3b1-ee72-498d-8fe5-fbc3e0cdbf23
http://computer-programming-forum.com/1-vba/2fb545278f4311ff.htm
https://groups.google.com/g/microsoft.public.word.vba.customization/c/Q4W2CK4gQOg?pli=1
But I can't figure out how to implement them...
Could someone be so kind to assist me?
Thanks!
PS Is there added value to use "SaveAs2" instead of "SaveAs" or the other way around?
That's as simple as:
Dim StrName as String
StrName = InputBox("Type the desired file name", "Save As")
If Trim(StrName) = "" then Exit Sub
If Dir(StrPath & StrName & ".docx") = "" Then ActiveDocument.SaveAs2 StrPath & StrName & ".docx"
where StrPath & StrName are the path & name, respectively.
Note: I haven't added any code for what to do if the file exists because you haven't said what you want to do in that case. Post a new question if you need help with that.
I want Word VBA macro to rename the document to the folder it lives in.
Sub SaveAsDOCX()
'
OpenDocName = ActiveDocument.FullName
lengthFileName `enter code here`= Len(OpenDocName)
OpenDocName = Left(OpenDocName, lengthFileName - 4)
'
ChangeFileOpenDirectory (ActiveDocument.Path & "\")
ActiveDocument.SaveAs2 FileName:=(OpenDocName & ".docx"),
FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="",
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:=False, SaveFormsData:=False,
SaveAsAOCELetter:=False, CompatibilityMode:=0
ActiveWindow.Close
End Sub
Right now the code functions to rename the DOCX as the old file name, but I want to extract from the directory the folders name, and rename the document that. Unfortunately I need this macro to run in a lot of different folders so I need it to stay dynamic, and can't use explicit folder paths.
'That line gets the Full path to the Folder where the document is located.
ThisDocument.path
'That line get the FullPath to the Document place
ThisDocument.FullName
Example one , you can create a new string for the name document
dim docpath as string
Dim docname As String
docname = VBA.Split(VBA.Mid(ActiveDocument.FullName, VBA.InStrRev(ActiveDocument.FullName, "\") + 1), ".")(0)
DocPath = ThisDocument.Path & "\" & docname & ".docx"
Example 2
dim docpath as string
Dim docname As String
docname = Vba.Split(ActiveDocument,".")(0)
DocPath = ThisDocument.Path & "\" & docname & ".docx"
I do not know if is that you want , please , comment below if that helped you , i want to help you!
Actually pretty simple. Used the ActiveDocument to get the path string, split it, ubound to the top, -1 to locate the parent folders name in the array, and then called that resulting string. The ending code looks like:
Dim name, nameSplit, ParentFolderName
OpenDocName = ActiveDocument.FullName
nameSplit = Split(OpenDocName, "\")
ParentFolderName = (UBound(nameSplit) - 1)
and then when performing SaveAs2 call the following as the FileName:=
(nameSplit(ParentFolderName) & ".docx")
I am trying to use VBA coding - which I am pretty new to - to obtain a series of .doc documents from PDFs (which are not images), that is, I am trying to loop over various PDF files and save them in MS Word format. My experience is that word reads pretty well the PDF documents that I have: word maintains the correct layout of the PDF file most of the time. I am not sure if this is the right choice to tackle this and I ask for an alternative suggestion -- using R, if possible.
Anyway, here it is the code which I found here:
Sub convertToWord()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("C:\Users\username\work_dir_example" & "*.pdf") 'pdf path
Do While (file <> "")
ChangeFileOpenDirectory "C:\Users\username\work_dir_example"
Documents.Open Filename:=file, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto, XMLTransform:=""
ChangeFileOpenDirectory "C:\Users\username\work_dir_example"
ActiveDocument.SaveAs2 Filename:=Replace(file, ".pdf", ".docx"), FileFormat:=wdFormatXMLDocument _
, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, CompatibilityMode:=15
ActiveDocument.Close
file = Dir
Loop
End Sub
After pasting it in the developer's window, I save the code in a module -> I close the developer's window -> I click on the "Macros" button -> I execute the "convertToWord" macro. I get the following error in a pop up box: "Sub or Function not defined". How do I fix this? Also, previously, for some reason that is not clear to me now, I got an error related to the function ChangeFileOpenDirectory, which seemed not to be defined also.
Update 27/08/2017
I changed the code to the following:
Sub convertToWord()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("C:\Users\username\work_dir_example" & "*.pdf")
ChDir "C:\Users\username\work_dir_example"
Do While (file <> "")
Documents.Open Filename:=file, ConfirmConversions:=False, ReadOnly:= _
False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _
"", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _
Format:=wdOpenFormatAuto, XMLTransform:=""
ActiveDocument.SaveAs2 Filename:=Replace(file, ".pdf", ".docx"), FileFormat:=wdFormatXMLDocument _
, LockComments:=False, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False, CompatibilityMode:=15
ActiveDocument.Close
file = Dir
Loop
End Sub
Now I do not get any error messages in a pop up box, but there is no output in my working directory. What might be wrong with it right now?
Any language that can read PDF files and write Word docs (which are XML) can do this, but the conversion you like (which Word does when the PDF is opened) will require using an API for the application itself. VBA is your easy option.
The snippets you've posted (and my samples below) use early binding and enumerated constants, which means we need a reference to the Word object library. That is already set up for any code you write in a Word document, so create a new Word document and add the code in a standard module. (See this Excel tutorial if you need more details, the steps for our process are the same).
You can run your macro from the VB Editor (using the Run button) or from the normal document window (click the Macros button on the View tab in Word 2010-2016). Save your document as a DOCM file if you want to reuse the macro without setting up the code again.
Now for the code!
As stated in comments, your second snippet is valid if you just ensure that your folder paths end with a backslash "\" character. It's still not great code after you fix that, but that'll get you up and running.
I'll assume you want to go the extra mile and have a well-written version of this you could repurpose or expand upon later. For simplicity, we'll use two procedures: the main conversion and a procedure to suppress the PDF conversion warning dialog (controlled by the registry).
Main procedure:
Sub ConvertPDFsToWord2()
Dim path As String
'Manually edit path in the next line before running
path = "C:\users\username\work_dir_example\"
Dim file As String
Dim doc As Word.Document
Dim regValPDF As Integer
Dim originalAlertLevel As WdAlertLevel
'Generate string for getting all PDFs with Dir command
'Check for terminal \
If Right(path, 1) <> "\" Then path = path & "\"
'Append file type with wildcard
file = path & "*.pdf"
'Get path for first PDF (blank string if no PDFs exist)
file = Dir(file)
originalAlertLevel = Application.DisplayAlerts
Application.DisplayAlerts = wdAlertsNone
If file <> "" Then regValPDF = TogglePDFWarning(1)
Do While file <> ""
'Open method will automatically convert PDF for editing
Set doc = Documents.Open(path & file, False)
'Save and close document
doc.SaveAs2 path & Replace(file, ".pdf", ".docx"), _
fileformat:=wdFormatDocumentDefault
doc.Close False
'Get path for next PDF (blank string if no PDFs remain)
file = Dir
Loop
CleanUp:
On Error Resume Next 'Ignore errors during cleanup
doc.Close False
'Restore registry value, if necessary
If regValPDF <> 1 Then TogglePDFWarning regValPDF
Application.DisplayAlerts = originalAlertLevel
End Sub
Registry setting function:
Private Function TogglePDFWarning(newVal As Integer) As Integer
'This function reads and writes the registry value that controls
'the dialog displayed when Word opens (and converts) a PDF file
Dim wShell As Object
Dim regKey As String
Dim regVal As Variant
'setup shell object and string for key
Set wShell = CreateObject("WScript.Shell")
regKey = "HKCU\SOFTWARE\Microsoft\Office\" & _
Application.Version & "\Word\Options\"
'Get existing registry value, if any
On Error Resume Next 'Ignore error if reg value does not exist
regVal = wShell.RegRead(regKey & "DisableConvertPdfWarning")
On Error GoTo 0 'Break on errors after this point
wShell.regwrite regKey & "DisableConvertPdfWarning", newVal, "REG_DWORD"
'Return original setting / registry value (0 if omitted)
If Err.Number <> 0 Or regVal = 0 Then
TogglePDFWarning = 0
Else
TogglePDFWarning = 1
End If
End Function
As others have stated, the problem seems to lie mostly with the path & file name. Here is the second version of the code you posted with some changes.
Unfortunately, a warning message pops up and setting DisplayAlerts to false will not suppress it. But if you click the "don't show this message again" checkbox the first time it pops up, then it will not continue to pop up for every file.
Sub convertToWord()
Dim MyObj As Object
Dim MySource As Object
Dim file As String
Dim path As String
path = "C:\Users\username\work_dir_example\"
file = Dir(path & "*.pdf")
Do While (file <> "")
Documents.Open FileName:=path & file
With ActiveDocument
.SaveAs2 FileName:=Replace(path & file, ".pdf", ".docx"), _
FileFormat:=wdFormatXMLDocument
.Close
End With
file = Dir
Loop
End Sub
I've made an Excel sheet which processes data to a Sheet and Saves it as a new workbook in a certain Folder - Subfolder (named like the first part of the file names).
The code works fine but I'd like to make a new folder if the required path does not exists. Should definitely be possible to achieve with an 'If' function, but I don't know how to create new folders.
Note: skipped some part in the code below, to keep it short I only past the parts worth mentioning.
Sub SaveSheetAs()
Dim sMainFolder as String
Dim sFileName as string
Dim sSubFolder as string
sMainFolder = Z:\Parts Manufacturing\5. Kwaliteit\130 - in proces meten\EindProject\Bron '(Main folder, which isn't variable)
sFileName = 4022 646 68954#1234 '(Part name with Unique number)'variable number, in de real code this number is received by refering to a range("")
sSubFolder = 4022 646 68954 '(variable number, in de real code this number is received by refering to a range("")
ActiveWorkbook.SaveAs Filename:=sMainFolder & "\"& sSubFolder & "\" & sFileName & ".csv", FileFormat:=xlCSV, CreateBackup:=False, Local:=True
end sub
Here you go :
If Dir(sMainFolder & "\"& sSubFolder & "\", 16) <> vbNullString Then
Else
MkDir (sMainFolder & "\"& sSubFolder & "\")
End If
I'm having a problem with this piece of my code in VBA and I can't figure out why it isn't working! I've tried another code to see if it was the loop that has the issue but the issue is specifically opening the files and not iterating through them.
Sub fileloop(Path)
Dim strFile As String, strPath As String
Dim MyBook As Workbook
strPath = Path '& "\*.csv"
strFile = Dir(strPath & "\*.csv")
MsgBox (strFile)
While strFile <> ""
'placed another messagebox here to see if the strFile was the same inside the loop.
MsgBox (strFile)
'this line has the error.
Workbooks.OpenText FileName:=strFile, _
DataType:=xlDelimited, Comma:=True, Local:=True
set MyBook = ActiveWorkbook
Call SortColumnB(MyBook)
strFile = Dir
Wend
End Sub
The error message I get goes something like this:
'AC000W0009.csv' could not be found. Check the spelling of the file name, and verify that the file location is correct.
If you are trying to open the file from your list of most recently used files, make sure that the file has not been renamed, moved, or deleted.
I've tried so many variations apart from the one listed above and I can't understand why VBA won't recognize that the file exists.
EDIT
Going off of what Mike said about opening a file with the complete path the changes I made to the code to let it open .csv files:
strPath = Path & "\"
strFile = Dir(strPath & "*.csv")
While strFile <> ""
MsgBox (strFile) 'added path to file name.
Workbooks.OpenText FileName:=strPath & strFile, _
DataType:=xlDelimited, Comma:=True, Local:=True
I beleve the Dir only returns only the filename.
If you want to open it, you need to add the path to the file name returned by Dir.
There's some good examples here