Preserving powerpoint/excel property data after converting to pptx/xlsx - excel

I have vba code to convert a ppt to pptx file, but how do I preserve the file properties (author/created date, modified date, etc)? Here is the vba code that converts the, in this case .ppt file, to a pptx file.
Sub BatchSave()
' Opens each PPT in the target folder and saves as PowerPoint 2007/2010 (.pptx) format
Dim sFolder As String
Dim sPresentationName As String
Dim oPresentation As Presentation
Dim bidpList As Collection
' Select the folder:
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
sFolder = fDialog.SelectedItems.Item(1)
If Right(sFolder, 1) <> "\" Then sFolder = sFolder + "\"
End With
' Make sure the folder name has a trailing backslash
If Right$(sFolder, 1) <> "\" Then
sFolder = sFolder & "\"
End If
' Are there PPT files there?
If Len(Dir$(sFolder & "*.PPT")) = 0 Then
MsgBox "Bad folder name or no PPT files in folder."
Exit Sub
End If
' Open and save the presentations
sPresentationName = Dir$(sFolder & "*.PPT")
While sPresentationName <> ""
Set oPresentation = Presentations.Open(sFolder & sPresentationName, , ,
False)
Call oPresentation.SaveAs(sFolder & sPresentationName & "x")
oPresentation.Close
Wend
MsgBox "DONE"
End Sub

Declaring object variables for your two presentations will simplify the code a bit, and then you can do something along these lines:
Dim oPres As Presentation
Dim oCopyPres As Presentation
Dim x As Long
Set oPres = ActivePresentation
ActivePresentation.SaveCopyAs "c:\temp\test.pptx"
Set oCopyPres = Presentations.Open("c:\temp\test.pptx")
On Error Resume Next
For x = 1 To oPres.BuiltInDocumentProperties.Count
oCopyPres.BuiltInDocumentProperties(x).Name = oPres.BuiltInDocumentProperties(x).Name
oCopyPres.BuiltInDocumentProperties(x).Value = oPres.BuiltInDocumentProperties(x).Value
Next
You'll want to modify this to set WithWindow false and to use variables as file names, but you're already doing that in the code you have. It should be simple enough to fold in a modified version of the code above.

Related

How to search for latest file in folder and if not found then open dialog box with restrictions?

The goal is to combine two functions or make them compatible with each other. There is errors when it comes to the part when the path of the chosen file is not refer to in the same manner as the path of the found file within the loop if available in the folder.
I get an error. See "HERE IS WHERE I GET THE ERROR" at
Dim closedBook As Workbook: Set closedBook = Workbooks.Open(sFilePath)
'main code that run is doing something like search for file within folder,
'loop and get the latest file and generates a path and name for next
'function which is to copy a sheet from the found file over to the main
'workbook and so.
'What I'm trying to to is to build a failsafe, lets say file is not pushed
'or placed whin this predestinated folder, then instead of doing nothing,
'dialog box opens up and files gets chosen instead.
Option Explicit
Sub ImportAndFormatData()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Const sFolderPath As String = "C:\Temp\"
'Search for newest file
Dim sFileName As String: sFileName = Dir(sFolderPath & "_pr11*.xlsx")
If Len(sFileName) = 0 Then Call OpenDialogBox
Dim cuDate As Date, sFileDate As Date, cuPath As String, sFilePath As String
Do Until Len(sFileName) = 0
cuPath = sFolderPath & sFileName
cuDate = FileDateTime(cuPath)
'Debug.Print "Current: " & cuDate & " " & cuPath ' print current
If cuDate > sFileDate Then
sFileDate = cuDate
sFilePath = cuPath
End If
sFileName = Dir
Loop
'Debug.Print "Result: " & sFileDate & " " & sFilePath ' print result
'Open newest file - HERE IS WHERE I GET THE ERROR
Dim closedBook As Workbook: Set closedBook = Workbooks.Open(sFilePath)
closedBook.Sheets("Analyse").Copy After:=ThisWorkbook.Sheets("PR11_P3")
closedBook.Close SaveChanges:=False
'code dose not end here but that part don't need to be included here since
'its just formatting
End Sub
In OpenDialogBox, I'm tying to enforce a specific title (only this file/report is correct source for the entire code or rather rest of the code).
See "GIVES ERROR DOSENT WORK" at
.Filters.Add "Excel filer", "_pr11*.xlsx?", 1
Sub OpenDialogBox()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Title = "Välj valfri PR11"
.Filters.Add "Excel filer", "_pr11*.xlsx?", 1 'GIVES ERROR DOSENT WORK
.AllowMultiSelect = False
If .Show = True Then
Debug.Print .SelectedItems(1)
Debug.Print Dir(.SelectedItems(1))
End If
End With
End Sub
This combines both the Dir() and FileDialog approaches:
Sub ImportAndFormatData()
Dim fSelected As String, wb As Workbook
fSelected = InputFile()
If Len(fSelected) > 0 Then
Set wb = Workbooks.Open(fSelected)
wb.Sheets("Analyse").Copy After:=ThisWorkbook.Sheets("PR11_P3")
wb.Close False
End If
End Sub
Function InputFile() As String
Const SRC_FOLDER As String = "C:\Temp\"
Dim f, fSelected As String, latestDate As Date, fdt
f = Dir(SRC_FOLDER & "*_pr11*.xlsx") 'first check the configured folder for a match
If Len(f) > 0 Then
'found matching file at specified path: loop for the newest file
Do While Len(f) > 0
fdt = FileDateTime(SRC_FOLDER & f)
If fdt > latestDate Then
fSelected = SRC_FOLDER & f
latestDate = fdt
End If
f = Dir()
Loop
InputFile = fSelected
Else
'no match at specified path - allow user selection
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Title = "Välj valfri PR11"
.Filters.Add "Excel filer", "*.xlsx" 'filter only allows extension: no filename wildcards...
.AllowMultiSelect = False
If .Show Then InputFile = .SelectedItems(1)
End With
End If
End Function

