Having difficulty getting multi unzip to work with a custom file name. Below is the code, any suggestions greatly appreciated. Have tried GetOpenFilename with no success. The point of where the error occurs is marked below:
Option Explicit
Sub UnzipSelectFiles()
Dim xFileSelect As Variant
Dim xSelectedItem As Variant
Dim xFilePath As String
Dim strDate As String
Dim xFileNameFolder As Variant
Dim xApp As Object
' Set xFileSelect = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=True)
Set xFileSelect = Application.FileDialog(msoFileDialogOpen)
With xFileSelect
.AllowMultiSelect = True
.Title = "Select ZIP Compressed Files"
.Filters.Clear
.Filters.Add "Zip Compressed Files", "*.zip"
.InitialView = msoFileDialogViewDetails
If xFileSelect.Show = -1 Then
For Each xSelectedItem In xFileSelect.SelectedItems
xFilePath = xSelectedItem
strDate = Format(Now, " mmm-dd-yyyy hh_mm_ss AMPM")
xFileNameFolder = xFilePath & strDate & "\"
Debug.Print xFileNameFolder
MkDir xFileNameFolder
Set xApp = CreateObject("Shell.Application")
'~~~~>
'Runtime error #91 Object variable or with block variable not set
xApp.Namespace(xFileNameFolder).CopyHere xApp.Namespace(xFileSelect).Items
'~~~~>
Next xSelectedItem
End If
End With
Set xApp = Nothing
End Sub
Related
Trying to set this code found Here to work recursively down through my folders. at the minute I have this
Public Sub addPassword()
Dim FSO As Object
Dim strFileName As String
Dim strFilePath As String
Dim folder As Object, subfolder As Object
Dim doc As Object
Dim oDoc As Document
Dim PWD As String
Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "G:\Test Data"
Set folder = FSO.GetFolder(folderPath)
PWD = "FooBar"
For Each doc In folder.Files
strFilePath = "G:\Test Data\"
strFileName = Dir$(strFilePath & "*.doc*")
Set oDoc = Documents.Open( _
FileName:=strFilePath & strFileName, _
PasswordDocument:="FooBar")
oDoc.Saved = False
oDoc.SaveAs2 FileName:=strFilePath & strFileName, _
Password:=PWD
oDoc.Close
Set oDoc = Nothing
Next
For Each subfolder In folder.SubFolders
For Each doc In subfolder.Files
strFilePath = "G:\Test Data\"
strFileName = Dir$(strFilePath & "*.doc*")
Set oDoc = Documents.Open( _
FileName:=strFilePath & strFileName, _
PasswordDocument:="FooBar")
oDoc.Saved = False
oDoc.SaveAs2 FileName:=strFilePath & strFileName, _
Password:=PWD
oDoc.Close
Set oDoc = Nothing
Next
Next
End Sub
Absolute Novice to vba so trying to use some limited python experience to set this up recursively. I can see every file open up in the side but when I go to check on them non of them have a password set
Any help would be appreciated thank you
I'm trying to get this macro to save my powerpoint slides as pdf in new folder, that is not created beforehand. Problem is that it seems like MkDir doesn't create the root folder, but rather folder inside folder. So if I want to create brand new folder in C:\ it doesn't do it, "Run time error '76' Path not found" occurs.
Sub Creating_Folder()
Dim timestamp As Date
Dim PR As PrintRanges
Dim lngLast As Long
Dim lngFirst As Long
Dim savePath As String
Dim PrintPDF As Integer
Dim name As String
Dim originalHides() As Long
Dim slidesToPrint() As Variant
Dim i As Variant
Dim folderPath As String
Dim strPath As String
Dim folder As String
strPath = "C:\Powerpoint2\test_file\"
If Not FolderExists(strPath) Then
FolderCreate strPath
End If
'Create a folder if it does not already exist, if it does, do nothing
'folderPath = "\\?\C:\Powerpoint\new_folder2"
'Check if the folder exists
'If Dir(folderPath, vbDirectory) = "" Then
'Folder does not exist, so create it
' MkDir folderPath
'End If
timestamp = Now()
With ActivePresentation
name = .Slides(2).Shapes("TextBox1").OLEFormat.Object.Text
savePath = strPath & Format(timestamp, "yyyymmdd-hhnn") & " - " & name & ".pdf"
lngLast = .Slides.Count
.PrintOptions.Ranges.ClearAll
slidesToPrint = Array(2, lngLast)
ReDim originalHides(1 To lngLast)
For i = 1 To lngLast
originalHides(i) = .Slides(i).SlideShowTransition.Hidden
.Slides(i).SlideShowTransition.Hidden = -1
Next
For Each i In slidesToPrint()
.Slides(i).SlideShowTransition.Hidden = 0
Next
.ExportAsFixedFormat _
Path:=savePath, _
FixedFormatType:=ppFixedFormatTypePDF, _
Intent:=ppFixedFormatIntentScreen, _
FrameSlides:=msoTrue
For i = 1 To lngLast
.Slides(i).SlideShowTransition.Hidden = originalHides(i)
Next
End With
End Sub
Also added this to end
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim fso As New FileSystemObject
If fso.FolderExists(path) Then
Exit Function
Else
On Error GoTo DeadInTheWater
fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
Exit Function
End If
DeadInTheWater:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim fso As New FileSystemObject
If fso.FolderExists(path) Then FolderExists = True
End Function
How can I import a selected presentation from a particular folder?
Below are the code which I tried but it is importing all the presentations which are stored in a particular folder.
Sub Merge()
' After doing the merge, open presentation #1
' Then run this code:
Dim sPath As String
Dim cFileNames As New Collection
Dim sTemp As String
Dim x As Long
sPath = CurDir ' by default
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
sPath = InputBox("Path to PPT files (ex: c:\my documents\", _
"Where are the files?", sPath)
If sPath = "" Then
Exit Sub
End If
sTemp = Dir(sPath & "*.pptx")
While sTemp <> ""
With cFileNames
.Add (sPath & sTemp)
End With
sTemp = Dir
Wend
If cFileNames.Count > 1 Then
' open the first file
Presentations.Open (cFileNames(1))
' Insert the other files
For x = 2 To cFileNames.Count
Call ActivePresentation.Slides.InsertFromFile( _
cFileNames(x), _
ActivePresentation.Slides.Count)
Next
End If
End Sub
For example. I have 10 presentations in XYZ folder but want to import only four selected presentations.
This should do it:
Sub Merge()
Dim sPath As String
Dim dlgOpen As FileDialog
Dim x As Integer
Dim vrtSelectedItem As Variant
'Set path to current dirrectory
sPath = CurDir
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
'Set File Picker dialog
Set dlgOpen = Application.FileDialog(Type:=msoFileDialogFilePicker)
'Set initial path and view, set multiselect capability
With dlgOpen
.InitialFileName = sPath
.InitialView = msoFileDialogViewList
.AllowMultiSelect = True
'If user click on OK, insert selected files after last slide of current presentation
If .Show = -1 And .SelectedItems.Count > 0 Then
For x = 1 To .SelectedItems.Count
ActivePresentation.Slides.InsertFromFile .SelectedItems(x), ActivePresentation.Slides.Count
Next
Else
'User Cancelled
End If
End With
End Sub
Right now I import all the data and if I need to import it again it makes duplicates then I delete all the duplicates. I was wondering if there was a way to omit the duplicate records before importing.
Private Sub btnImport_Click()
Dim strFileName As String
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim strFile As String, strPath As String
Dim xmlDoc As New MSXML2.DOMDocument60, xslDoc As New MSXML2.DOMDocument60, newDoc As New MSXML2.DOMDocument60
Dim daoRST As DAO.Recordset:
Dim xdoc As DOMDocument60
Set daoRST = CurrentDb.OpenRecordset("XSLT"): Debug.Print daoRST.Fields("XSL_Load").Value:
xslDoc.loadXML daoRST.Fields("XSL_Load").Value
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.InitialFileName = "C:\Users\" & Environ("USERNAME") & "\Desktop\*.xml"
'On Error GoTo ErrorHandle
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
' INITIALIZE XML OBJECTS
Set xmlDoc = New MSXML2.DOMDocument60
Set newDoc = New MSXML2.DOMDocument60
' LOAD XML SOURCE
xmlDoc.Load vrtSelectedItem
' TRANSFORM SOURCE
xmlDoc.transformNodeToObject xslDoc, newDoc
newDoc.Save "C:\Users\" & Environ("USERNAME") & "\Desktop\temp.xml"
' APPEND TO TABLES
On Error Resume Next
''''''''''''''''''''''''Try something like this?
If xmlDoc.getElementsByTagName("ID") = rsR.Fields("ID").Value
Then Resume Next
Else
''''''''''''''''''''''''
Application.ImportXML "C:\Users\" & Environ("USERNAME") & "\Desktop\temp.xml", acAppendData
Next vrtSelectedItem
Set daoRST = Nothing
End If
End With
Set xmlDoc = Nothing
Set newDoc = Nothing
Set xslDoc = Nothing
End Sub
I have written a VBA routine for comparing docx files and saving the delta. I need to deactivate TrackFormatting in the delta but adding .trackFormatting = False does not do anything. In the compare method the CompareFormatting is false as well! How should I do this?
Sub ProduceDeltas()
Dim strFolderA As String
Dim strFolderB As String
Dim strFolderC As String
Dim strFileSpec As String
Dim strFileName As String
Dim objDocA As Word.Document
Dim objDocB As Word.Document
Dim objDocC As Word.Document
Dim dc As Word.Document
Dim FldrPickerInputA As FileDialog
Dim FldrPickerInputB As FileDialog
Dim FldrPickerOutput As FileDialog
Application.ScreenUpdating = False
Set FldrPickerInputA = Application.FileDialog(msoFileDialogFolderPicker)
Set FldrPickerInputB = Application.FileDialog(msoFileDialogFolderPicker)
Set FldrPickerOutput = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPickerInputA
.Title = "Choose first file: "
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
strFolderA = .SelectedItems(1) & "\"
End With
With FldrPickerInputB
.Title = "Choose second file: "
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
strFolderB = .SelectedItems(1) & "\"
End With
With FldrPickerOutput
.Title = "Choose output file: "
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
strFolderC = .SelectedItems(1) & "\"
End With
NextCode:
strFolderA = strFolderA
strFolderB = strFolderB
strFolderC = strFolderC
If strFolderA = "" Then GoTo ResetSettings
strFileSpec = "*.docx"
strFileName = Dir(strFolderA & strFileSpec)
Do While strFileName <> vbNullString
Set objDocA = Documents.Open(strFolderA & strFileName)
Set objDocB = Documents.Open(strFolderB & strFileName)
If objDocA.TablesOfContents.Count = 1 Then _
objDocA.TablesOfContents(1).Update
If objDocB.TablesOfContents.Count = 1 Then _
objDocB.TablesOfContents(1).Update
Set dc = Application.CompareDocuments(objDocA, objDocB, wdCompareDestinationNew, _
Granularity:=wdGranularityWordLevel, _
CompareFormatting:=False, RevisedAuthor:="IQTIG", CompareFootnotes:=False, CompareHeaders:=False)
dc.TrackFormatting = False
objDocA.Save
objDocB.Save
objDocA.Close
objDocB.Close
If dc.TablesOfContents.Count = 1 Then _
dc.TablesOfContents(1).Update
dc.SaveAs strFolderC & strFileName
dc.Close SaveChanges:=False
strFileName = Dir
Loop
Set objDocA = Nothing
Set objDocB = Nothing
ResetSettings:
Application.ScreenUpdating = True
End Sub
Which version of Word? On Word 2013, CompareFormatting:=False works for me.
One option is to accept (or reject) all formatting revisions after running the comparison. Before dc.SaveAs, insert the following:
dim oRevision as Revision
For Each oRevision In dc.StoryRanges(wdMainTextStory).Revisions
If (oRevision.Type<> wdRevisionInsert) and (oRevision.type <> wdRevisionDelete) then
oRevision.Accept ' or .Reject
End If
Next oRevision
(code modified from ExtractTrackedChangesToNewDoc by Lene Fredborg, supplied as-is with no warranty.)