' Defragment and compact a Virtual PC virtual disk.  This uses
' the vhdmount.exe utility and the VirtualServer.Application
' COM object both of which are installed by Virtual Server.
'
' Note that it may be necessary to use Device Manager to add a
' legacy device using vhdbus.inf.  If the mount fails then right
' click and update "MS Virtual Server SCSI Disk Device" in Device
' Manager.  Diagnostics for vhdmount.exe can be obtained using
' "set VHD_MOUNT_TRACE=1" (for example, prefix this text to the
' command with a joining " && ").
'
' The "Distributed Link Tracking Client" service (TrkWks) is
' stopped in order to minimise the chance of locks (which may
' prevent the virtual hard disk from unmounting).
'
' Place precompact.exe from Virtual Server (not Virtual PC) in
' the same folder as this script.  Under Windows Vista run this
' script as Administrator.  This script was developed and tested
' under Windows Vista Business Edition (Service Pack 1).
'
' Michael Bone
' 14-Apr-2008



Option Explicit



Dim strDriveLetter
Dim strVirtualHardDiskPath
Dim strMountUtilityPath
Dim strDefragUtilityPath
Dim strPrecompactUtilityPath
Dim strChange
Dim objFileSystem
Dim nStartSize
Dim nEndSize

strMountUtilityPath = "%ProgramFiles%\Microsoft Virtual Server\Vhdmount\vhdmount.exe"
strDefragUtilityPath = "%SystemRoot%\System32\Defrag.exe"
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
strPrecompactUtilityPath = objFileSystem.BuildPath(objFileSystem.GetParentFolderName(WScript.ScriptFullName), "Precompact.exe")

If (WScript.Arguments.Count < 2) Then
   MsgBox "The first parameter must be an unused drive letter and the second parameter must be the path to a virtual hard disk.  For example," & vbCrLf & vbCrLf & "Compact.vbs v ""C:\Temp\HardDisk.vhd""" & vbCrLf & vbCrLf & "Note that under Windows Vista this must be run as Administrator.", vbInformation, "Arguments Required"
   WScript.Quit
End If

strDriveLetter = WScript.Arguments(0)
strVirtualHardDiskPath = WScript.Arguments(1)

