I need to move a file from one folder to another folder using VBA.
For m = 1 To fnum
MsgBox " Please Select " & m & "files"
ffiles(m) = Application.GetOpenFilename
Next m
If Dir(outputfolder) = "" Then
fso.createfolder (outputfolder)
End If
fso.Movefile ffiles(m), outputfolder " getting error at this place "
I am getting an error message.
Error message id "Runtime error 438 . Object doesnt support this property "
My favorite way of doing it. Using the SHFileOperation API
Option Explicit
Private Declare Function SHFileOperation Lib "shell32.dll" _
Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Const FO_MOVE As Long = &H1
Private Const FOF_SIMPLEPROGRESS As Long = &H100
Private Type SHFILEOPSTRUCT
hWnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As Long
End Type
Sub Sample()
Dim fileToOpen As Variant
Dim outputfolder As String
Dim i As Long
outputfolder = "C:\Temp\"
fileToOpen = Application.GetOpenFilename(MultiSelect:=True)
If IsArray(fileToOpen) Then
If Dir(outputfolder) = "" Then MkDir outputfolder
For i = LBound(fileToOpen) To UBound(fileToOpen)
Call VBCopyFolder(fileToOpen(i), outputfolder)
Next i
Else
MsgBox "No files were selected."
End If
End Sub
Private Sub VBCopyFolder(ByRef strSource, ByRef strTarget As String)
Dim op As SHFILEOPSTRUCT
With op
.wFunc = FO_MOVE
.pTo = strTarget
.pFrom = strSource
.fFlags = FOF_SIMPLEPROGRESS
End With
'~~> Perform operation
SHFileOperation op
End Sub
We can move files from one folder to another automatically using script
https://seleniumautomations.blogspot.com/2020/05/less-than-5-sec-to-clean-and-organise.html?view=magazine
Related
I am very new to VBA. I keep on getting an error of type mismatch whenever the cancel/quit button in the dialogue box is clicked. The error appears on the Application.GetOpenFileName line. Does anyone know what is wrong here? I have tried several methods but none of them work :(
Thanks!
Here's my code:
Private Sub cmdBrowse_Click()
Application.ScreenUpdating = False
Dim i As Long, j As Long, iCheck As Long
Dim fname() As Variant
Dim wkbNameList As String, wkbNamePath As String
Dim win As Window
fname = Application.GetOpenFilename(filefilter:="Excel, *xlsx; *xlsm", MultiSelect:=True)
If fname = "False" Then
Exit Sub
End If
For i = LBound(fname) To UBound(fname)
workbooks.Open Filename:=fname(i)
wkbNameList = wkbNameList & workbooks(i + 1).Name & vbCrLf
wkbNamePath = wkbNamePath & fname(i) & " , "
Next i
function returns an array when files are selected, but returns a string when cancel/quit is selected
try this
Private Sub cmdBrowse_Click()
Application.ScreenUpdating = False
Dim i As Long, j As Long, iCheck As Long
Dim fname As Variant
Dim wkbNameList As String, wkbNamePath As String
Dim win As Window
fname = Application.GetOpenFilename(filefilter:="Excel, *xlsx; *xlsm", MultiSelect:=True)
If IsArray(fname) Then 'file selected
For i = LBound(fname) To UBound(fname)
Workbooks.Open Filename:=fname(i)
wkbNameList = wkbNameList & Workbooks(i + 1).Name & vbCrLf
wkbNamePath = wkbNamePath & fname(i) & " , "
Next i
ElseIf fname = "False" Then 'cancel/quit
Exit Sub
End If
End Sub
As pointed out by Kostas K. in the comments on h2so4's reply, the method returns boolean (False) when the dialog is cancelled, and array when a file is chosen.
I'd suggest trying this slight modification of h2so4's code:
Private Sub cmdBrowse_Click()
Application.ScreenUpdating = False
Dim i As Long, j As Long, iCheck As Long
Dim fname() As Variant
Dim wkbNameList As String, wkbNamePath As String
Dim win As Window
fname = Application.GetOpenFilename(filefilter:="Excel, *xlsx; *xlsm", MultiSelect:=True)
'the only option to get boolean is to have cancelled the dialog, which gives False for the variable
If VarType(fname) = vbBoolean Then
Exit Sub
Else
For i = LBound(fname) To UBound(fname)
workbooks.Open Filename:=fname(i)
wkbNameList = wkbNameList & workbooks(i + 1).Name & vbCrLf
wkbNamePath = wkbNamePath & fname(i) & " , "
Next i
End If
End Sub
'I ran into this problem working with multiselect as well
'Something like this will work
'The problem is [cancel] returns a Boolean instead of an array.. so we make it return an array
Dim fname(), fname_catcherror() As Variant
fname_catcherror = Array(Application.GetOpenFilename(filefilter:="Excel, *xlsx; *xlsm", MultiSelect:=True), True)
if VarType(fname_catcherror(0)) <> vbBoolean Then
fname = fname_catcherror(0)
'..code here
end if
I have to create a code to save configuration script of routers from specified list.
Using telnet and VBA I'm able to fulfill my requirement. But telnet window is visible every time and also I have to rely on SendKeys to send Commands properly to that telnet window.
I have embedded 'plink.exe' as an "Object 7" in Sheet1. below is the code which copies this object and paste created of today's date in temp folder:
EmbeddedObject.Copy
Set oFolder = CreateObject("Shell.Application").Namespace(sFolder & Chr(0))
oFolder.Self.InvokeVerb "Paste"
Here the problem is after copy-paste, the file is showing as corrupted. I tried adding a zip file, but zip also gets corrupted.
So I had added a code to open the object within Excel and using SendKeys and 7z Extractor I extract to temp folder again relying on SendKeys.
Please help me with to copy it in better way without getting file corrupted.
Here is my code.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
#Else
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
#End If
Private Type FUNC_OUT_RESULTS
SUCCESS As Boolean
SAVED_FILE_PATH_NAME As String
ERROR As String
End Type
Sub test()
Dim tRes As FUNC_OUT_RESULTS
Dim oleObj As OLEObject
tRes = SaveEmbeddedOleObjectToDisk _
(EmbeddedObject:=ActiveSheet.OLEObjects("Object 7"), FilePathName:="C:\Users\user\AppData\Local\Temp\20170512\")
With tRes
If .SUCCESS Then
MsgBox "OleObject successfully saved as : '" & .SAVED_FILE_PATH_NAME & " '", vbInformation
Else
MsgBox .ERROR, vbCritical
End If
End With
End Sub
Private Function SaveEmbeddedOleObjectToDisk( _
ByVal EmbeddedObject As OLEObject, _
ByVal FilePathName As String _
) _
As FUNC_OUT_RESULTS
Dim oFolder As Object
Dim sFolder As String
On Error GoTo errHandler
If Len(Dir$(FilePathName)) <> 0 Then 'Err.Raise 58
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefile FilePathName & "\*.*", True 'Delete files
FSO.deletefolder FilePathName 'Delete Todays Date folder
MkDir FilePathName 'Make Todays Date folder
End If
'\---------------------------------------\
sFolder = Left$(FilePathName, InStrRev(FilePathName, "\") - 10)
If Len(Dir$(sFolder, vbDirectory)) = 0 Then
MkDir sFolder
End If
If EmbeddedObject.OLEType = xlOLEEmbed Then
EmbeddedObject.Verb Verb:=xlPrimary '\---Here it opens within excel
Set EmbeddedObject = Nothing
Application.DisplayAlerts = True
Dim oShell
Set oShell = CreateObject("WScript.Shell")
Application.Wait (Now + TimeValue("0:00:02"))
oShell.AppActivate sFolder & "\plink*"
oShell.SendKeys "{F5}" '\----it extracts to temp-----------\
oShell.SendKeys FilePathName
oShell.SendKeys "{ENTER}"
Application.Wait (Now + TimeValue("0:00:01"))
oShell.AppActivate sFolder & "\plink*"
oShell.SendKeys ("%{F4}")
'----Copy the object without opening-----
' EmbeddedObject.Copy
' Set oFolder = CreateObject("Shell.Application").Namespace(sFolder & Chr(0))
' oFolder.Self.InvokeVerb "Paste"
'\---------------------------------------\
SaveEmbeddedOleObjectToDisk.SAVED_FILE_PATH_NAME = FilePathName
SaveEmbeddedOleObjectToDisk.SUCCESS = True
End If
Call CleanClipBoard
Exit Function
errHandler:
SaveEmbeddedOleObjectToDisk.ERROR = Err.Description
Call CleanClipBoard
End Function
Private Function GetPastedFile( _
ByVal Folder As String _
) _
As String
Dim sCurFile As String
Dim sNewestFile As String
Dim dCurDate As Date
Dim dNewestDate As Date
Folder = Folder & "\"
sCurFile = Dir$(Folder & "*.*", vbNormal)
Do While Len(sCurFile) > 0
dCurDate = FileDateTime(Folder & sCurFile)
If dCurDate > dNewestDate Then
dNewestDate = dCurDate
sNewestFile = Folder & sCurFile
End If
sCurFile = Dir$()
Loop
GetPastedFile = sNewestFile
End Function
Private Sub CleanClipBoard()
OpenClipboard 0
EmptyClipboard
CloseClipboard
End Sub
Does anyone have an idea how to return parameter name in VBA?
This is what I have:
Sub Main()
Dim MyString As String
MyString = "Hello World"
MsgBox MyString
End Sub
It shows only "Hello World". I would like to have it "MyString says Hello World", but dynamically, not by entering
MsgBox "MyString says " & MyString
I would prefer something like
MsgBox ParamName(MyString) & " says " & MyString
but it actually won't work... Could anyone help?
I believe I have accomplished what you are looking to do here. However, please note that this will currently only work for your first parameter in a macro assigned to a Form control:
Step 1
Add the following code, adapted from here, to a new Module:
Public Function ExportModules(ModuleName As String) As String
Dim bExport As Boolean
Dim wkbSource As Excel.Workbook
Dim szSourceWorkbook As String
Dim szExportPath As String
Dim szFileName As String
Dim cmpComponent As VBIDE.VBComponent
''' The code modules will be exported in a folder named.
''' VBAProjectFiles in the Documents folder.
''' The code below create this folder if it not exist
''' or delete all files in the folder if it exist.
If FolderWithVBAProjectFiles = "Error" Then
MsgBox "Export Folder not exist"
Exit Function
End If
On Error Resume Next
Kill FolderWithVBAProjectFiles & "\*.*"
On Error GoTo 0
''' NOTE: This workbook must be open in Excel.
szSourceWorkbook = ActiveWorkbook.Name
Set wkbSource = Application.Workbooks(szSourceWorkbook)
If wkbSource.VBProject.Protection = 1 Then
MsgBox "The VBA in this workbook is protected," & _
"not possible to export the code"
Exit Function
End If
szExportPath = FolderWithVBAProjectFiles & "\"
Set cmpComponent = wkbSource.VBProject.VBComponents(ModuleName)
bExport = True
szFileName = cmpComponent.Name
''' Concatenate the correct filename for export.
Select Case cmpComponent.Type
Case vbext_ct_ClassModule
szFileName = szFileName & ".cls"
Case vbext_ct_MSForm
szFileName = szFileName & ".frm"
Case vbext_ct_StdModule
szFileName = szFileName & ".bas"
Case vbext_ct_Document
''' This is a worksheet or workbook object.
''' Don't try to export.
bExport = False
End Select
If bExport Then
''' Export the component to a text file.
cmpComponent.Export szExportPath & szFileName
''' remove it from the project if you want
'''wkbSource.VBProject.VBComponents.Remove cmpComponent
End If
ExportModules = szExportPath & szFileName
End Function
Function FolderWithVBAProjectFiles() As String
Dim WshShell As Object
Dim FSO As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
Set FSO = CreateObject("scripting.filesystemobject")
SpecialPath = WshShell.SpecialFolders("MyDocuments")
If Right(SpecialPath, 1) <> "\" Then
SpecialPath = SpecialPath & "\"
End If
If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = False Then
On Error Resume Next
MkDir SpecialPath & "VBAProjectFiles"
On Error GoTo 0
End If
If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = True Then
FolderWithVBAProjectFiles = SpecialPath & "VBAProjectFiles"
Else
FolderWithVBAProjectFiles = "Error"
End If
End Function
Step 2
Add the following code, adapted from answer #7 here, and from here, along with my own function, to a new module (it could be the same module as the first if preferred):
Public Function MyMacroInfo() As String
Dim MacroName$, SubName$, ModArr As Variant
Dim ModName As Object, strModName$, i&, j&
MacroName = ActiveSheet.Buttons(Application.Caller).OnAction
SubName = Application.Replace(MacroName, 1, Application.Search("!", MacroName), "")
ModArr = Array(0, 1, 2, 3)
For Each ModName In ActiveWorkbook.VBProject.VBComponents
For j = LBound(ModArr) To UBound(ModArr)
i = 0
On Error Resume Next
i = ModName.CodeModule.ProcStartLine(SubName, CLng(ModArr(j)))
Err.Clear
If i > 0 Then
strModName = ModName.Name
Exit For
End If
Next j
Next ModName
MyMacroInfo = strModName
End Function
Public Function GetParamName(ModulePath As String) As String
Dim text As String
Dim textline As String
Dim ParamStartLocation As Long
Dim ParamEndLocation As Long
Dim ParamLength As Long
Dim i As Long
Open ModulePath For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
ParamStartLocation = 0
For i = 1 To 3
ParamStartLocation = InStr(ParamStartLocation + 1, text, "Dim ")
Next i
ParamEndLocation = InStr(ParamStartLocation, text, " As ")
ParamLength = ParamEndLocation - ParamStartLocation
GetParamName = Left(Right(text, Len(text) - ParamStartLocation - 3), ParamLength - 4)
End Function
Step 3
Change your sub to the following:
Sub Main()
'--------Leave this section at the top of your sub---------
Dim strExportedModule As String
Dim strParamName As String
strExportedModule = ExportModules(MyMacroInfo)
strParamName = GetParamName(strExportedModule)
'-----------------Start your code here---------------------
Dim MyString As String
MyString = "Hello World"
MsgBox strParamName & " says " & MyString
End Sub
Step 4
Assign Main to a Form Button.
Notes
As noted above, this will only get the first parameter that you dimension in the macro assigned to the Form Button. If this is not acceptable, I'll have to take a look at it to see if it can be modified to meet your needs.
As Ron de Bruin notes on his site, you'll need to do the following:
In the VBE Editor set a reference to "Microsoft Visual Basic For
Applications Extensibility 5.3" and to "Microsoft Scripting Runtime"
and then save the file.
This code will export the module to a folder named "VBAProjectFiles" in your My Documents folder. If you happen to have a folder saved there with the same name (as unlikely as that is), it will delete all the files in that folder.
I have a directory with several .txt files. Let's say
hi.txt
hello.txt
hello_test.txt
test.txt
Using a file dialogue in VBA, how can I filter to show only "*test.txt" matching files (ie last two) in the dropdown? Or can I only use *. filters?
The following seems it should work but does not:
Sub TestIt()
Dim test As Variant 'silly vba for not having a return type..
test = Application.GetOpenFilename(FileFilter:="test (*test.txt), *test.txt")
End Sub
edit: clarifying in case this wasn't clear: I want to filter "test.txt" instead of ".txt" files so I can only select from hello_test.txt and test.txt in the chooser.
I see that you are concerned about putting text in the file name box, but that is exactly what you need to do and appears to be the norm for your situation. I got hung up on the exact same issue.
This is what I used:
Public Sub Browse_Click()
Dim fileName As String
Dim result As Integer
Dim fs
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select Test File"
.Filters.Add "Text File", "*.txt"
.FilterIndex = 1
.AllowMultiSelect = False
.InitialFileName = "*test*.*"
result = .Show
If (result <> 0) Then
fileName = Trim(.SelectedItems.Item(1))
Me!txtFileLocation = fileName
End If
End With
How about filedialog?
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogOpen)
With dlgOpen
.AllowMultiSelect = True
.InitialFileName = "Z:\docs\*t*.*x*"
.Show
End With
http://msdn.microsoft.com/en-us/library/aa213120(v=office.11).aspx
Is this what you are trying? Paste this in a module and run the sub OpenMyFile
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Sub OpenMyFile()
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim strFilter As String
OpenFile.lStructSize = Len(OpenFile)
'~~> Define your filter here
strFilter = "Text File (*test.txt)" & Chr(0) & "*test.txt" & Chr(0)
With OpenFile
.lpstrFilter = strFilter
.nFilterIndex = 1
.lpstrFile = String(257, 0)
.nMaxFile = Len(.lpstrFile) - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = .nMaxFile
.lpstrInitialDir = "C:\Users\Siddharth Rout\Desktop\"
.lpstrTitle = "My FileFilter Open"
.flags = 0
End With
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
'~~> User cancelled
MsgBox "User cancelled"
Else
MsgBox "User selected" & ":=" & OpenFile.lpstrFile
'
'~~> Rest of your code
'
End If
End Sub
I have a Workbook with three WorkSheets: Product , Customer, Journal.
What I need is a macro assigned to a button within each one of the above Sheets.
If the button is clicked by the user, then the active sheet should be saved as a new workbook with the following naming convention:
SheetName_ContentofCellB3_DD.MM.YYYY
where
SheetName should be the name of the
current active sheet
ContentofCellB3
the content of cell B3 of the active
sheet each time
DD.MM.YYYY the
current date
The following macro I wrote makes the aforementioned:
Sub MyMacro()
Dim WS As Worksheet
Dim MyDay As String
Dim MyMonth As String
Dim MyYear As String
Dim MyPath As String
Dim MyFileName As String
Dim MyCellContent As Range
MyDay = Day(Date)
MyMonth = Month(Date)
MyYear = Year(Date)
MyPath = "C:\MyDatabase"
Set WS = ActiveSheet
Set MyCellContent = WS.Range("B3")
MyFileName = "MyData_" & MyCellContent & "_" & MyDay & "." & MyMonth & "." & MyYear & ".xls"
WS.Copy
Application.WindowState = xlMinimized
ChDir MyPath
If CInt(Application.Version) <= 11 Then
ActiveWorkbook.SaveAs Filename:= _
MyFileName, _
ReadOnlyRecommended:=True, _
CreateBackup:=False
Else
ActiveWorkbook.SaveAs Filename:= _
MyFileName, FileFormat:=xlExcel8, _
ReadOnlyRecommended:=True, _
CreateBackup:=False
End If
ActiveWorkbook.Close
End Sub
However there are some issues I would like your help:
How should I change the above macro so
that the user can decide the path
where the new workbook will be
saved?
How should I change the above macro so that the new Workbook wont include any macros that were part of the sheet of the initial workbook?
Do u see anything in my macro
that could be done another better
way?
Thanks everybody for your time in advance.
P.S. For my case of use there must always be a backward compatibility from excel 2007 till excel 2002
To piggyback on Lunatik's suggestion, you might add this:
MyPath = Application.GetSaveAsFilename(FILEFILTER:="Excel Files (*.xls), *.xls", Title:="Something really clever about saving")
If MyPath <> False Then
ActiveWorkbook.SaveAs (MyPath)
End If
GetSaveAsFilename returns FALSE if the user hits cancel. You can also supply a default filename.
This is a taste thing, but Format(Date, "dd.mm.yyyy") could replace your method.
The first one is simple. Use Application.GetSaveAsFilename to allow the user to nominate a path and filename.
I've used the following from Chip Pearson to strip the VBA out of a copied workbook before, it should do what you are after:
Sub DeleteAllVBACode()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = myWorkbook.VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
Set CodeMod = VBComp.CodeModule
With CodeMod
.DeleteLines 1, .CountOfLines
End With
Else
VBProj.VBComponents.Remove VBComp
End If
Next VBComp
End Sub
Sorry, not got time to review your code in detail (leaving work!)
Another appoach: SHBrowseForFolder
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Declare Function SHBrowseForFolder Lib _
"shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib _
"shell32" (ByVal pidList As Long, ByVal lpBuffer _
As String) As Long
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Function Show_Save_WorkSheet() As String
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
szTitle = "Please, specify the location where you want the Worksheet to be stored"
With tBrowseInfo
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
Show_Save_WorkSheet = sBuffer
End If
End Function