Convert vbs script to vb6 please

To All:

down below s a great script that we are going to be using production environment pretty soon. I now need this to be converted to vb6 with a GUI interface. Basically this script requires 4 variable in order to run:

StartDate, EndDate, Existing pst filename, New pst filename

I also would like to see the debug information in a log window. (the script is ran through csript which gives out results and if any errors. I would need that information if something gos wrong to debug in future)

This is extremely URGENT and very important so I am assigning 500 points to it!

Thank you :)

--ITKM

P.S. The vbs script


'Web Listing 1: PSTSplitter.vbs
' ==================================================================
Option explicit
Dim olApp
Dim olNameSPace
Dim inbox
Dim myfolder
Dim pAItems
Dim archive
Dim newarchive
Dim startDate
Dim endDate
Dim fs
Dim rootStoreID
Dim archStoreID
Dim newarchStoreID
Dim archFileName
Dim newarchFileName
Dim oArgs


Const olFolderCalendar = 9
Const olFolderInbox = 6

Const mailItemClass = 43
Const mailDefaultItemType = 0


Set oArgs = Wscript.Arguments


If oArgs.Count < 3 Then
     Wscript.Echo "USAGE: PSTSplitter.vbs <startdate> <enddate> <pstfile> [newfilename]"
     WScript.ECHO "Example: PSTSplitter.vbs 1/1/2000 12/31/2000 q:\archive.pst q:\newarchive.pst"
     WScript.Echo ""
     WScript.ECHO "Note: If newfilename is not specified, a new filename will automatically"
     WScript.ECHO "      be generated"
     Wscript.Quit 1
End If

WScript.Echo "Defining date ranges..."
startDate = DateValue(oArgs(0))
WScript.Echo "Start Date: " & startDate
endDate = DateValue(oArgs(1))
WScript.Echo "End Date: " & endDate
archFileName = oArgs(2)

If startDate > endDate Then
     WScript.Echo "INVALID: Start date is after end date"
     WScript.Quit 1
End If

set olApp = CreateObject("Outlook.Application")
set olNameSpace =olApp.GetNameSpace("MAPI")

rootStoreID = olNameSpace.GetDefaultFolder(olFolderInbox).parent.storeId


Set fs = CreateObject("Scripting.FileSystemObject")

If NOT fs.FileExists(archFileName) Then
     WScript.Echo "Archive file doesn't exist"
     WScript.Echo "Make sure the path to the .pst file contains no spaces"
     WScript.Quit 1
End If

If oArgs.Count = 4 Then
     ' === New archive name was specified.
     newarchFileName = oArgs(3)
Else
     ' === Generate a filename for new archive.
     newarchFileName = genNewFilename(archFileName, oArgs(0), oArgs(1))
End If

WScript.echo "Current Archive: " & archFileName
WScript.echo "New Archive: " & newarchfilename

WScript.echo "Closing any opened .pst file to avoid conflict"
Dim i, temp
For i = olNameSpace.Folders.count To 1 Step -1
     temp = olNameSpace.Folders(i).storeID
     If Left(temp,75) <> Left(rootStoreID,75) Then
          ' === At least the first 75 digits of the rootStoreID
          '     are the same for items that aren’t Personal Folders.
          '     Since they're not equal, this must be a
          '     Personal Folder. Close it.
          olNameSpace.RemoveStore olNameSpace.Folders(i)
     End If
Next

Wscript.echo "Opening .pst files"
olNameSpace.AddStore archfilename

For i = olNameSpace.Folders.count To 1 Step -1
     temp = olNameSpace.Folders(i).storeID
     If Left(temp,75) <> Left(rootStoreID,75) Then
          ' === This must be the old archive. Save the storeID
          '     and reference to the MAPIFolder instance.
          set archive = olNameSpace.Folders(i)
          archStoreID = temp
     End If
Next
olNameSpace.AddStore newarchfilename
For i = olNameSpace.Folders.count To 1 Step -1
     temp = olNameSpace.Folders(i).storeID
     ' === We need to get the reference to the MAPIFolder instance
     '     of the new .pst file by looking for .pst files currently
     '     opened in Outlook (using AddStore). We also need to make
     '     sure that this storeID isn’t the same as the one for
     '     the old archive, or we will be referencing the old
     '     archive rather than the new one.
     If (Left(temp,75) <> Left(rootStoreID,75)) AND _
        (temp <> archStoreID) Then
          set newarchive = olNameSpace.Folders(i)
          newarchStoreID = temp
     End If
