Copy the contents of a document(s) through FileDialogbox picker, to a new one - vba

With MS_Word 2010 I have been trying to achieve the way to copy the contents(whole) of one file to a new one retrieving the file name of the original and adding it to the new one with the suffix "Copy".
All this process has a reason, since the Original document has only a few editable section and have protection enable (And I cant disable it) but I need to review it with other macro, so with a Copy of the contents in a new document I have been able to apply my whole macro. I also know of the method CopyFile but since this method copy also the characteristic of the original doc (the constrains in edit) I decide not to use it.
Searching around and using the recorder(for the copy actions) i have been able to come with this:
Sub Backup()
Dim DocName As String
Dim DocPath As String
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path of each selected item. Even though the path is aString, the variable must be a Variant because For Each...Next, routines only work with Variants and Objects.
Dim vrtSelectedItem As Variant
'Use a With...End With block to reference the FileDialog object.
With fd
'Allow the user to select multiple files.
.AllowMultiSelect = True
'Use the Show method to display the File Picker dialog box and return the user's action.
'If the user presses the button...
If .Show = -1 Then
'Step through each string in the FileDialogSelectedItems collection.
For Each vrtSelectedItem In .SelectedItems
On Error Resume Next
'vrtSelectedItem is aString that contains the path of each selected item. You can use any file I/O functions that you want to work with this path.
'MsgBox "Selected item's path: " & vrtSelectedItem
'Retrieve the name of the current doc (later I found out about .Name, .Path, .FullName ...)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
DocName = fso.GetBaseName(vrtSelectedItem)
'MsgBox "Selected item's : " & DocName
'Retrieve the path without the filename/extention
Documents.Open(vrtSelectedItem).Active
DocPath = ActiveDocument.Path
'MsgBox "Selected item's path: " & DocPath
'Copy the content of the current document
'With Documents(DocName)
With ActiveDocument
.WholeStory
.Copy
End With
'Create Backup File with ability to modify it, since the original is protected by password and only few segments are enable to edit
Documents.Add Template:=DocName & "Copy", NewTemplate:=False, DocumentType:=0
'Since Document.Add its suppose to promp as the Active document
'Paste the contents and save
'With Documents(DocName & "Copy")
With ActiveDocument
.PasteAndFormat (wdUseDestinationStylesRecovery)
.SaveAs DocPath
End With
'Documents(DocName & "Copy").Close SaveChanges:=True
Next
'If the user presses Cancel...
Else
End If
End With
'Set the object variable to Nothing.
Set fd = Nothing
End Sub
But as you guess, it doesn't work as desire and don't create the copy neither the new document with the name. So any scope in the right direction will be appreciate.
Thanks in advance for all the answers.
For future reference here is the code improved, based in the Response of #Charlie
Sub Backup()
Dim DocName As String
Dim NewDoc As Document
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path of each selected item. Even though the path is aString, the variable must be a Variant because For Each...Next, routines only work with Variants and Objects.
Dim vrtSelectedItem As Variant
'Use a With...End With block to reference the FileDialog object.
With fd
'Allow the user to select multiple files.
.AllowMultiSelect = True
'Use the Show method to display the File Picker dialog box and return the user's action.
'If the user presses the button...
If .Show = -1 Then
'Step through each string in the FileDialogSelectedItems collection.
For Each vrtSelectedItem In .SelectedItems
On Error Resume Next
'vrtSelectedItem is aString that contains the path of each selected item. You can use any file I/O functions that you want to work with this path.
'MsgBox "Selected item's path: " & vrtSelectedItem
'Retrieve the name of the current doc (later I found out about .Name, .Path, .FullName ...)
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
DocName = fso.GetBaseName(vrtSelectedItem)
'MsgBox "Selected item's : " & DocName
'Create Backup File with ability to modify it, since the original is protected by password and only few segments are enable to edit
Set NewDoc = Documents.Add
'Since Document.Add its suppose to promp as the Active document
'Paste the contents and save
With NewDoc
Selection.InsertFile FileName:=vrtSelectedItem, Range:=vbNullString, _
ConfirmConversions:=False, Link:=False, Attachment:=False
.SaveAs FileName:=vrtSelectedItem & "_BACKUP.docx"
.Close
End With
Next
'If the user presses Cancel...
Else
End If
End With
'Set the object variable to Nothing.
Set fd = Nothing
End Sub

I would try creating a new Word doc then using this line to "insert the text from the protected Word doc." It's the same as going to the Insert Ribbon tab -> Object -> Text from File.
Selection.InsertFile FileName:="protected.docx", Range:="", _
ConfirmConversions:=False, Link:=False, Attachment:=False

