Script to Rename Files (VBS)

I ran across this post on MS Technet earlier:

I have a collection of files in a directory with this filename formats:
zipname-date.ZIP.source.destination.timecreated

Where:
ZipName - Flexible; filename is created automatically
Source / Destination - Normal value is from 0001 to 9999

Sample:
Account20080909.zip.1.0001.0901
Account20080909.zip.1.0025.0902
Account20080909.zip.1.0110.0910
Group20080909.zip.1.0110.0905
Group20080909.zip.1.0025.0903
Group20080909.zip.1.0001.0904

Scenario:
I want to copy the file and rename file with 0001 by removing the trailing extensions, just retain the zip file, see sample output:

Account20080909.zip.1.0001.0901 to Account20080909.zip
Group20080909.zip.1.0001.0904 to Group20080909.zip

Is this possible?

Here's a script I came up with to rename the files:

Option Explicit
On Error Resume Next
Dim objFSO
Dim strSource, strDestination
Dim strFile1, strFile2
Dim x, y, z, arrFiles
strSource = "C:\Source"
strDestination ="C:\Target"
Set objFSO = CreateObject("Scripting.FileSystemObject")
arrFiles = split(ListFiles(strSource), vbCrLf)
For x=0 to Ubound(arrFiles)
z=Instr(arrFiles(x),".0001")
if z > 0 then
y=Instr(arrFiles(x), "zip")
strFile2=Left(arrFiles(x),Len(arrFiles(x))-y-3)
objFSO.CopyFile strSource & "\" & arrFiles(x), _
strDestination _ & "\" & strFile2, True
Else
'not .0001 file
end if
Next

Function ListFiles(strFolder)
Dim strFiles, FSObj, FDir, FS, sFile
strFiles = ""
Set FSObj = CreateObject("Scripting.FileSystemObject")
Set FDir = FSObj.GetFolder(strFolder)
set FS = FDir.Files
For Each sFile in FS
strFiles = strFiles & sFile.name & chr(13) & Chr(10)
Next
ListFiles = strFiles
Set FSObj = Nothing
End Function

Here's the link from the Technet forum: http://forums.technet.microsoft.com/en-US/ITCG/thread/4dbeceaa-e6d2-4a1e-a10a-e46011f4359f.