Next

WScript.Echo vbTab & archive
WScript.Echo vbTab & newarchive

createFolders archive, newarchive, startDate, endDate

WScript.Echo "Closing .pst files"

olNameSpace.RemoveStore archive
olNameSpace.RemoveStore newarchive
Set olNameSPace = Nothing
Set olApp = Nothing
Set fs = Nothing
WScript.Echo "SUGGESTION: open up the old archive in Outlook and compact it " & _
          "to reclaim the lost space"
WScript.Quit 0

Sub createFolders(objArchive, objNewArchive, sDate, eDate)
     Dim objSubFolders, objSubFolder, j, objNewFolder
     On Error Resume Next
     For j = objArchive.Items.Count To 1 Step -1
          'WScript.Echo "Date Check: " & FormatDateTime(objArchive.Items.Item(j).CreationTime,2) & " " & sDate & " " & eDate & " " & objArchive.Items.Item(j).Class
          If (CDate(FormatDateTime(objArchive.Items.Item(j).CreationTime,2)) >= CDate(sDate)) And (CDate(FormatDateTime(objArchive.Items.Item(j).CreationTime,2)) <= CDate(eDate)) And (objArchive.Items.Item(j).Class = mailItemClass) Then
               WScript.Echo "Moving: " & objArchive.Items.Item(j).Subject
               objArchive.Items.Item(j).Move objNewArchive
               If Err.number <> 0 Then
                 WScript.Echo "Error #" & Err.number & " - "& Err.Description
            End If
          End If
     Next
     Set objSubFolders = objArchive.Folders
    If objSubFolders.Count = 0 Then
         ' === Stop condition reached
        Exit Sub
    End If
     For Each objSubFolder In objSubFolders
          WScript.Echo "Processing SubFolder: " & objSubFolder.Name
          Set objNewFolder = OpenMAPIFolder("\" & objNewArchive.Name & "\" & objSubFolder.Name)
        If Not TypeName(objNewFolder) = "MAPIFolder" Then
            Set objNewFolder = objNewArchive.Folders.Add(objSubFolder.Name)
        End If
          createFolders objSubFolder, objNewFolder, sDate, eDate
    Next
    On Error Goto 0
    Set objNewFolder = Nothing
    Set objSubFolder = Nothing
    Set objSubFolders = Nothing
End Sub

Function genNewFilename(str, sDate, eDate)
     sDate = replaceText(sDate,"/","")
     sDate = replaceText(sDate,"\\","")
     eDate = replaceText(eDate,"/","")
     eDate = replaceText(eDate,"\\","")
     Dim pos, tempname
     pos = InStr(1,str,".pst",1)
     If pos <> 0 Then
          tempname = Left(str,pos-1)
     Else
          tempname = str
     End If
     
     genNewFilename = tempname & "_" & sDate & "_" & eDate & ".pst"    
End Function


Function ReplaceText(str1, oldstr, newstr)
     Dim regEx
     Set regEx = New RegExp
     regEx.Pattern = oldstr
     regEx.IgnoreCase = True
     regEx.Global = True
     ReplaceText = regEx.Replace(str1,newstr)
End Function

'Credit where credit is due.
'The code below is not mine.  I found it somewhere on the internet but do
'not remember where or who the author is.  The original author(s) deserves all
'the credit for these functions.
Function OpenMAPIFolder(szPath)
    Dim app, ns, flr, szDir, i
    Set flr = Nothing
    Set app = CreateObject("Outlook.Application")
    If Left(szPath, Len("\")) = "\" Then
        szPath = Mid(szPath, Len("\") + 1)
    Else
        Set flr = app.ActiveExplorer.CurrentFolder
    End If
    While szPath <> ""
        i = InStr(szPath, "\")
        If i Then
            szDir = Left(szPath, i - 1)
            szPath = Mid(szPath, i + Len("\"))
        Else
            szDir = szPath
            szPath = ""
        End If
        If IsNothing(flr) Then
            Set ns = app.GetNamespace("MAPI")
            Set flr = ns.Folders(szDir)
        Else
            Set flr = flr.Folders(szDir)
        End If
    Wend
    Set OpenMAPIFolder = flr
    Set app = Nothing
End Function

Function IsNothing(Obj)
  If TypeName(Obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End FunctionStart Free Trial