Related

VBA FileDialog saves powerpoint as .ppt instead of .pptx

I have a PowerPoint with a couple macros: one that allows you to load some data from a Word, and another one that exports the PowerPoint to the same location where the Word was. This is the latter:
Sub export()
Dim dlgSaveAs As FileDialog
Dim strMyFile As String
Dim ppPres As Presentation
Set dlgSaveAs = Application.FileDialog(Type:=msoFileDialogSaveAs)
With dlgSaveAs
.InitialFileName = path & "Exported without macros - " & company & " (((insert date)))"
If .Show = -1 Then
strMyFile = .SelectedItems(1)
'MsgBox strMyFile
ActivePresentation.SaveAs strMyFile, 1
'-- save your file to strMyFile here
Else
'MsgBox "No file selected."
'-- The user pressed Cancel.
End If
End With
Set dlgSaveAs = Nothing
End Sub
To be honest, I didnĀ“t wrote this code. I found it months ago and adapted it and I dont know how it really works.
The issue is that when the 'Save As' FileDialog opens, the file extension seems to be ok:
But after pressing 'save' the file gets saved as a .ppt:
Any idea how to fix this?
Change this:
ActivePresentation.SaveAs strMyFile, 1
to this:
ActivePresentation.SaveAs strMyFile, 24
or to
ActivePresentation.SaveAs strMyFile, ppSaveAsOpenXMLPresentation

Adding existing Header and Footer for multiple word documents

I have around 1000 word documents in one folder which the header and footer needs to be added/changed (header need to added/changed just for the first page).
I found a very helpful VBA script which is work but I tried but can not style and format to my needs, which is shown in the attached pictures
Header Style I need
Footer Style I need
The found working code which i found in stackoverflow:
Sub openAllfilesInALocation()
Dim Doc
Dim i As Integer
Dim docToOpen As FileDialog
Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
docToOpen.Show
For i = 1 To docToOpen.SelectedItems.Count
'Open each document
Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
With ActiveDocument.Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Text = "Header goes here"
.Footers(wdHeaderFooterPrimary).Range.Text = "Footer goes here"
End With
Doc.Save
Doc.Close
Next i
End Sub
Thanks in advance for everybody reading and/or helping me with this question, because if I can not work it out, I need to add for around 1000 word docs headers and footers manually...... :( so thanks for helping or just trying!
Before you write code for this you need to break the task down into steps.
Open one of the documents that you need to apply the changes to.
Record a macro whilst you edit the Header style so that it has the correct formatting
Record a macro whilst you edit the Footer style so that it has the correct formatting
Edit the header of the document to include whatever logo and text you require.
Select the content of the header and save as as a Building Block - on the Header & Footer tab click "Header" then "Save Selection to Header Gallery". Ensure that you pay attention to which template you are saving it to as you will need to know this later.
Edit the footer of the document to include whatever text you require.
Select the content of the footer and save as as a Building Block - on the Header & Footer tab click "Footer" then "Save Selection to Footer Gallery". Again ensure that you pay attention to which template you are saving it to.
Now you can write your code. For example:
Sub openAllfilesInALocation()
Dim Doc As Document
Dim i As Integer
Dim BBlockSource As Template
Set BBlockSource = Application.Templates("<Full path to template you stored building blocks in>")
Dim docToOpen As FileDialog
Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
docToOpen.Show
For i = 1 To docToOpen.SelectedItems.Count
'Open each document
Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
MacroToModifyHeaderStyle 'name of the macros you recorded in steps 2 & 3
MacroToModifyFooterStyle
With ActiveDocument.Sections(1)
BBlockSource.BuildingBlockEntries("Name of Header Building Block").Insert .Headers(wdHeaderFooterFirstPage).Range
BBlockSource.BuildingBlockEntries("Name of Footer Building Block").Insert .Footers(wdHeaderFooterFirstPage).Range
'you may need the following if an extra paragraph is created when adding the building block
'.Headers(wdHeaderFooterFirstPage).Range.Paragraphs.Last.Range.Delete
'.Footers(wdHeaderFooterFirstPage).Range.Paragraphs.Last.Range.Delete
End With
Doc.Save
Doc.Close
Next i
End Sub
Obviously you test your code on a copy of some of the files before attempting to run it on all of them.
Simply add the following macro to a document containing your new header & footer, then run the macro, which includes a folder browser so you can select the folder to process.
Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim wdDocTgt As Document, wdDocSrc As Document
Dim Sctn As Section, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set wdDocSrc = ActiveDocument
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> wdDocSrc.FullName Then
Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, _
AddToRecentFiles:=False, Visible:=False)
With wdDocTgt
For Each Sctn In .Sections
'For Headers
For Each HdFt In Sctn.Headers
With HdFt
If .Exists Then
If .LinkToPrevious = False Then
.Range.FormattedText = _
wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText
End If
End If
End With
Next
'For footers
For Each HdFt In Sctn.Footers
With HdFt
If .Exists Then
If .LinkToPrevious = False Then
.Range.FormattedText = _
wdDocSrc.Sections.First.Footers(wdHeaderFooterPrimary).Range.FormattedText
End If
End If
End With
Next
Next
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
As coded, the macro assumes the document you're running the macro from has only one Section, with up to three populated headers (as allowed by Word), and that all headers in the target document are to be updated to match the source document's primary header & footer. If you only want to update headers in the first Section, delete the footer loop and delete 'For Each Sctn In .Sections' and it's 'Next' later in the code and change 'For Each HdFt In Sctn.Headers' to 'For Each HdFt In .Sections(1).Headers'.