Select a previous file in a folder and copy it to a new one

I need to do the following:
Allow the user to select any number of files, in any format, and copy them to a new folder.
Create the destination folder if it doesn't exist. In this case, the folder name should be given by the content of the C2 & C3 cells (Range("C2").Value & Range("C3").Text & "\").
Private Sub CommandButton4_Click()
Dim strDirname As String
Dim strDefpath As String
Dim strPathname As String
Dim strFilename As String
Dim FSO
Dim sFile As FileDialog
Dim sSFolder As String
Dim sDFolder As String
strDirname = Range("C2").Value & Range("C3").Text
MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename
Set sFile = Application.FileDialog(msoFileDialogOpen)
sDFolder = strDirname & "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set FSO = New FileSystemObject
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
If Not .Show Then Exit Sub
Set xFolder = FSO.GetFolder(.SelectedItems(1))
For Each xFile In xFolder.Files
On Error Resume Next
xRow = Application.Match(xFile.Name, Range("A:A"), 0)
On Error GoTo 0
Next
End With
End Sub
I know the error is here...
Set xFolder = FSO.GetFolder(.SelectedItems(1))
...because I'm asking it to get a file, not a folder.
It is not very clear to me what you are trying to do but, if you intend to select a folder, you have to use it
Application.FileDialog (msoFileDialogFolderPicker)
instead of
Application.FileDialog (msoFileDialogFilePicker)
Your posted code shows so little resemblance to what you Q asks for, I've disregarded it.
This code follows the description. You may need to alter certain details to fully match your needs
Sub Demo()
Dim FilePicker As FileDialog
Dim DefaultPath As String
Dim DestinationFolderName As String
Dim SelectedFile As Variant
Dim DestinationFolder As Folder
Dim FSO As FileSystemObject
DefaultPath = "C:\Data" ' <~~ update to suit, or get it from somewhere else
' Validate Default Path
If Right$(DefaultPath, 1) <> Application.PathSeparator Then
DefaultPath = DefaultPath & Application.PathSeparator
End If
If Not FSO.FolderExists(DefaultPath) Then Exit Sub
' Get Destination Folder, add trailing \ if required
DestinationFolderName = Range("C2").Value & Range("C3").Value
If Right$(DestinationFolderName, 1) <> Application.PathSeparator Then
DestinationFolderName = DestinationFolderName & Application.PathSeparator
End If
Set FSO = New FileSystemObject
' Get reference to Destination folder, create it if required
If FSO.FolderExists(DefaultPath & DestinationFolderName) Then
Set DestinationFolder = FSO.GetFolder(DefaultPath & DestinationFolderName)
Else
Set DestinationFolder = FSO.CreateFolder(DefaultPath & DestinationFolderName)
End If
' File Selection Dialog
Set FilePicker = Application.FileDialog(msoFileDialogFilePicker)
With FilePicker
.AllowMultiSelect = True ' allow user to select multiple files
.InitialFileName = DefaultPath ' set initial folder for dialog
If .Show = False Then Exit Sub ' check if user cancels
For Each SelectedFile In .SelectedItems ' loop over selected files
If SelectedFile Like DefaultPath & "*" Then 'Optional: disallow browsing higher than default folder
FSO.CopyFile SelectedFile, DefaultPath & DestinationFolderName, True ' Copy file, overwrite is it exists
End If
Next
End With
End Sub

