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
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