Open Excel from Word using FileDialog

What I want to do is:
Press a button in my Microsoft Word doc it will prompt me to select a document in the file explorer.
Select my document the relevant fields in my word doc will be populated.
This will be populated based upon information in the document (the month) and using a Match function it will search for the correct row/column in the selected excel document and return the value.
I am stuck on the FileDialog(msoFileDialogFilePicker) section of my code below.
For the purpose of my document I can not enter the direct file path, the file path needs to be taken from the FileDialog function (or something similar).
I have also tried GetOpenFilename. I am unsure how to do this. My code currently opens FileDialog and lets me select a file, but I can not pass the file path onto my colNum1 line.
The error I get is Run-time error '91'. Object variable or With Block variable not set.
I am open to suggestions and any help is much appreciated.
Sub KPI_Button()
'
' KPI_Button Macro
Dim objExcel As New Excel.Application
Dim exWb As Excel.Workbook
Dim strFile As String
Dim Doc As String
Dim Res As Integer
Dim dlgSaveAs As FileDialog
Doc = ThisDocument.Name
Set dlgSaveAs = Application.FileDialog(msoFileDialogFilePicker)
Res = dlgSaveAs.Show
colNum1 = WorksheetFunction.Match("(Month)", ActiveWorkbook.Sheets("Sheet1").Range("A2:I2"), 0)
ThisDocument.hoursworkedMonth.Caption = exWb.Sheets("Sheet1").Cells(3, colNum1)
exWb.Close
Set exWb = Nothing
End Sub
try a dialog that specifies an Excel extension as such:
Sub GetNames()
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excel files", "*.xls*", 1
If .Show = True Then
If .SelectedItems.Count > 0 Then
'this is the path you need
MsgBox .SelectedItems(1)
Else
MsgBox "no valid selection"
End If
End If
End With
End Sub

VBA - Automated PowerPoint won't open .pptx file that is being used by another User