VBA userform to copy pdfs from selected folder locations

We import a CSV file into excel from Creo, this is our Bill of materials, We create the drawing PDF's and DXF's and save them in two 'MASTER' folders. When issuing the drawings to a manufacturer we must copy every individual drawing to a separate folder before sending.
The solution I am working on is to use a userform to select the 'copyfrom' location and 'copyto' location, on the 'run' command button, a sub should copy the files across.
I have the used the copy code by entering the folder locations in the Sub routine, but i need to allow other users to choose other files. The userform is adding the folder locations to the specific textboxes, but the next sub routine to copy the pdfs will not work.
I think it may be the textbox value is not recorded?
As a side I would also like to return the number of moved PDF's as part of the message in the Message box once the routine has completed. This may be different to the number of used cells in column B
The part number of the drawing will always be in column B
I haven't created the DXF option yet, but it will be very similar to the PDF one if i can get it to work
Any and all help much appreciated.
Private Sub cmdclose_Click()
Unload Me
End Sub
Private Sub copyfromcmd_Click()
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
'.InitialFileName = Application.GetSaveAsFilename()
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
copyfromtb.Value = sItem
Set fldr = Nothing
End Sub
Private Sub copytocmd_Click()
Dim fldr As FileDialog
Dim sItem2 As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
'.InitialFileName = Application.GetSaveAsFilename()
If .Show <> -1 Then GoTo NextCode
sItem2 = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem2
copytotb.Value = sItem2
Set fldr = Nothing
End Sub
Private Sub runcmd_Click()
Dim R As Range
Dim SourcePath As String, DestPath As String, FName As String
'Setup source and dest path (Note: must have a trailing backslash!)
SourcePath = Me.copyfromtb.Value
DestPath = Me.copytotb.Value
'Visit each used cell in column B
For Each R In Range("B1", Range("B" & Rows.Count).End(xlUp))
'Search the file with the file mask from the cell (Note: can contain wildcards like *.xls)
FName = Dir(SourcePath & R.Value & ".pdf")
'Loop while files found
Do While FName <> ""
'Copy the file
FileCopy SourcePath & FName, DestPath & FName
'Search the next file
FName = Dir()
Loop
Next
MsgBox ("PDF's Copied")
End Sub
Expected Results:
When the Copy Files command button is clicked, the pdf files from part numbers listed in column B will be copied from the first folder location to the second folder location.
If the entries are blank a message should appear which will request folder location are selected
Once the PDF's have been moved a message should appear to tell the user the number of files which have been copied.
Actual Results:
The folder location is being entered into the required textbox, but the PDF's are not being copied over
try this
dim counter as integer
counter = 0
'Visit each used cell in column B
For Each R In Range("B1", Range("B" & Rows.Count).End(xlUp))
'Search the file with the file mask from the cell (Note: can contain wildcards like *.xls)
FName = Dir(SourcePath & R.Value & ".pdf")
'Loop while files found
Do While FName <> ""
counter = counter + 1
'Copy the file
FileCopy SourcePath & FName, DestPath & FName
'Search the next file
FName = Dir()
Loop
Next
MsgBox (counter & " PDF's Copied")
good luck
I just realized my error
I need to add the trailing backslash!
SourcePath = Me.copyfromtb.Value
DestPath = Me.copytotb.Value
Changed to
SourcePath = copyfromtb.Value & "\"
DestPath = copytotb.Value & "\"
Still having issues with counting the number of moved files and adding that value to the message box at the end

