PDA

View Full Version : Move files with a selection of file(s)



lucpian
02-19-2008, 12:22 PM
Hi All,

I am writing a vba code that will allow user to dialog to a folder, and select any file that they wish to move to another folder. I wrote this code which works moving the files, but does not dialog to give the user the option f choosing which to move. Here is my vba code

Sub moveFilesToCaprsbutton()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim PathExists As Boolean
Dim strSourceFolder As String
Dim strDestFolder As String
Dim x, Counter As Integer
Dim Overwrite As String
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim FileName As String


FromPath = "C:\Documents and Settings\029573\Desktop\Excelssheets" '<< Change
ToPath = "C:\Documents and Settings\029573\Desktop\Weekly Report for WICS" '<< Change


FileExt = "*.xl*" '<< Change
'You can use *.* for all files or *.doc for word files
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
Set FSO = CreateObject("scripting.filesystemobject")
'Loop through the folder & build file list
strFile = Dir(FromPath & "*.xls")
While strFile <> ""
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend
'MsgBox "list of files" & intFile

On Error Resume Next

If FSO.FolderExists(ToPath) = True Then 'if there is no error, set flag to TRUE
Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _
"Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!")
'message to alert that you may overwrite files of the same name since folder exists
If Overwrite <> vbYes Then Exit Sub 'if the user clicks YES, then exit the routine..
End If 'end the conditional testing

If FSO.FolderExists(FromPath) = False Then
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects

Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on
' MsgBox FromPath & " doesn't exist"
Exit Sub

End If
If FSO.FolderExists(ToPath) = False Then
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing 'clear the objects

Application.ScreenUpdating = True 'turn screenupdating back on
Application.EnableEvents = True 'turn events back on

'MsgBox ToPath & " doesn't exist"
Exit Sub
End If

' Counter = Counter + 1

FSO.MoveFolder Source:=FromPath, Destination:=ToPath
'FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath

MsgBox "All " & intFile & "files from " & FromPath & "have been copied/moved to: " & ToPath, , "Completed Transfer/Copy!"
'Message to user confirming completion
End Sub Please, could someone help me with how I can successfully do this, if a new set of code could be provided, I would very grateful.

Thanks

Lucpian


~Code Tags Added By Oorang

mdmackillop
02-26-2008, 11:23 AM
Bump!

Bob Phillips
02-26-2008, 02:46 PM
Sub moveFilesToCaprsbutton()
Dim FromPath As String
Dim ToPath As String
Dim mpFromFile As String
Dim mpToFile As String
Dim mpCount As Long
Dim i As Long

FromPath = "C:\test" '"C:\Documents and Settings\029573\Desktop\Excelssheets" '<< Change
ToPath = "C:\test\backups" '"C:\Documents and Settings\029573\Desktop\Weekly Report for WICS" '<< Change

With Application.FileDialog(msoFileDialogFilePicker)

.AllowMultiSelect = True
.Filters.Add "Excel Files", "*.xl*", 1
.InitialFileName = FromPath
If .Show = -1 Then

ReDim mpFiles(1 To .SelectedItems.Count)
For i = 1 To .SelectedItems.Count

mpFromFile = .SelectedItems(i)
mpToFile = Right$(mpFromFile, Len(mpFromFile) - InStrRev(mpFromFile, "\"))
mpToFile = ToPath & Application.PathSeparator & mpToFile
If Dir(mpToFile) <> "" Then

If MsgBox("Overwrite file " & mpToFile & "?", vbYesNo) = vbYes Then

Kill mpToFile
Name mpFromFile As mpToFile
mpCount = mpCount + 1
End If
Else

Name mpFromFile As mpToFile
mpCount = mpCount + 1
End If
Next i
End If

MsgBox "All " & mpCount & " files from " & FromPath & "have been copied/moved to: " & ToPath, , "Completed Transfer/Copy!"
'Message to user confirming completion
End With

End Sub

lucpian
02-27-2008, 01:50 PM
Thanks a lot xld. Your code works fine.