I have upload.exe, which should be launched by the button in excel, but when I start from the button, I get an error:
method run of object iwshshell3 failed
My code
Sub upload()
Application.Calculation = xlCalculationManual
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim strProgramPath As String
Dim strProgramName As String
Dim strArgument As String
strProgramPath = "\upload.exe"
strProgramName = "upload.exe"
strArgument = Application.ActiveWorkbook.FullName
wsh.Run """" & strProgramPath & strProgramName & """ """ & strArgument & """", windowStyle, waitOnReturn
Application.Calculation = xlCalculationAutomatic
End Sub
The files in the folder are arranged as follows:
directory:
-upload.exe
-table.xlsm
...
Dim strProgramPath As String
Const ProgramName = "upload.exe"
Dim strArgument As String
'full path to program in workbook directory
strProgramPath = ActiveWorkbook.Path & Application.PathSeparator & ProgramName
strArgument = Application.ActiveWorkbook.FullName
wsh.Run """" & strProgramPath & """ """ & strArgument & """", _
windowStyle, waitOnReturn
...
Related
I have a code which can transfer the Excel files from one folder to another but i would like to update the code so that it can move all the files (.xml, .txt, .pdf, etc.) from one folder to another.
Sub MoveFiles()
Dim sourceFolderPath As String, destinationFolderPath As String
Dim FSO As Object, sourceFolder As Object, file As Object
Dim fileName As String, sourceFilePath As String, destinationFilePath As String
Application.ScreenUpdating = False
sourceFolderPath = "E:\Source"
destinationFolderPath = "E:\Destination"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set sourceFolder = FSO.GetFolder(sourceFolderPath)
For Each file In sourceFolder.Files
fileName = file.Name
If InStr(fileName, ".xlsx") Then ' Only xlsx files will be moved
sourceFilePath = file.Path
destinationFilePath = destinationFolderPath & "\" & fileName
FSO.MoveFile Source:=sourceFilePath, Destination:=destinationFilePath
End If ' If InStr(sourceFileName, ".xlsx") Then' Only xlsx files will be moved
Next
'Don't need set file to nothing because it is initialized in for each loop
'and after this loop is automatically set to Nothing
Set sourceFolder = Nothing
Set FSO = Nothing
End Sub
can you please help
Move Files Using MoveFile
You would get greater control of things by using CopyFile and DeleteFile instead of MoveFile.
Using Dir, FileCopy, and Kill, instead of the FileSystemObject object and its methods, would make it simpler and also faster.
Option Explicit
Sub MoveFilesTEST()
Const sFolderPath As String = "E:\Source"
Const dFolderPath As String = "E:\Destination"
Const FilePattern As String = "*.*"
MoveFiles sFolderPath, dFolderPath, FilePattern
End Sub
Sub MoveFiles( _
ByVal SourceFolderPath As String, _
ByVal DestinationFolderPath As String, _
Optional ByVal FilePattern As String = "*.*")
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(SourceFolderPath) Then
MsgBox "The source folder path '" & SourceFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
If Not fso.FolderExists(DestinationFolderPath) Then
MsgBox "The destination folder path '" & DestinationFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim apSep As String: apSep = Application.PathSeparator
Dim sPath As String: sPath = SourceFolderPath
If Left(sPath, 1) <> apSep Then sPath = sPath & apSep
Dim sFolder As Object: Set sFolder = fso.GetFolder(sPath)
If sFolder.Files.Count = 0 Then
MsgBox "There are no files in the source folder '" & sPath & "'.", _
vbExclamation
Exit Sub
End If
Dim dPath As String: dPath = DestinationFolderPath
If Left(dPath, 1) <> apSep Then dPath = dPath & apSep
Dim dFolder As Object: Set dFolder = fso.GetFolder(dPath)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sFile As Object
Dim dFilePath As String
Dim ErrNum As Long
Dim MovedCount As Long
Dim NotMovedCount As Long
For Each sFile In sFolder.Files
dFilePath = dPath & sFile.Name
If fso.FileExists(dFilePath) Then
dict(sFile.Path) = Empty
NotMovedCount = NotMovedCount + 1
Else
On Error Resume Next
fso.MoveFile sFile.Path, dFilePath
ErrNum = Err.Number
' e.g. 'Run-time error '70': Permission denied' e.g.
' when the file is open in Excel
On Error GoTo 0
If ErrNum = 0 Then
MovedCount = MovedCount + 1
Else
dict(sFile.Path) = Empty
NotMovedCount = NotMovedCount + 1
End If
End If
Next sFile
Dim Msg As String
Msg = "Files moved: " & MovedCount & "(" & NotMovedCount + MovedCount & ")"
If NotMovedCount > 0 Then
Msg = Msg & vbLf & "Files not moved:" & NotMovedCount & "(" _
& NotMovedCount + MovedCount & ")" & vbLf & vbLf _
& "The following files were not moved:" & vbLf _
& Join(dict.keys, vbLf)
End If
MsgBox Msg, IIf(NotMovedCount = 0, vbInformation, vbCritical)
End Sub
I'm trying to run a powershell command to unzip some files, but running in to some issues figuring out the correct syntax. The following doesn't error out, and even when I run the command in powershell itself it doesn't display an error (but also doesn't work). Does anyone know what I'm doing wrong?
Dim command As String: Set wsh = VBA.CreateObject("WScript.Shell")
Dim wsh As Object
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 7
Dim pdfPath As String
pdfPath = ThisWorkbook.Path & "\PDFTemp\"
command = "Powershell -Command" & Chr(32) & "{Expand-Archive -LiteralPath" & Chr(32) & _
"'" & frmMerge.txtBoxFile2.Value & "'" & Chr(32) & "-DestinationPath" & Chr(32) & "'" & pdfPath & "'" & "}"
wsh.Run command, windowStyle, waitOnReturn
Thanks so much for your help!
You can remove a lot of parts from that concatenation.
This worked for me (also adjusted the command a little):
Sub Unzipper()
Dim command As String, wsh As Object, waitOnReturn As Boolean, windowStyle As Integer
Dim pdfPath As String, zipPath As String
waitOnReturn = True
windowStyle = 7
zipPath = "C:\Tester\PDF_files.zip" 'frmMerge.txtBoxFile2.Value
pdfPath = "C:\Tester\PDFTemp\" 'ThisWorkbook.Path & "\PDFTemp\"
command = "Powershell Expand-Archive -LiteralPath " & _
"'" & zipPath & "' -DestinationPath '" & pdfPath & "'"
Set wsh = VBA.CreateObject("WScript.Shell")
wsh.Run command, windowStyle, waitOnReturn
End Sub
I'd like to copy all files with pdf as extension to a new folder (with name from a cell)
I've created below code:
Public Sub MyFileprojectTF()
Dim startPath As String
Dim myName As String
Dim SourceFileName As String, DestinFileName As String
Dim FSOFile As Object
Dim FSOFolder As Object
FolderName = "C:\Users\320105013\Desktop\DXR\"
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
Set FSOFolder = FSOLibrary.getfolder(FolderName)
Set FSOFile = FSOFolder.Files
Set fso = CreateObject("Scripting.Filesystemobject")
startPath = "C:\Users\320105013\Desktop\DXR Test files\"
myName = ActiveSheet.Range("B3").Text ' Change as required to cell holding the folder title
If myName = vbNullString Then myName = "Testing"
Dim folderPathWithName As String
folderPathWithName = startPath & Application.PathSeparator & myName
If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
Else
MsgBox "Folder already exists"
Exit Sub
End If
ActiveWorkbook.FollowHyperlink startPath & myName
SourceFileName = "C:\Users\320105013\Desktop\DXR\" & (FSOFile)
DestinFileName = startPath & myName & "\"
For Each FSOFile In FSOFile
If FSOFile Like "*.pdf" Then
FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName
End If
Next
End Sub
I get the following error:
"Wrong number of arguments"
on FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName.
You are using FSOFile twice as 2 different variables... see the 3 comments I added.
Public Sub MyFileprojectTF()
Dim startPath As String
Dim myName As String
Dim SourceFileName As String, DestinFileName As String
Dim FSOFile As Object
Dim FSOFiles As Object ' ADD THIS
Dim FSOFolder As Object
FolderName = "C:\Users\320105013\Desktop\DXR\"
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
Set FSOFolder = FSOLibrary.getfolder(FolderName)
Set FSOFiles = FSOFolder.Files ' CHANGE THIS
Set fso = CreateObject("Scripting.Filesystemobject")
startPath = "C:\Users\320105013\Desktop\DXR Test files\"
myName = ActiveSheet.Range("B3").Text ' Change as required to cell holding the folder title
If myName = vbNullString Then myName = "Testing"
Dim folderPathWithName As String
folderPathWithName = startPath & Application.PathSeparator & myName
If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
Else
MsgBox "Folder already exists"
Exit Sub
End If
ActiveWorkbook.FollowHyperlink startPath & myName
SourceFileName = "C:\Users\320105013\Desktop\DXR\" & (FSOFile)
DestinFileName = startPath & myName & "\"
For Each FSOFile In FSOFiles ' CHANGE THIS
If FSOFile Like "*.pdf" Then
FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName
End If
Next
End Sub
Okay I've changed it to below
but get error message "object doesn't support..." on line FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName
Public Sub MyFileprojectTF()
Dim startPath As String
Dim myName As String
Dim SourceFileName As String, DestinFileName As String
Dim FSOFile As Object
Dim FSOFiles As Object
Dim FSOFolder As Object
FolderName = "C:\Users\320105013\Desktop\DXR\"
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
Set FSOFolder = FSOLibrary.getfolder(FolderName)
Set FSOFiles = FSOFolder.Files
Set fso = CreateObject("Scripting.Filesystemobject")
startPath = "C:\Users\320105013\Desktop\DXR Test files\"
myName = ActiveSheet.Range("B3").Text ' Change as required to cell holding the folder title
If myName = vbNullString Then myName = "Testing"
Dim folderPathWithName As String
folderPathWithName = startPath & Application.PathSeparator & myName
If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
Else
MsgBox "Folder already exists"
Exit Sub
End If
ActiveWorkbook.FollowHyperlink startPath & myName
SourceFileName = "C:\Users\320105013\Desktop\DXR\"
DestinFileName = startPath & myName & "\"
For Each FSOFile In FSOFiles
If FSOFile Like "*.pdf" Then
FSOFile.MoveFile Source:=SourceFileName, Destination:=DestinFileName
End If
Next
End Sub
Move Files to a Folder
Using the MoveFile method is the simplest way to go.
The Code
Option Explicit
Public Sub MyFileprojectTF()
Const sFolderPath As String = "C:\Users\320105013\Desktop\DXR\"
Const dStartPath As String = "C:\Users\320105013\Desktop\DXR Test files\"
Const ExtensionPattern As String = "*.pdf"
Dim pSep As String: pSep = Application.PathSeparator
Dim wb As Workbook: Set wb = ThisWorkbook
Dim dFolderName As String
Dim dFolderPath As String
dFolderName = wb.Worksheets("Sheet1").Range("B3").Value
If dFolderName = vbNullString Then
dFolderName = "Testing"
End If
dFolderPath = dStartPath & pSep & dFolderName
If Dir(dFolderPath, vbDirectory) = vbNullString Then
If Dir(sFolderPath & pSep & ExtensionPattern) <> vbNullString Then
MkDir dFolderPath
With CreateObject("Scripting.FileSystemObject")
.MoveFile Source:=sFolderPath & pSep & ExtensionPattern, _
Destination:=dFolderPath
wb.FollowHyperlink dFolderPath
End With
Else
MsgBox "No matching files found in folder '" & sFolderPath & "'."
End If
Else
MsgBox "Folder '" & dFolderPath & "' already exists"
End If
End Sub
My code copy the open workbook and then renames the copied one with the month of analysis, but I need to save all the analysis of the month doing a sequence at the end of the file name. I tried some simple loops and it doesn't work.
Sub NewReport()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim dateStr As String
Dim myDate As Date
Dim i As Integer
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set Wb1 = ActiveWorkbook
myDate = Date
dateStr = Format(myDate, "mmm_yyyy")
Set Wb2 = Application.Workbooks.Add(1)
Wb1.Sheets(Array(Wb1.Sheets(1).Name)).Copy Before:=Wb2.Sheets(1)
Wb2.Sheets(Wb2.Sheets.Count).Delete
On Error GoTo Fim
'Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr, FileFormat:=51
'Wb2.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
Fim:
Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_", FileFormat:=51
End Sub
UPDATE
I tried put an "i + 1" and the macro runs until version 2! But at the 3rd I have the same error because the "i" is reseted. I can do the bit at the end for like 50 times assuming that the person don't run the macro 50 times haha. Any suggestions?
Sub NewReport()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim dateStr As String
Dim myDate As Date
i = 1
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Set Wb1 = ActiveWorkbook
myDate = Date
dateStr = Format(myDate, "mmm_yyyy")
Set Wb2 = Application.Workbooks.Add(1)
Wb1.Sheets(Array(Wb1.Sheets(1).Name)).Copy Before:=Wb2.Sheets(1)
Wb2.Sheets(Wb2.Sheets.Count).Delete
On Error GoTo Fim
Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i, FileFormat:=51
'Wb2.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
End With
Fim:
i = i + 1
Wb2.SaveAs Filename:="\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\" & "Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i, FileFormat:=51
End Sub
So, the question is how to get from something like:
\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_21
an incremented value at the end like this one:
\\BRGABS001\g_supc\P.C.P\07- Comum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_22
This could be carried out through the following steps:
Take the string and split it by _.
Increment the last part of the string with 1.
Public Sub TestMe()
Dim fileName As String
Dim dateStr As String: dateStr = "probablySomeString"
Dim i As Long: i = 21
fileName = "\\BRGABS001\g_supc\P.C.P\07- Comum\" & _
"Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i
Debug.Print fileName
Debug.Print Increment(fileName)
End Sub
Public Function Increment(fileName As String) As String
Dim myResult As String
Dim newValue As Long
Dim myArr As Variant
newValue = Split(fileName, "_")(UBound(Split(fileName, "_"))) + 1
myArr = Split(fileName, "_")
myArr(UBound(Split(fileName, "_"))) = newValue
Increment = Join(myArr, "_")
End Function
And if the initial file looks like this:
~omum\Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT_probablySomeString_21.xlsx then
the following sample works:
Public Sub TestMe()
Dim fileName As String
Dim dateStr As String: dateStr = "probablySomeString"
Dim i As Long: i = 21
fileName = "\\BRGABS001\g_supc\P.C.P\07- Comum\" & _
"Natalia\3_TESTE_MACRO\Phase_IN_Phase_OUT" & "_" & dateStr & "_" & i & ".xlsx"
Debug.Print fileName
Debug.Print Increment(fileName)
End Sub
Public Function Increment(fileName As String) As String
Dim myResult As String
Dim newValue As Long
Dim myArr As Variant
newValue = Split(Split(fileName, "_")(UBound(Split(fileName, "_"))), ".")(0) + 1
myArr = Split(fileName, "_")
myArr(UBound(Split(fileName, "_"))) = newValue
Increment = Join(myArr, "_")
Increment = Increment & ".xslx"
End Function
After a deep research on google, I found a code and adapt to my situation. It doesn't let to choose the way to save, it's just in the same Folder, but that's ok to me. Credits on the code (I have just put the date at the name):
Function FileExist(FilePath As String) As Boolean
'PURPOSE: Test to see if a file exists or not
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault
'RESOURCE: http://www.rondebruin.nl/win/s9/win003.htm
Dim TestStr As String
'Test File Path (ie "C:\Users\Chris\Desktop\Test\book1.xlsm")
On Error Resume Next
TestStr = Dir(FilePath)
On Error GoTo 0
'Determine if File exists
If TestStr = "" Then
FileExist = False
Else
FileExist = True
End If
End Function
Sub SaveNewVersion_Excel()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault
Dim FolderPath As String
Dim myPath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
Dim dateStr As String
myDate = Date
dateStr = Format(myDate, "mmm_yyyy")
TestStr = ""
Saved = False
x = 2
'Version Indicator (change to liking)
VersionExt = "_" & dateStr & "_Rev"
'Pull info about file
On Error GoTo NotSavedYet
myPath = ActiveWorkbook.FullName
myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
FolderPath = Left(myPath, InStrRev(myPath, "\"))
SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
On Error GoTo 0
'Determine Base File Name
If InStr(1, myFileName, VersionExt) > 1 Then
myArray = Split(myFileName, VersionExt)
SaveName = myArray(0)
Else
SaveName = myFileName
End If
'Test to see if file name already exists
If FileExist(FolderPath & SaveName & SaveExt) = False Then
ActiveWorkbook.SaveAs FolderPath & SaveName & SaveExt
Exit Sub
End If
'Need a new version made
Do While Saved = False
If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
ActiveWorkbook.SaveAs FolderPath & SaveName & VersionExt & x & SaveExt
Saved = True
Else
x = x + 1
End If
Loop
'New version saved
MsgBox "New file version saved (version " & x & ")"
Exit Sub
'Error Handler
NotSavedYet:
MsgBox "This file has not been initially saved. " & _
"Cannot save a new version!", vbCritical, "Not Saved To Computer"
End Sub
In the document I have a button to do a save as, this function takes a path and creates the filename based off a cell and the date. This has been working fine until a path came up that has a period in it, it will locate the path correctly but is no longer filling in the filename.
Sub SaveWorkbookAsNewFile()
Dim NewFileType As String
Dim NewFile As String
Dim newfilename As String
Dim cellname As String
Dim monthnum As String
Dim monthtxt As String
Dim daynum As String
Dim yearnum As String
Dim yeartxt As String
Dim SaveArea As String
Dim q As Long
If Worksheets.Count <= 6 Then MsgBox "You must run the report before saving it.", vbInformation, "Save Error": End
SaveArea = Sheet1.Range("K12")
cellname = Sheet1.Range("K20")
'********************************************************************
Dim objFSO As Object, objFolder As Object, objSubFolder As Object
Dim varDirectory As Variant
Dim flag As Boolean
Dim strDirectory As String, goodfolder As String
Dim NumMonth As Integer
NumMonth = 0
q = 0
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(SaveArea)
NumMonth = Month(Date)
For Each objSubFolder In objFolder.subfolders
If InStr(1, UCase(objSubFolder.Name), UCase(MonthName(NumMonth, True)), vbTextCompare) > 1 Then goodfolder = objSubFolder.Name: Exit For
Next objSubFolder
If Not goodfolder = "" Then SaveArea = SaveArea & goodfolder & "\"
'********************************************************************
monthnum = Month(Date)
monthtxt = UCase(MonthName(monthnum, True))
daynum = Day(Date)
yearnum = Year(Date)
yeartxt = Right(yearnum, 2)
newfilename = cellname & "-" & monthtxt & "-" & daynum & "-" & yeartxt
Application.ScreenUpdating = False ' Prevents screen refreshing.
NewFileType = "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm," & _
"All files (*.*), *.*"
NewFile = Application.GetSaveAsFilename( _
InitialFileName:=SaveArea & newfilename, _
fileFilter:=NewFileType)
If NewFile <> "" And NewFile <> "False" Then
ActiveWorkbook.SaveAs FileName:=NewFile, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
CreateBackup:=False, _
ConflictResolution:=xlUserResolution
End If
Application.ScreenUpdating = True
End Sub
A working path (SaveArea) is as follows: \\TestServer\Test\Test\Standards\Test\Test 1\
A broken path (SaveArea) is as follows: \\TestServer\Test\Test\Standards\Test\Test. 1\
Both bring up the save as dialog, but the path with the period does not populate a filename. Is there a way to make this work when the path includes a period?
Edit: I've found a similar post here but it doesn't have a solution to fix the problem.
To get this to work, add the file extension to the InitialFileName parameter like below:
NewFile = Application.GetSaveAsFilename( _
InitialFileName:=SaveArea & newfilename & ".xlsm", _
fileFilter:=NewFileType)