excel vba change txt file name (remove time)

How do I programmatically change the file name of a .txt using excel vba, I need a script where it will go through a folder which consists of txt files and remove time from its filename.
Original Filename: ABC_ABCDE_ABCD_YYYYMMDDTTTTTT.txt
New Filename: ABC_ABCDE_ABCD_YYYYMMDD.txt
Thank you in advance
Mike
As per My understanding of your question, I write a code which asks a user to select the folder and rename ".txt" file as per requirements, you may be add an additional code of line for perfect work
'call sub LoopThroughFiles
'this sub is loop every file and rename it
Sub LoopThroughFiles()
Dim txtfile As String, folderPath As String
Dim newName As String
folderPath = GetFolder()
txtfile = Dir(folderPath & "\" & "*.txt")
While txtfile <> ""
If checkFormat(txtfile) = True Then
newName = Left(txtfile, 23) & ".txt"
On Error Resume Next
'rename file is done here
If Not txtfile = "" Then Name (folderPath + "\" + txtfile) As (folderPath + "\" + newName)
On Error GoTo 0
End If
txtfile = Dir
Wend
End Sub
'this function is for check format of file
'you may edit it as per your requirment
Function checkFormat(str As String) As Boolean
checkFormat = False
If Len(str) = 33 And Mid(str, 4, 1) = "_" Then
checkFormat = True
End If
End Function
'this function for select folder path
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Before use this code please make an additional copy of your file in case some error you have a backup...
Hope This help

Export Pictures Excel VBA in original resolution

This solution: Export Pictures Excel VBA
Works just fine, but it's using a chart method that's being resized to the images inside the table to "screenshot" them(in my case even including the table borders), not actually exporting the images themselves.
When I get the images by converting the excel table to a html file, they even come in better resolution in the folder.
Is there a way to get the images themselves, with their original resolution instead using VBA(obviously I don't just need the pictures, otherwise I'd be content with the html conversion method)?
What I mean can be seen here: http://i.imgur.com/OUX9Iji.png The picture on the left is what I get using the html conversion method, the picture on the right is what I get using the chart method. As you can see the chart method just screenshots the picture within the excel table, and I need it to get the original picture like on the left.
As the newer filetypes .xlsm and .xlsx is actually a zip file, it's possible to have the workbook save a copy of itself and change the extension from .xlsm to .zip. From there, it can look inside the zip's xl/media folder and copy out the actual image files which will include metadata, etc.
For my purposes, since it changes the image filename (not filetype) inside the zip, I'm working on how to be more specific about renaming the image files based on workbook content (i.e., their placement in the workbook) as I copy them out for the user.
But yes, screenshots are not nearly as good as the real files and this method does it. This sub took me quite some time to write but I'm sure will be used by many!
Private Sub ExtractAllPhotosFromFile()
Dim oApp As Object, FileNameFolder As Variant, DestPath As String
Dim num As Long, sZipFile As String, sFolderName As String ', iPos As Long, iLen As Long
Dim vFileNameZip As Variant, strTmpFileNameZip As String, strTmpFileNameFld As String, vFileNameFld As Variant
Dim FSO As Object, strTmpName As String, strDestFolderPath As String
On Error GoTo EarlyExit
strTmpName = "TempCopy"
' / Check requirements before beginning / /
'File must be .xlsm
If Right(ActiveWorkbook.FullName, 5) <> ".xlsm" Then
MsgBox ("This function cannot be completed because the filetype of this workbook has been changed from its original filetype of .xlsm" _
& Chr(10) & Chr(10) & "Save as a Microsoft Excel Macro-Enabled Workbook (*.xlsm) and try again.")
Exit Sub
End If
'User to choose destination folder
strDestFolderPath = BrowseFolder("Choose a folder to Extract the Photos into", ActiveWorkbook.Path, msoFileDialogViewDetails)
If strDestFolderPath = "" Then Exit Sub
If Right(strDestFolderPath, 1) <> "\" Then strDestFolderPath = strDestFolderPath & "\"
'Prepare vars and Tmp destination
strTmpFileNameZip = Environ("Temp") & "\" & strTmpName & ".zip"
strTmpFileNameFld = Environ("Temp") & "\" & strTmpName
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(strTmpFileNameFld) Then
FSO.deletefolder strTmpFileNameFld
End If
If FSO.FileExists(strTmpFileNameZip) Then
Kill strTmpFileNameZip
End If
Set FSO = Nothing
'Save current workbook to Temp dir as a zip file
Application.StatusBar = "Saving copy of file to temp location as a zip"
ActiveWorkbook.SaveCopyAs Filename:=strTmpFileNameZip
'Create a folder for the contents of the zip file
strTmpFileNameFld = strTmpFileNameFld & "\"
MkDir strTmpFileNameFld
'Pass String folder path variables to Variant type variables
vFileNameFld = strTmpFileNameFld
vFileNameZip = strTmpFileNameZip
'Count files/folders inside the zip
Set oApp = CreateObject("Shell.Application")
num = oApp.Namespace(vFileNameZip).Items.Count
If num = 0 Then 'Empty Zip
GoTo EarlyExit 'Skip if somehow is empty as will cause errors
Else
'zip has files, copy out of zip into tmp folder
Application.StatusBar = "Copying items from temp zip file to folder"
oApp.Namespace(vFileNameFld).CopyHere oApp.Namespace(vFileNameZip).Items
End If
'Copy the image files from the tmp folder to the Dest folder
Application.StatusBar = "Moving Photos to selected folder"
strTmpFileNameFld = strTmpFileNameFld & "xl\media\"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.jpeg"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.jpg"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.png"
CopyFiles strTmpFileNameFld, strDestFolderPath, "*.bmp"
'Function complete, cleanup
'Prepare vars and Tmp destination
Application.StatusBar = "Cleaning up"
strTmpFileNameZip = Environ("Temp") & "\" & strTmpName & ".zip"
strTmpFileNameFld = Environ("Temp") & "\" & strTmpName
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(strTmpFileNameFld) Then
FSO.deletefolder strTmpFileNameFld
End If
If FSO.FileExists(strTmpFileNameZip) Then
Kill strTmpFileNameZip
End If
Application.StatusBar = False
MsgBox ("Photos extracted into the folder: " & strDestFolderPath)
Set oApp = Nothing
Set FSO = Nothing
Exit Sub
EarlyExit:
Application.StatusBar = False
Set oApp = Nothing
Set FSO = Nothing
MsgBox ("This function could not be completed.")
End Sub
I moved the copy to it's own sub to save space on how I filtered filetypes, not the best way but works
Private Sub CopyFiles(strFromPath As String, strToPath As String, FileExt As String)
'As function to get multiple filetypes
Dim FSO As Object
If Right(strFromPath, 1) <> "\" Then strFromPath = strFromPath & "\"
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.MoveFile Source:=strFromPath & FileExt, Destination:=strToPath
Set FSO = Nothing
On Error GoTo 0
End Sub
I found this stable function online to select a destination folder, was actually difficult to find a good solid one.
Private Function BrowseFolder(Title As String, Optional InitialFolder As String = vbNullString, _
Optional InitialView As Office.MsoFileDialogView = msoFileDialogViewList) As String
'Used for the Extract Photos function
Dim V As Variant
Dim InitFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Title
.InitialView = InitialView
If Len(InitialFolder) > 0 Then
If Dir(InitialFolder, vbDirectory) <> vbNullString Then
InitFolder = InitialFolder
If Right(InitFolder, 1) <> "\" Then
InitFolder = InitFolder & "\"
End If
.InitialFileName = InitFolder
End If
End If
.Show
On Error Resume Next
Err.Clear
V = .SelectedItems(1)
If Err.Number <> 0 Then
V = vbNullString
End If
End With
BrowseFolder = CStr(V)
End Function

Categories

Resources