I am creating a script that copies slides from various other .pptx files into a Master PowerPoint, but if one of the files is opened by another User at the same time the macro executes I receive an 80004005 error. My script is as follows:
Public Sub Update()
Dim PPTApp As Object
Dim PPT As Object
Dim MasterPPT As Presentation
Dim Total As Integer
Dim FSO As New Scripting.FileSystemObject
Dim Folder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim File As Scripting.File
Set MasterPPT = Presentations("Combined Staff Agenda Template.pptm")
Total = MasterPPT.Slides.Count
Set PPTApp = CreateObject("PowerPoint.Application")
' Sets the first ComboBox destination folder
Set Folder = FSO.GetFolder("O:\org\acle\Common\PE_SHARE\Technical Staff Meeting Agendas\Individual Slides\" & Order_UserForm.comboFirst.Value)
For Each SubFolder In Folder.SubFolders
For Each File In SubFolder.Files
' Copies and pastes all slides for each file
Set PPT = PPTApp.Presentations.Open(File.Path, ReadOnly:=msoTrue, WithWindow:=msoFalse)
PPT.Slides.Range.Copy
MasterPPT.Slides.Paste (Total)
PPT.Close
Total = MasterPPT.Slides.Count
Next File
Next SubFolder
The For Each loop is repeated twice for two more folders, and then the sub routine ends. The folder system is organized as follows: Parent Directory ("Technical Staff Meeting Agendas") > "Individual Slides" > Three (3) Department Folders > Individual User Folders with a .pptx file in each. Any workaround for accessing the File.Path if it is already opened?
Completely untested, but let's try something like this (assuming you're getting an error on Presentations.Open. I added an error-handling block around this method call, and based on the documentation (here) it looks like the .Open method's Untitled argument is equivalent to creating a copy of the file.
If that doesn't work, let me know. I can revise to explicitly create and open a copy of the file and open that, instead.
UPDATE Since the Untitled property didn't work, let's try explicitly creating a copy of the file. I did not include any "cleanup" code to remove the copied versions.
Public Sub Update()
Dim PPTApp As Object
Dim PPT As Object
Dim MasterPPT As Presentation
Dim Total As Integer
Dim FSO As New Scripting.FileSystemObject
Dim Folder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim File As Scripting.File
Set MasterPPT = Presentations("Combined Staff Agenda Template.pptm")
Total = MasterPPT.Slides.Count
Set PPTApp = CreateObject("PowerPoint.Application")
' Sets the first ComboBox destination folder
Set Folder = FSO.GetFolder("O:\org\acle\Common\PE_SHARE\Technical Staff Meeting Agendas\Individual Slides\" & Order_UserForm.comboFirst.Value)
For Each SubFolder In Folder.SubFolders
For Each File In SubFolder.Files
' Copies and pastes all slides for each file
On Error GoTo FileInUseError
Set PPT = PPTApp.Presentations.Open(File.Path, ReadOnly:=msoTrue, WithWindow:=msoFalse)
On Error GoTo 0
PPT.Slides.Range.Copy
MasterPPT.Slides.Paste (Total)
PPT.Close
Total = MasterPPT.Slides.Count
Next File
Next SubFolder
'## It's important to put this before your error-handling block:
Exit Sub
'## Error handling:
Err.Clear
'## First attempt, did not work as expected
'Set PPT = PPTApp.Presentations.Open(File.Path, ReadOnly:=msoTrue, Untitled:=msoTrue, WithWindow:=msoFalse)
'## Second attempt. You will need to add some logic to remove these files or do it manually.
Dim copyPath as String
copyPath = Replace(File.Path, File.Name, "Copy of " & File.Name)
FSO.CopyFile File.Path, copyPath, True
Set PPT = PPTApp.Presentations.Open(copyPath)
Resume Next
End Sub
Update 2
Other things you could try (not likely to work, but you should try them anyways):
I notice that this code is executing from within PowerPoint, so one thing that doesn't make sense is the: Set PPTApp = CreateObject("PowerPoint.Application"). You're already running an instance of PPT, and only one instance of PPT runs (unlike Excel which can have multiple instances). So get rid of that line entirely.
'Set PPTApp = CreateObject("PowerPoint.Application")
Then also you can get rid of the variable PPTApp. I notice you use a combination of early- and late-binding for your PowerPoint Object Variables. That doesn't really make sense and while I wouldn't expect that to cause any errors, you never know.
'Dim PPTApp as Object 'PowerPoint.Application '## This is unnecessary!!
Dim PPT as Presentation
Dim MasterPPT as Presentation
If all else fails, open the new file WithWindow=msoTrue and step through the code line by line using F8...
UPDATE 3
While I am not able to test a file that is locked/in-use by another user, I was able to test what happens if I have a file that is in use by myself. I use the following code and identify that the Files iteration will eventually encounter the lock/tmp version of the file, beginning with "~" tilde character. These are ordinarily hidden files, but FSO is picking them up in the iteration anyways.
Aside from that, I encounter similar errors if the file is not a valid PPT filetype (PPT, PPTX, PPTM, XML, etc.). I used the following code which prints a log of errors in the Immediate window (and informs you with MsgBox prompt) if there are errors.
Sub Test()
Dim MasterPPT As Presentation
Dim PPT As Presentation
Dim Total As Integer
Dim FSO As Object
Dim Folder As Object
Dim SubFolder As Object
Dim File As Object
Dim errMsg$
Dim copyPath$
Set MasterPPT = ActivePresentation '## Modify as needed.
Total = MasterPPT.Slides.Count
Set FSO = CreateObject("Scripting.FileSystemObject")
' Sets the first ComboBox destination folder // MODIFY AS NEEDED
Set Folder = FSO.GetFolder("C:\Users\david_zemens\Desktop\CHARTING STANDARDS")
For Each SubFolder In Folder.SubFolders
For Each File In SubFolder.Files
' Copies and pastes all slides for each file
On Error GoTo FileInUseError:
' Make sure it's a PPT file:
If File.Type Like "Microsoft PowerPoint*" Then
10:
Set PPT = Presentations.Open(File.Path, ReadOnly:=msoTrue, WithWindow:=msoFalse)
20:
PPT.Slides.Range.Copy
30:
MasterPPT.Slides.Paste (Total)
PPT.Close
End If
On Error GoTo 0
Total = MasterPPT.Slides.Count
NextFile:
Next File
Next SubFolder
'## It's important to put this before your error-handling block:
Set FSO = Nothing
Set Folder = Nothing
Set SubFolder = Nothing
Set File = Nothing
Exit Sub
FileInUseError:
'## Error handling:
'## Display information about the error
errMsg = "Error No.: " & Err.Number & vbCrLf
errMsg = errMsg & "Description: " & Err.Description & vbCrLf
errMsg = errMsg & "At line #: " & Erl & vbCrLf
errMsg = errMsg & "File.Name: " & File.Name
Debug.Print errMsg & vbCrLf
MsgBox errMsg, vbInformation, "Error!"
Err.Clear
Resume NextFile
End Sub

How can I import a text file into PowerPoint with vba?

I am used to doing this type of thing in Word, but the methods for the same sort of thing in PowerPoint are quite different.
I have a network folder with a list of text files in it. I want to be able to click into a text field on a slide and then click an import button on a custom menu. I then select one of the text files in the dialog and that imports the text into the area I have specified.
I have built the custom menu in PowerPoint 2010, and added a few other macros, but I can't work out the methods to use.
Can anyone give me a start?
Here is the code I am playing with:
Sub GetTextFromLibrary()
Dim lCurrentView As Long
Dim SlideNum As Integer
Dim Name$
Dim OldName$
'Store the default shape name to reset later
OldName$ = ActiveWindow.Selection.ShapeRange(1).Name
'Now rename the shape to work with it
Name$ = "temp01"
MsgBox "You are on slide: " & _
OldName$, vbInformation
ActiveWindow.Selection.ShapeRange(1).Name = Name$
' Get the current view type.
lCurrentView = ActiveWindow.ViewType
' Make sure that PowerPoint is in Slide view.
' ActiveWindow.Selection.SlideRange.SlideNumber produces an error if
' you are using any other view.
If lCurrentView = ppViewNormal Then
' Display the slide number.
'MsgBox "You are on slide: " & _
ActiveWindow.Selection.SlideRange.SlideNumber, vbInformation
SlideNum = ActiveWindow.Selection.SlideRange.SlideNumber
MsgBox "You are on slide: " & _
SlideNum, vbInformation
' Dim a variable as a specific object type
Dim oShape As Shape
' Set it to "point" to a specific shape:
Set oShape = ActivePresentation.Slides(SlideNum).Shapes("temp01")
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
'Declare a variable for the directory path.
Dim directory As String
'Set the directory path
directory = "C:\Documents and Settings\<USER>\Desktop\PitchTemplateLibrary\Quotes"
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Declare a variable to contain the path
'of each selected item. Even though the path is aString,
'the variable must be a Variant because For Each...Next
'routines only work with Variants and Objects.
Dim vrtSelectedItem As Variant
'Use a With...End With block to reference the FileDialog object.
With fd
'Change the initial directory\filename
.InitialFileName = directory
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the button.
If .Show = -1 Then
'Step through each string in the FileDialogSelectedItems collection.
For Each vrtSelectedItem In .SelectedItems
Dim fs As Object
Dim f As Object
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(vrtSelectedItem, 1, 0)
' Put the text into the text box
oShape.TextFrame.TextRange.Text = f 'oShape IS EMPTY, BUT CAN"T SEE WHY.
Next vrtSelectedItem
'The user pressed Cancel.
Else
End If
End With
' Until we release the memory used by oShape
Set oShape = Nothing
ActiveWindow.Selection.ShapeRange(1).Name = OldName$
Else
' PowerPoint is not in slide view.
MsgBox "You must be in slide view to run this macro.", _
vbInformation
End If
'Set the object variable to Nothing.
Set fd = Nothing
End Sub
PowerPoint code to set the text of a TextBox, or other Shape, is:
ActivePresentation.Slides(1).Shapes(3).TextFrame.TextRange _
= "Hello there"
I want to be able to click into a text field on a slide and then click an import button on a custom menu. I then select one of the text files in the dialog and that imports the text into the area I have specified.
' CYA
If Not ActiveWindow.Selection.Type = ppSelectionText Then
MsgBox "Select some text first"
Exit Sub
End if
' You might also want to allow for the case where the user has
' selected a rectangle or other shape rather than a text range.
' You could add the text to the shape as well.
With ActiveWindow.Selection.TextRange
.TextFrame.Text = "Text you've read from the chosen file"
End With