If (MsgBox("Do you want to compact """ & strVirtualHardDiskPath & """ using the " & UCase(strDriveLetter) & ": drive?", vbQuestion + vbYesNo, "Compact") = vbYes) Then

    nStartSize = objFileSystem.GetFile(strVirtualHardDiskPath).Size
    Message ""
    Message ""
    Message ""
    Message "Started (virtual hard disk size is " & FormatNumber(nStartSize, 0) & " bytes)."

    Start "%ComSpec%", "/c net stop TrkWks & set ERRORLEVEL=0"
    Start strMountUtilityPath, "/m /f """ & strVirtualHardDiskPath & """ " & strDriveLetter
    Start strDefragUtilityPath, strDriveLetter & ": -w"
    Start strPrecompactUtilityPath, "-Silent -SetDisks:" & strDriveLetter
    Start strMountUtilityPath, "/u """ & strVirtualHardDiskPath & """"
    Compact strVirtualHardDiskPath

    nEndSize = objFileSystem.GetFile(strVirtualHardDiskPath).Size
    strChange = "decreased"
    If (nEndSize > nStartSize) Then strChange = "increased"
    Message "Completed (virtual hard disk " & strChange & " in size by " & FormatNumber(Abs(nEndSize - nStartSize), 0) & " byte(s))."
    MsgBox "Compact completed successfully and " & strChange & " virtual hard disk size by " & FormatNumber(Abs(nEndSize - nStartSize), 0) & " byte(s).", vbInformation, "Successful"

End If



Sub Compact(ByVal strVirtualHardDiskPath)

    ' Compact the virtual disk using the Virtual Server COM object.

    Dim objVirtualServer
    Dim objVirtualHardDisk
    Dim objCompactTask

    Message "Compact started: " & strVirtualHardDiskPath

    Set objVirtualServer = CreateObject("VirtualServer.Application")
    Set objVirtualHardDisk = objVirtualServer.GetHardDisk(strVirtualHardDiskPath)
    Set objCompactTask = objVirtualHardDisk.Compact

    Do While (Not objCompactTask.IsComplete)
        Message "Compact " & objCompactTask.PercentCompleted & "% complete."
        WScript.Sleep 60000
    Loop

    Message "Compact completed."

End Sub



Sub Start(ByVal strFileName, ByVal strArguments)

    ' Perform a command and capture any error messages.

    Dim objShell
    Dim objFileSystem
    Dim objApplicationExec
    Dim objRegExp
    Dim strCommand
    Dim strOutput
    Dim strFile

    Do

        ' Construct the command.

        strCommand = """" & strFileName & """ " & strArguments
        Message "Performing: " & strCommand

        ' Ensure that the executable exists.

        Set objShell = CreateObject("WScript.Shell")
        Set objFileSystem = CreateObject("Scripting.FileSystemObject")
        If (Not objFileSystem.FileExists(objShell.ExpandEnvironmentStrings(strFileName))) Then
            Message "The command cannot be performed because the executable was not found."
            MsgBox "The command cannot be performed because the executable was not found." & vbCrLf & vbCrLf & strCommand, vbExclamation, "File Not Found"
            WScript.Quit
        End If

        ' Execute the command.

        Set objApplicationExec = objShell.Exec(strCommand)
        Do While (objApplicationExec.Status = 0)
            WScript.Sleep 100
        Loop

        ' Attempt to detect and report errors.

        Set objRegExp = New RegExp
        objRegExp.Pattern = "^\s+|\s+$"  ' leading or trailing whitespace
        objRegExp.Global = True
        strOutput = objRegExp.Replace(objApplicationExec.StdErr.ReadAll & vbCrLf & objApplicationExec.StdOut.ReadAll, "")
        If (objApplicationExec.ExitCode <> 0) Then Message "Exit code " & objApplicationExec.ExitCode & "."
        If (strOutput <> "") Then Message strOutput
        If (objApplicationExec.ExitCode = 0 And InStr(1, strOutput, "Error", vbTextCompare) <= 0) Then Exit Do

        ' An error was detected so prompt for a retry.

        If (MsgBox("Do you want to retry the command (it failed with an exit code of " & objApplicationExec.ExitCode & ")?" & vbCrLf & vbCrLf & strCommand & vbCrLf & vbCrLf & strOutput, vbExclamation + vbYesNo, "Command Failed") = vbNo) Then
            strFile = objFileSystem.BuildPath(objFileSystem.GetSpecialFolder(2), objFileSystem.GetTempName())
            objFileSystem.CreateTextFile(strFile, True).Write(strCommand & vbCrLf & vbCrLf & strOutput)
            objShell.Exec "Notepad.exe """ & strFile & """"
            WScript.Sleep 2000
            objFileSystem.DeleteFile strFile
            WScript.Quit
        End If

    Loop

End Sub



Sub Message(ByVal strMessage)
    On Error Resume Next

    ' Record a message in the log file.

    Dim objFileSystem
    Dim objFile
    Dim dateTime
    Dim strPrefix

    ' Open the log file.

    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    Set objFile = objFileSystem.OpenTextFile(objFileSystem.BuildPath(objFileSystem.GetParentFolderName(WScript.ScriptFullName), objFileSystem.GetBaseName(WScript.ScriptFullName) & ".log"), 8, True)

    ' Place the message in the log file prefixed with the date/time.

    dateTime = Now
    strPrefix = Right("0" & Day(dateTime), 2) & "-" & MonthName(Month(dateTime), True) & "-" & Right("000" & Year(dateTime), 4) & " " & Right("0" & Hour(dateTime), 2) & ":" & Right("0" & Minute(dateTime), 2) & ":" & Right("0" & Second(dateTime), 2) + " "
    objFile.WriteLine Replace(strPrefix & strMessage, vbCrLf, vbCrLf & Space(Len(strPrefix)))
    objFile.Close

End Sub