Moving all files to a different location

[Donna S]

I need help changing this macro I received from Vergel Adriano. It works but
I would like it to always move all the files in F:\temp and not ask me were
the source is and I was wondering if it could ask me to browse to the
destination location so I wouldn't have to type it in the Imput box. Is this
possible??? Thanks,

Sub test()
Dim strSource As String
Dim strDest As String
Dim strFileName As String

strSource = InputBox("Enter source folder path")
strDest = InputBox("Enter destination folder path")

strFileName = Dir(strSource, vbDirectory)
If strFileName = "" Then
MsgBox "Source Folder path is invalid", vbCritical
Exit Sub
End If

strFileName = Dir(strDest, vbDirectory)
If strFileName = "" Then
MsgBox "Destination Folder path is invalid", vbCritical
Exit Sub
End If

strFileName = Dir(strSource & "\*.*")
While strFileName <> ""
Name strSource & "\" & strFileName As strDest & "\" & strFileName
strFileName = Dir
Wend

End Sub

 

[moon]

Put this code in a module:

Option Explicit

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

Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260

Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal
lpString1 As String, ByVal lpString2 As String) As Long
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

Public Function APIDlgFolders() As String
Dim iNull As Integer, lpIDList As Long, lResult As Long
Dim sPath As String, udtBI As BrowseInfo

With udtBI
.hWndOwner = 0
.lpszTitle = lstrcat(CurDir, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
SHGetPathFromIDList lpIDList, sPath
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
APIDlgFolders = sPath
End Function

Private Sub BrowseAndMove()
Dim fso, fld, fls, f
Dim strReturn As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder("F:\TEMP")
Set fls = fld.Files
strReturn = APIDlgFolders
For Each f In fls
fso.MoveFile f, strReturn & "\" & f.Name
Next
Set f = Nothing
Set fls = Nothing
Set fld = Nothing
Set fso = Nothing
End Sub

 

[Tom Ogilvy]

Here is a modification of code at John Walkenbach's site.

Paste this into a New Module or put the declarations part at the top of the
module.

Then run TestMe

Option Explicit
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Sub TestMe()
Dim Msg As String
Dim strFileName As String
Dim strDest As String
Dim sPath As String
sPath = "C:\Temp\"
Msg = "Please select a location to move the files to."
strDest = GetDirectory(Msg)
If strDest = "" Then Exit Sub
If Right(strDest, 1) <> "\" Then strDest = _
strDest & "\"

strFileName = Dir(sPath & "*.*")
Do While strFileName <> ""
Name sPath & strFileName As strDest & strFileName
strFileName = Dir
Loop



End Sub

Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Root folder = Desktop
bInfo.pidlRoot = 0&

' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' Type of directory to return
bInfo.ulFlags = &H1

' Display the dialog
x = SHBrowseForFolder(bInfo)

' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

 

[Tom Ogilvy]

Change C:\Temp\

to

F:\Temp\

sorry.

 

[Donna S]

Tom,

Yesterday I ran your macro and it worked great. Today I run it and it stops
at this line: Name sPath & strFileName As strDest & strFileName
Any advise???

Thanks,
Donna