I have Word survey files, each containing forms filled by subjects. Until now I have manually exported the forms data by saving as txt and choosing the option "save form data as delimited text file".
I want to programmatically save as delimited text file all the .doc documents in a given directory. Alternatively, if this were to be too complicated, it would be sufficient to save one file at a time. The new txt files must have the same name as the original .doc files.
Thanks for your input Jan Schejbal. I've reached a solution with this piece of code, so I share it for whose who encounter the same problem. I received help from here
Sub Save_Forms_Data()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document, strDocName As String
strFolder = CurDir
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
strDocName = Left(.FullName, InStrRev(.FullName, ".")) & "txt"
.SaveAs2 FileName:=strDocName, FileFormat:=wdFormatText, AddToRecentFiles:=False, _
SaveFormsData:=True, Encoding:=1252, InsertLineBreaks:=False, LineEnding:=wdCRLF
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
Application.Quit SaveChanges:=wdDoNotSaveChanges
End Sub
You can record a macro, which means you start the recording, do certain actions, then stop the recording, and VBA code for said actions is automatically generated. The code may not be very clean, but it should give you a good start to show you how the syntax looks and what commands you need for your actions. For certain things (e.g. dynamically specifying the file name), you will need to consult the documentation, but if you have any programming experience in any common language, this should not pose a significant problem once you have the "skeleton" provided by the macro recorder.
The more you want to automate, the more VBA you will need to learn. As VBA really isn't difficult, and it seems like you have a lot of repetitive work in front of you if you don't automate it, I'd suggest you learn it and Google what you need. This way, you will get your work done in a similar timeframe (or less, especially if this is not just a one-off thing), you will have a macro to do it next time, it will be less boring, and you will have learned a bit of VBA.
Related
I need to loop over some word documents, and extract images from a word document and save them in a separate folder.
I've tried the method of saving them as an HTML document, but it is not a good fit for my requirement.
Now, I'm looping through the images using inlineshapes object and then copy-pasting them on a publisher document and then saving them as an image. However, I'm facing a Runtime Automation error when I'm running the script.
For using the Publisher runtime library I've tried both early and late binding but I'm facing the error on both of them.
Can anyone please let me know what is the problem? Also, if anyone can explain why I'm facing this error, that'd be great. As per my understanding, it is due to memory allocation, but I'm not sure.
Here is the code block that I've been working on (fp, dp are folder paths, while filename is the word document name. I'm calling this sub in another sub that is looping over all the files in a folder):
Sub test(ByVal fp As String, ByVal dp As String, ByVal filename As String)
Dim doc As Document
Dim pubdoc As New Publisher.Document
Dim shp As InlineShape
'Application.Screenupdating = False
'Dim pubdoc As Object
'Set pubdoc = CreateObject("Publisher.Document")
Set doc = Documents.Open(fp)
With doc
i = .InlineShapes.Count
Debug.Print i
End With
For j = 1 To i
Set shp = doc.InlineShapes(j)
shp.Select
Selection.CopyAsPicture
pubdoc.Pages(1).Shapes.Paste
pubdoc.Pages(1).Shapes(1).SaveAsPicture (dp & Application.PathSeparator & j & ".jpg")
pubdoc.Pages(1).Shapes(1).Delete
Next
doc.Close (wdDoNotSaveChanges)
pubdoc.Close
'Application.Screenupdating = True
End Sub
Apart from this, if anyone has any suggestions to make this faster, I'm all ears. Thanks in advance!
Just add .zip to the end of the file name, expand the file and look in the word/media folder. All the files will be there, no programming necessary.
Extracting the pictures from a Filtered HTML document that was created from your original source document would be faster. However, you said that was not a good fit for you needs so ... here is example code that will locate pictures in your source document and paste them into a second document.
The speed problem of this type of code is caused by the CopyPicture working from a Selection command, so I recommend using a range instead. Of course the For/Next loop that is required is slower no matter what.
Sub CopyPasteAsPicture()
Dim doc As Word.Document, iShp As Word.InlineShape, shp As Word.Shape
Dim i As Integer, nDoc As Word.Document, rng As Word.Range
Set doc = ActiveDocument
If doc.Shapes.Count > 0 Then
For i = 1 To doc.Shapes.Count
Set shp = doc.Shapes(i)
If shp.Type = msoLinkedPicture Or shp.Type = msoPicture Then
'if you want only pictures extracted then you have
'to specify the type
shp.ConvertToInlineShape
'if you want all extracted pictures to be in the sequence
'they appear in the document then you have to convert
'floating shapes to inline shapes
End If
Next
End If
If doc.Content.InlineShapes.Count > 0 Then
Set nDoc = Word.Documents.Add
Set rng = nDoc.Content
For i = 1 To doc.Content.InlineShapes.Count
doc.Content.InlineShapes(i).Range.CopyAsPicture
rng.Paste
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
rng.Paragraphs.Add
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
Next
End If
End Sub
If you want to place all shapes (floating or inline) into a folder as image files, then the best way is to save the source document as a filtered HTML document. Here is the command:
htmDoc.SaveAs2 FileName:=LGPWorking & strFileName, AddToRecentFiles:=False, FileFormat:=Word.WdSaveFormat.wdFormatFilteredHTML
In the above the active document is assigned to the variable htmDoc. I am giving this new document a specific name and location. The output from this is not only the HTML file but also a directory by the same name with an appended "_Files" label. In the "x_Files" directory are all the image files.
If you only want selective images pulled from your original source document, or if you want images pulled from multiple source documents ... then you need to use the above code that I shared for placing only the images you want from one or more source document into a new Word document and then save that new document as an Filtered HTML.
When your routine is done, you can Kill the HTML document and only leave the Files directory.
I had to change a few things around, but this will allow to save a single image on a word document and go through a couple of cycles before it turns into a jpg on the other side, without any white space
filename = ActiveDocument.FullName
saveLocaton = "z:\temp\"
FolderName = "test"
On Error Resume Next
Kill "z:\temp\test_files\*" 'Delete all files
RmDir "z:\temp\test_files" 'Delete folder
ActiveDocument.SaveAs2 filename:="z:\temp\test.html", FileFormat:=wdFormatHTML
ActiveDocument.Close
Kill saveLocaton & FolderName & ".html"
Kill saveLocaton & FolderName & "_files\*.xml"
Kill saveLocaton & FolderName & "_files\*.html"
Kill saveLocaton & FolderName & "_files\*.thmx"
Name saveLocaton & FolderName & "_files\image00" & 1 & ".png" As saveLocaton & FolderName & "_files\" & test2 & "_00" & x & ".jpg"
Word.Application.Visible = True
Word.Application.Activate
The problem I'm having is when I run my macro to save the current Word Document as a HTML type, the document still remains open but not in the original .docx format, it's in the .htm format.
If I were to edit the document after the macro is ran, it wouldn't remain on the original .docx format later.
I would appreciate feedback on how to remain in the original format when also saving a copy with a different format. Thanks.
Here is my docx to html code in VBA
Sub DocToHTML()
Dim slice As String
Dim strDocName As String
Dim PathOrg As String
On Error Resume Next
strDocName = ActiveDocument.Name
slice = Left(strDocName, InStrRev(strDocName, ".") - 1)
strDocName = ActiveDocument.Path + "\" + slice
ActiveDocument.SaveAs2 FileName:=strDocName, FileFormat:=wdFormatHTML
End Sub
Before you write code to do things like this stop and think how you would do it in the UI without code. Any code that you write will simply automate that process.
So what would you do in the UI?
Save the original document to preserve any changes that you have made.
Save a copy as html.
Reopen the original document.
Possibly close the html version.
So your code can be rewritten as follows:
Sub DocToHTML()
Dim origName As String
Dim saveName As String
Dim docHTML As Document
If Not ActiveDocument.Saved Then ActiveDocument.Save
origName = ActiveDocument.FullName
saveName = Left(origName, InStrRev(origName, ".") - 1)
ActiveDocument.SaveAs2 FileName:=saveName, FileFormat:=wdFormatHTML
Set docHTML = ActiveDocument
Documents.Open origName
docHTML.Close wdDoNotSaveChanges
End Sub
I want to open and copy sheet in file TFM_20150224_084502 and this file has different date and time each day. I have developed code until open the date format but I can't develop to open it with time format.
What's the more code for it?
Sub OpenCopy ()
Dim directory As String, fileName As String, sheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "z:\FY1415\FI\Weekly Report\Astry"
fileName = "TFM_" & Format(Date, "yyyymmdd") & ".xls"
Workbooks.Open "z:\FY1415\FI\Weekly Report\Astry\" & "TFM_" & Format(Date, "yyyymmdd") & ".xls"
Sheets("MSP").Copy After:=Workbooks("Generate Report 2.xlsm").Sheets("PlanOEE")
ActiveSheet.Name = "MSP"
End sub
It seems that some linebreaks have disappeared when you posted the code into your post, but assuming you are aware of this, I assume that the main problem you have is figuring out the name of the file you want to open?
The VBA Dir-function lets you search for a file in a folder, and lets you include wildcards in your search. I've included this function in your sub, and have tested it with a similarly named file on my computer (albeit without the copying of the sheet), and it opened the sheet:
Sub OpenCopy()
Dim directory As String, fileName As String, sheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
directory = "z:\FY1415\FI\Weekly Report\Astry\"
fileName = Dir(directory & "TFM_" & Format(Date, "yyyymmdd") & "*.xls*")
If fileName <> "" Then
With Workbooks.Open(directory & fileName)
.Sheets("MSP").Copy After:=Workbooks("Generate Report 2.xlsm").Sheets("PlanOEE")
End With
ActiveSheet.Name = "MSP"
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The line relevant for finding the filename is, as you probably see:
fileName = Dir(directory & "TFM_" & Format(Date, "yyyymmdd") & "*.xls*")
I have simply used Dir to do a search for file fitting the string inside the parantheses, where the asterisks are wildcards. The reason I have included an asterisk after xls too is because there is a chance the file can have extensions such as xlsx or xlsm in newer versions of office. I've also added a backslash at the end of the directory string, since you'll have to include it before the filename anyway.
I have also added an if-clause around what you do with the workbook you open, in case no file fitting the search is found.
Note that this sub will only do what you want provided that there only is one file generated for each date. If you want to loop through all files which includes a given date, I would recommend having a look at this post here on SO, which explains how to loop through all files in a folder, modifying the macros presented there to fit your needs should be fairly trivial.
When I run the following dir loop, the files that open prompt to update the links even though the code says to update them. Does anyone know why I'm still prompted to update? I have a feeling its related that my directory is sharepoint.
Sub OpenProjectFiles()
Dim sFile As String
Dim sPath As String
sPath = Application.ActiveWorkbook.Path
sPath = Replace(sPath, "/", "\")
sPath = Replace(sPath, "http:", "")
sFile = Dir(sPath & "\FY*.xls")
Do While Len(sFile) > 0
On Error Resume Next
Workbooks.CheckOut FileName:=sPath & "\" & sFile
Workbooks.Open FileName:=sPath & "\" & sFile, UpdateLinks:=3
sFile = Dir
Loop
End Sub
I actually figured out my own question, explained below. However I would love insight if there's a better or faster way to cycle through and open these files. Currently it takes about 6 seconds to find, check out, open and update the links--updating the links doesn't take long since it normally isn't much information to update. And since this routine will normally open about 10-15 files it almost takes about 2 minutes to complete.
Answer: what I realized was the code was in fact updating the links but for some reason the prompt was still popping up. So I just disabled the prompt with:
Application.AskToUpdateLinks = False
I am making my first steps in VBA.
I have been trying many things, but still I haven't figured out a way to save a .pptm powerpoint presentation to .pptx format with the same file name in a specific path?
I already use the following code to save as pdf.
ActivePresentation.ExportAsFixedFormat "c:\" + Replace(ActivePresentation.Name, "pptm", "pdf"), ppFixedFormatTypePDF, ppFixedFormatIntentPrint, msoCTrue
Thank you in advance.
Basic usage is:
With ActivePresentation
.SaveCopyAs _
FileName:=.Path & "\" & Left(.Name, InStrRev(.Name, ".")) & "pptx", _
FileFormat:=ppSaveAsOpenXMLPresentation
End With
(Or you can use .SaveAs. SaveAsCopy keeps the current open and doesn't open the copy, whereas .SaveAs sets the current to be the saved version)
However, if the Powerpoint you are saving hasn't been saved at least once then the above will error (there is no file extension in Presentation.Name to find with InStrRev). You can either test for there being no full stop, or you can use a lazy method of asking FileSystemObject to get you the name without an extension (I am lazy so I prefer this method):
So a better more robust method is:
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
With ActivePresentation
.SaveCopyAs _
FileName:=fso.BuildPath(.Path, fso.GetBaseName(.Name) & ".pptx"), _
FileFormat:=ppSaveAsOpenXMLPresentation
End With