'=========================================================
'
' DESC: Move files in a directory to a new folder with a date timestamp
'
' USAGE: Call MoveFilesWithDateStamp ("SOURCE DIR", "DESTINATION DIR")
'
'
' AUTHOR: Todd Woolums (twoolums@toddwoolums.com)
' DATE : 05/29/2004
' VERSION: 1.0
'=========================================================

Dim fso
Dim strCurrentDate
Set fso = CreateObject("scripting.filesystemobject")
Call BuildCurrentDate
Call MoveFilesWithDateStamp ("\\server\share\incoming", "\\server\share\Archive")
Set fso = Nothing


Sub MoveFilesWithDateStamp(strSourceFolder, strDestinationFolder)

    Dim fsoFile
    Dim fsoFolder
    Dim fsoSubFolder
    Dim strFileNameFront
    Dim strFileExt
    Dim strNewFileName
   
    Set fsoFolder = fso.GetFolder(strSourceFolder)

    
    For Each fsoFile In fsoFolder.Files
        BreakFileName fsoFile.Name, strFileNameFront, strFileExt
        strNewFileName = strFileNameFront & "_" & strCurrentDate & strFileExt
        fsoFile.Move strDestinationFolder & "\" & strNewFileName
    Next
    
    Set fsoFile = Nothing
    Set fsoFolder = Nothing

    
End Sub



Sub BreakFileName(strFullName, strFront, strExtension)

    Dim intPos
    
    strFront = strFullName
    strExtension = ""
    
    intPos = InStrRev(strFullName, ".")
    If intPos > 0 Then
        strFront = Left(strFullName, intPos - 1)
        strExtension = Mid(strFullName, intPos)
    End If

End Sub

Sub BuildCurrentDate

    strCurrentDate = Year(date()) 
    If (Month(date()) < 10) Then
        strCurrentDate = strCurrentDate & "0" & Month(date())
    Else
        strCurrentDate = strCurrentDate & Month(date())
    End If
    If (Day(date()) < 10) Then
        strCurrentDate = strCurrentDate & "0" & Day(Date())
    Else
        strCurrentDate = strCurrentDate & Day(Date())
    End If

End Sub