hello all-

 

i need help with this vbscript i thought i was doing good until it got really complicated.I have a folder with a file with .ach at the end the file names can change daily i try creating this script that will go in the folder then copy the files rename it and move it to a different. how can i copy a wildcard file using vbscript. this is what i have so far. any help would be greatly appreciated.

 

thanks in advance

 

Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile _
    ("c:\ACHTEST\MOBILDEP", ForReading)
        Do Until objTextFile.AtEndOfStream                      ' Loop until end of file.
             sRecord  = objTextFile.Readline             ' Read line into variable.
            If Mid(sRecord, 1, 1) = "9" Then
                sRec9 = 1                        ' EOF record found so change flag
                sTotalDebit = FormatCurrency((Mid(sRecord, 32, 12) / 100),2)
                sTotalCredit = FormatCurrency((Mid(sRecord, 44, 12) / 100),2)
                Exit Do
            End If
        Loop
                                 ' Close file.
       
        If sRec9 = 0 Then
            Error = MsgBox("BAD FILE - EOF record not found" & (Chr(13)))     ' EOF record not found
        Else
            Response = MsgBox("Please verify File is current: " _
                & "OK To Transfer to Spectrum?", vbYesNo)
            If Response = vbNo Then
                                                                Error = MsgBox("Transfer Aborted" & (Chr(13)))     ' Abort Transfer
'               End If
        Else
                                                dim filesys
                                                set filesys=CreateObject("Scripting.FileSystemObject")
                                                If filesys.FileExists("c:\ACHTEST\.ach") Then
                                                newName=Replace(MOBILDEP)
                                                                filesys.CopyFile "c:\ACHTEST\.ach", "C:\ACHFTP\"
                                                Error = MsgBox("Transfer to HP Successful" & (Chr(13)))     '
                                                End If
                                End If
 
End If
objTextFile.Close  

2 Comments   [ + ] Show Comments

Comments

  • I haven't tested this but have you tried "*" without quotes?
  • You need to recurse through the files. Here's something you will be able to adapt by editing the 'StartProcessing' function:

    (Note to Bob: this forum sooooooooooooooooooooo needs a 'CODE' tag!!!)
    '// Run RegSvr32 against a folder and its sub-folders containing DLLs and OCXs
    '// Programming obfuscation a speciality

    Option Explicit

    Dim blnResult
    Dim blnIsCustomAction
    Dim intIndex
    Dim strMsg
    Dim objFSO
    Dim objWSHShell
    Dim objRegistry
    Dim objWMIService
    Dim objEventSink
    Dim lngProcessID
    Dim strScriptFullName
    Dim dicFiles
    Dim dicArguments
    Dim blnFailed
    Dim objFailure
    Dim dicFailures
    Dim strOut
    Dim blnProcessTerminated

    Const intFSOForReading = 1
    Const intFSOForWriting = 2
    Const intFSOForAppending = 8
    Const intFSOTristateFalse = 0
    Const strNameSeparator = "|"
    Const strBrowseForFolderTitle = "Select a folder to process"

    strScriptFullName = WScript.ScriptFullName

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objWSHShell = CreateObject("Shell.Application")
    Set dicArguments = CreateObject("Scripting.Dictionary")
    Set dicFiles = CreateObject("Scripting.Dictionary")
    Set dicFailures = CreateObject("Scripting.Dictionary")
    Set objRegistry = New clsRegistry
    Set objWMIService = GetObject("WINMGMTS:{impersonationLevel=impersonate,(Security)}!\\.\ROOT\CIMV2")

    dicArguments.CompareMode = vbTextcompare '// Ignore case in command-line arguments

    Call Main

    Set objWMIService = Nothing
    Set objFSO = Nothing
    Set objWSHShell = Nothing
    Set dicArguments = Nothing
    Set dicFiles = Nothing
    Set dicFailures = Nothing
    Set objRegistry = Nothing

    Sub Main
    Dim objFolder
    Dim strFolder
    Dim strDest
    Dim objFailure
    Dim strFailureList

    '//------------------------------------------------------------------------------------------------------------//
    '// Force use of CScript
    '//------------------------------------------------------------------------------------------------------------//
    Call ForceCScriptExecution(True)

    blnIsCustomAction = False

    On Error Resume Next
    If IsObject(Session) Then
    '// We may have arrived here because error-trapping is off
    If Err.Number = 0 Then
    blnIsCustomAction = True
    End If
    End If

    If Not IsObject(objRegistry) Then
    Exit Sub
    End If

    On Error Goto 0

    '// Get the folder you want to process and the target folder
    Select Case WScript.Arguments.Count
    Case 0
    strFolder = BrowseForFolder(strBrowseForFolderTitle)
    If Len(strFolder) = 0 Then
    Exit Sub
    End If

    Case 1
    strFolder = WScript.Arguments(0)

    Case Else
    strFolder = WScript.Arguments(0)

    End Select

    If Len(strFolder) = 0 Then
    Exit Sub
    End If

    blnFailed = False

    '// Create the Event Notification sink
    Set objEventSink = CreateObject("WbemScripting.SWbemSink")

    WScript.ConnectObject objEventSink,"EVENTSINK_"

    blnProcessTerminated = False

    Call ProcessFiles(".DLL", strFolder)
    Call ProcessFiles(".OCX", strFolder)

    If blnFailed Then
    strMsg = "Failed to register the following files:" & vbCRLF
    For Each objFailure In dicFailures
    strFailureList = ""
    strFailureList = strFailureList & dicFailures.Item(objFailure) & vbCRLF
    Next

    Call Say(strMsg & strFailureList, blnIsCustomAction)
    End If

    End Sub

    Sub ProcessFiles(ByVal strExt, ByVal strSourceFolder)
    Dim arrDictItems
    Dim arrDictKeys
    Dim strKey
    Dim strItem

    '// Don't even bother to start if the source of destination folders don't exist.
    If Not objFSO.FolderExists(strSourceFolder) Then
    strMsg = "The source folder '" & strSourceFolder & "' does not exist."
    Call Say(strMsg, blnIsCustomAction)
    Exit Sub
    End If

    '// Empty the dictionary
    On Error Resume Next
    dicFiles.RemoveAll
    On Error Goto 0

    strOut = ""
    Call RecurseExtensions(objFSO.GetFolder(strSourceFolder), strExt)
    'Call RecurseFiles(objFSO.GetFolder(strSourceFolder))

    If IsEmpty(dicFiles) Then
    Exit Sub
    End If

    '// Now that we have a dictionary, we can process the items in it
    With dicFiles
    arrDictKeys = .Keys
    arrDictItems = .Items

    For intIndex = 0 To .Count - 1
    strKey = arrDictKeys(intIndex)
    strItem = .Item(arrDictKeys(intIndex))

    'WScript.Echo "Key = " & strKey & " Item = " & strItem
    '// The data looks like this:
    '// Path_to_file, Name_of_file, Size, File type
    '// separator (see strNameSeparator)
    '// Path_to_file, Name_of_file, Size, File type
    '// etc

    '// This next call is what makes this script reasonably generic:
    '// just pass the data to a function which does what you want it to do

    blnResult = StartProcessing(strItem)
    Next
    End With
    End Sub

    Sub RecurseExtensions(ByVal objFolderName, ByVal strExt)
    Dim objSubFolders
    Dim objSubFolder
    Dim objFolder
    Dim objFile
    Dim strDetails
    Dim intElement
    Dim strFolderName
    Dim strExtension

    strFolderName = objFolderName.Path
    Set objFolder = objWSHShell.Namespace(strFolderName)
    If Err.Number <> 0 Then
    Exit Sub
    End If

    '// Write the actual data elements for each file
    For Each objFile in objFolder.Items
    With dicFiles
    If InStr(objFile.Name, ".") Then
    strExtension = UCase(Mid(objFile.Name, InStrRev(objFile.Name, "." ) ) )
    If UCase(strExt) = UCase(strExtension) Then
    Call Say("Adding " & objFolder.GetDetailsOf(objFile, 0) & " for processing", blnIsCustomAction)
    If strOut <> "" Then
    strOut = strOut & strNameSeparator
    End If

    strOut = strOut & strFolderName

    '// We're not interested in the rest of this junk
    'For intElement = 0 to 37
    For intElement = 0 To 2
    If strOut <> "" Then
    strOut = strOut & ","
    End If
    strOut = strOut & Replace(objFolder.GetDetailsOf(objFile, intElement), ",", "")
    Next

    If Not .Exists(strExtension) Then
    .Add strExtension, strOut
    Else
    .Item(strExtension) = strOut
    End If
    End If
    End If
    End With
    Next

    '// Check for any sub-folders and recursively process them
    Set objSubFolders = objFolderName.SubFolders
    For Each objSubFolder In objSubFolders
    If LCase(objSubFolder.Name) <> "recycled" Then
    Call RecurseExtensions(objSubFolder, strExt)
    End If
    Next

    '// Just cosmetic padding for output
    Call Say(String(2, vbCRLF), blnIsCustomAction)

    Set objFile = Nothing
    Set objFolder = Nothing
    End Sub

    Function StartProcessing(ByVal strData)
    Dim arrData
    Dim strItem
    Dim strPath
    Dim strName
    Dim strSize
    Dim strType
    Dim objFile
    Dim strSourceFile
    Dim strTextToSearch
    Dim objTextStream
    Dim blnCanBeRegistered
    Dim blnRanRegSvr32

    Const strTextToFind = "DllRegisterServer"

    StartProcessing = False

    arrData = Split(strData, strNameSeparator)

    For intIndex = 0 To UBound(arrData)
    strItem = arrData(intIndex)

    'WScript.Echo strItem
    'Call Say("Processing " & strItem, blnIsCustomAction)

    '// Split the data into an array
    strPath = Split(strItem, ",")(0)
    strName = Split(strItem, ",")(1)
    strSize = Split(strItem, ",")(2)
    strType = Split(strItem, ",")(3)

    strSourceFile = strPath & "\" & strName

    With objFSO
    Set objFile = .GetFile(strSourceFile)
    Set objTextStream = objFile.OpenAsTextStream(intFSOForReading, intFSOTristateFalse)

    Call Say(vbTAB & "Checking for 'DLLRegisterServer' entry point in " & strName, blnIsCustomAction)
    strTextToSearch = objTextStream.Read(objFile.Size)

    blnCanBeRegistered = False
    If InStr(strTextToSearch, strTextToFind) > 0 Then
    blnCanBeRegistered = True
    Call Say(String(2, vbTAB) & "'DLLRegisterServer' entry point found, registering file", blnIsCustomAction)
    blnRanRegSvr32 = RunRegSvr32(strSourceFile)
    If Not blnRanRegSvr32 Then
    If blnRanRegSvr32 = -99 Then
    Exit Function
    Else
    blnFailed = True
    dicFailures.Add strSourceFile, strSourceFile
    End If
    End If
    End If

    Set objTextStream = Nothing
    Set objFile = Nothing
    End With
    Next

    StartProcessing = True

    End Function

    Function RunRegSvr32(ByVal strSource)
    Dim blnLocateWise
    Dim strPath
    Dim strName
    Dim strArguments
    Dim intSepPos
    Dim blnProcessCreated

    RunRegSvr32 = False

    '// Add quote marks to paths if necessary
    If InStr(strSource, Chr(32)) > 0 Then
    strSource = Chr(34) & strSource & Chr(34)
    End If

    intSepPos = InStrRev(strSource, "\")
    If intSepPos = 0 Then
    strMsg = "There is a problem with the definition of the source folder (no backslash in path)." & vbCRLF
    strMsg = strMsg & "This is a serious configuration error. Contact the Helpdesk." & vbCRLF
    Call Say(strMsg, blnIsCustomAction)
    Exit Function
    End If

    '// Call RegSvr32
    strPath = "C:\Windows\System32"
    strName = "RegSvr32.EXE"
    strArguments = "/S" & strSource

    blnProcessCreated = ProcessLaunch(strPath & "\" & strName & " " & strArguments, strPath)
    If Not blnProcessCreated Then
    Exit Function
    End If

    Call Say(String(3, vbTAB) & strSource & " registered" & vbCRLF, blnIsCustomAction)

    RunRegSvr32 = True
    End Function

    Function LocateWise(ByRef strWisePath)

    Dim strHive
    Dim strKey
    Dim strSubKey
    Dim strValue
    Dim blnResult_Wise
    Dim strLocation
    Dim strLocationCheck
    Dim blnLocationsMatch
    Dim intEXEPos

    '// Naturally, being a DeepNet script, we search one location then check against another.
    '// Never, EVER assume...

    LocateWise = False

    blnResult_Wise = objRegistry.Connect(".")
    If blnResult_Wise Then
    With objRegistry

    '// No good - only returns one folder up from what we want to know
    'strHive = "HKCU"
    'strKey = "Software\Wise Solutions\Install"
    'strSubKey = "Wise Package Studio 7"
    'strValue = "WPSDir"

    strHive = "HKCU"
    strKey = "Software\Classes\Msi.Package\shell\EditWPS"
    strSubKey = "command"
    strValue = ""

    blnResult_Wise = .ExistKey(strHive, strKey, strSubKey)
    If Not blnResult_Wise Then
    '// Too serious for us to get involved. Flag an error and exit
    strMsg = "Registry key '" & strHive & "\" & strKey & "\" & strSubKey & " does not exist." & vbCRLF
    strMsg = strMsg & "This is a serious configuration error. Contact the Helpdesk." & vbCRLF
    Call Say(strMsg, blnIsCustomAction)
    Exit Function
    End If

    '//
    '// Serious bug!
    '// The WMI EnumValues method returns Null if the only value which exists in a key is the default one
    '// i.e. the one which RegEdit displays as "(Default)"

    '// blnResult_Wise = .ExistValue(strHive, strKey & "\" & strSubKey, strValue)
    '// If Not blnResult_Wise Then
    '// '// Too serious for us to get involved. Flag an error and exit
    '// strMsg = "Registry value '" & strHive & "\" & strKey & "\" & strSubKey & "\" & strValue & " does not exist." & vbCRLF
    '// strMsg = strMsg & "This is a serious configuration error. Contact the Helpdesk." & vbCRLF
    '// Call Say(strMsg, blnIsCustomAction)
    '// Exit Function
    '// End If

    '//
    '// It's been that way since Win2K (apparently) and, at the time of writing (July 2007), is present in Vista.
    '// See http://www.eggheadcafe.com/software/aspnet/30166439/default-value-bug-in-stdr.aspx
    '// Superb...
    '//

    '// Now read the actual data and store it in strLocation
    blnResult_Wise = .ReadValue(strHive, strKey & "\" & strSubKey, strValue)
    If blnResult_Wise Then
    strLocation = .get_RegResult
    Else
    strMsg = "Failed to read value '" & strHive & "\" & strKey & "\" & strSubKey & "\" & strValue & "." & vbCRLF
    strMsg = strMsg & "This is a serious configuration error. Contact the Helpdesk." & vbCRLF
    Call Say(strMsg, blnIsCustomAction)
    Exit Function
    End If

    '// Before we can use strLocation, we need to throw away the executable name at the end
    intEXEPos = InStr(UCase(strLocation), "WFWI.EXE")
    If intEXEPos = 0 Then
    strMsg = "Unable to extract path to Wise executables from registry data." & vbCRLF
    strMsg = strMsg & "This is a serious configuration error. Contact the Helpdesk." & vbCRLF
    Call Say(strMsg, blnIsCustomAction)
    Exit Function
    End If

    '// We subtract only one, to retain the trailing backslash
    strLocation = Left(strLocation, (intEXEPos - 1))

    '// Throw away any leading quote marks
    If Left(strlocation, 1) = Chr(34) Then
    strlocation = Right(strlocation, Len(strlocation) - 1)
    End If

    '// Now get the registry stuff we can double-check against (Paranoid? Moi?
    strHive = "HKCR"
    strKey = "Applications\WfWI.exe\shell\EditWPS"
    strSubKey = "command"
    strValue = ""

    blnResult_Wise = .ExistKey(strHive, strKey, strSubKey)
    If Not blnResult_Wise Then
    '// Too serious for us to get involved. Flag an error and exit
    strMsg = "Registry key '" & strHive & "\" & strKey & "\" & strSubKey & " does not exist." & vbCRLF
    strMsg = strMsg & "This is a serious configuration error. Contact the Helpdesk." & vbCRLF
    Call Say(strMsg, blnIsCustomAction)
    Exit Function
    End If


    '//
    '// Serious bug!
    '// The WMI EnumValues method returns Null if the only value which exists in a key is the default one
    '// i.e. the one which RegEdit displays as "(Default)"

    '// blnResult_Wise = .ExistValue(strHive, strKey & "\" & strSubKey, strValue)
    '// If Not blnResult_Wise Then
    '// '// Too serious for us to get involved. Flag an error and exit
    '// strMsg = "Registry value '" & strHive & "\" & strKey & "\" & strSubKey & "\" & strValue & " does not exist." & vbCRLF
    '// strMsg = strMsg & "This is a serious configuration error. Contact the Helpdesk." & vbCRLF
    '// Call Say(strMsg, blnIsCustomAction)
    '// Exit Function
    '// End If

    '//
    '// Been that way since Win2K (apparently) and, at the time of writing (July 2007), is present in Vista.
    '// See http://www.eggheadcafe.com/software/aspnet/30166439/default-value-bug-in-stdr.aspx
    '// Superb...
    '//

    '// Now read the actual data and store it in strLocationCheck
    blnResult_Wise = .ReadValue(strHive, strKey & "\" & strSubKey, strValue)
    If blnResult_Wise Then
    strLocationCheck = .get_RegResult
    Else
    strMsg = "Failed to read value '" & strHive & "\" & strKey & "\" & strSubKey & "\" & strValue & "." & vbCRLF
    strMsg = strMsg & "This is a serious configuration error. Contact the Helpdesk." & vbCRLF
    Call Say(strMsg, blnIsCustomAction)
    Exit Function
    End If

    '// Before we can use strLocationCheck, we need to throw away the executable name at the end
    intEXEPos = InStr(UCase(strLocationCheck), "WFWI.EXE")
    If intEXEPos = 0 Then
    strMsg = "Unable to extract path to Wise executables from registry data." & vbCRLF
    strMsg = strMsg & "This is a serious configuration error. Contact the Helpdesk." & vbCRLF
    Call Say(strMsg, blnIsCustomAction)
    Exit Function
    End If

    '// We subtract only one, because strLocation will have a trailing backslash so we want to leave this one intact
    strLocationCheck = Left(strLocationCheck, (intEXEPos - 1))

    '// Throw away any leading quote marks
    If Left(strlocationCheck, 1) = Chr(34) Then
    strlocationCheck = Right(strlocationCheck, Len(strlocationCheck) - 1)
    End If

    '// The key and values all exist so now we need to check that they're the same.
    blnResult_Wise = StringMatch(strLocation, strLocationCheck, blnLocationsMatch)
    If Not blnLocationsMatch Then
    strMsg = "Unable to match locations for Wise executables." & vbCRLF
    strMsg = strMsg & "This is a serious configuration error. Contact the Helpdesk." & vbCRLF
    Call Say(strMsg, blnIsCustomAction)
    Exit Function
    End If

    '// If we get here, everything should be set up OK so use the first location as Wise path
    LocateWise = True
    strWisePath = strLocation
    End With
    End If
    End Function

    Sub RecurseFiles(ByVal objFolderName)
    Dim objSubFolders
    Dim objSubFolder
    Dim objFolder
    Dim objFile
    Dim strOut
    Dim intElement
    Dim strFolderName

    strFolderName = objFolderName.Path
    Set objFolder = objWSHShell.Namespace(strFolderName)
    If Err.Number <> 0 Then
    Exit Sub
    End If

    '// Write the actual data elements for each file
    For Each objFile in objFolder.Items
    Call Say("Processing " & objFolder.GetDetailsOf(objFile, 0), blnIsCustomAction)
    If strOut <> "" Then
    strOut = strOut & vbCrLf
    End If

    strOut = strOut & strFolderName

    '// We're not interested in the rest of this junk
    'For intElement = 0 to 37
    For intElement = 0 To 2
    If strOut <> "" Then
    strOut = strOut & ","
    End If
    strOut = strOut & Replace(objFolder.GetDetailsOf(objFile, intElement), ",", "")
    Next

    Call AddLineToDictionary(strOut)
    strOut = ""
    Next

    '// Check for any sub-folders and recursively process them
    Set objSubFolders = objFolderName.SubFolders
    For each objSubFolder in objSubFolders
    If LCase(objSubFolder.Name) <> "recycled" Then
    Call RecurseFiles(objSubFolder)
    End If
    Next
    End Sub

    '//=========================================================================================================
    '// Name: StringMatch
    '// Purpose: Checks if two strings match
    '// Why not use 'If strFirst = strSecond', you're asking?
    '// Well, the 'Equals' operator :
    '// - is not very fast (at string comparison)!
    '// - compares strings left to right and is smart enough to stop comparing when it spots the first difference, but
    '// - is too dumb to first do the most obvious test: comparing the lengths of the strings!
    '// Input: strFirst - the first string
    '// strSecond - the second string
    '// blnMatch - a Boolean indicating whether or not the strings matched
    '// Output: None
    '// Returns: True/False
    '//
    '//=========================================================================================================
    Function StringMatch(ByVal strFirst, ByVal strSecond, ByRef blnMatch)

    StringMatch = True

    blnMatch = False

    If LenB(strFirst) = LenB(strSecond) Then
    blnMatch = (InStrB(1, strFirst, strSecond, vbBinaryCompare) <> 0)
    End If

    End Function

    Function BrowseForFolder(ByVal strPrompt)
    '// Uses "Shell.Application" (only present in Win98 and newer)
    '// to bring up a file/folder selection window. Falls back to an
    '// ugly input box under Win95.

    'Shell32.Shell SpecialFolder constants
    Const ssfPERSONAL = 5 '// My Documents
    Const ssfDRIVES = 17 '// My Computer
    Const ssfWINDOWS = 36 '// Windows
    Const SFVVO_SHOWALLOBJECTS = 1
    Const SFVVO_SHOWEXTENSIONS = 2

    Const BIF_RETURNONLYFSDIRS = &H0001
    Const BIF_EDITBOX = &H0010
    Const BIF_VALIDATE = &H0020
    Const BIF_NEWDIALOGSTYLE = &H0040

    Dim objFolder
    Dim lngView
    Dim strPath

    If Instr(TypeName(objWSHShell), "Shell") = 0 Then
    BrowseForFolder = InputBox(strPrompt, "Select Folder", CreateObject("Scripting.FileSystemObject").GetParentFolderName(strScriptFullName))
    Exit Function
    End If

    lngView = SFVVO_SHOWALLOBJECTS Or SFVVO_SHOWEXTENSIONS
    lngView = lngView + BIF_NEWDIALOGSTYLE + BIF_VALIDATE + BIF_EDITBOX + BIF_RETURNONLYFSDIRS

    strPath = ""

    Set objFolder = objWSHShell.BrowseForFolder(&0, strPrompt, lngView, ssfDRIVES)
    Err.Clear

    On Error Resume Next
    strPath = objFolder.ParentFolder.ParseName(objFolder.Title).Path

    '// An error occurs if the user selects a drive instead of a folder
    '// so handle it here
    Select Case Err.Number
    Case 0
    BrowseForFolder = strPath
    Case 424
    '// User probably selected a drive. Let's see.
    '// First, have a fall-back option
    BrowseForFolder = objFolder.Title

    strPath = objFolder.Title
    If Len(strPath) > 0 Then
    intIndex = InStr(strPath, ":")
    If intIndex > 0 Then
    strPath = Mid(strPath, intIndex - 1, 2) & "\"
    End If
    End If
    Case Else
    End Select

    '// If the user *types (or pastes) in* an incorrect path, no error is raised
    '// so handle it here
    If Len(strPath) > 0 Then
    '// Only process if something was entered/selected.
    '// However, ignore '.' (use current folder) or '..' (use parent folder)
    If strPath = "." Or strPath = ".." Then

    BrowseForFolder = strPath
    Exit Function
    End If

    If objFSO.FolderExists(strPath) Then
    BrowseForFolder = strPath
    Exit Function
    End If

    strMsg = "The folder '" & strPath & "' does not exist."
    Call Say(strMsg, blnIsCustomAction)
    BrowseForFolder = ""
    End If
    On Error Goto 0
    End Function

    Sub Say(ByVal strMsgText, ByVal blnCustomAction)

    If blnCustomAction Then
    Dim objMSIRecord
    Const msiMessageTypeFatalExit = &H00000000 '// Premature termination, possibly fatal out of memory.
    Const msiMessageTypeError = &H01000000 '// Formatted error message, [1] is message number in Error table.
    Const msiMessageTypeWarning = &H02000000 '// Formatted warning message, [1] is message number in Error table.
    Const msiMessageTypeUser = &H03000000 '// User request message, [1] is message number in Error table.
    Const msiMessageTypeInfo = &H04000000 '// Informative message for log, not to be displayed.
    Const msiMessageTypeFilesInUse = &H05000000 '// List of files in use that need to be replaced.
    Const msiMessageTypeResolveSource = &H06000000 '// Request to determine a valid source location.
    Const msiMessageTypeOutOfDiskSpace = &H07000000 '// Insufficient disk space message.
    Const msiMessageTypeActionStart = &H08000000 '// Start of action,
    '// [1] action name,
    '// [2] description,
    '// [3] template for ACTIONDATA messages.
    Const msiMessageTypeActionData = &H09000000 '// Action data. Record fields correspond to the template of ACTIONSTART message.
    Const msiMessageTypeProgress = &H0A000000 '// Progress bar information. See the description of record fields below.
    Const msiMessageTypeCommonData = &H0B000000 '// To enable the Cancel button set [1] to 2 and [2] to 1.
    '// To disable the Cancel button set [1] to 2 and [2] to 0

    Set objMSIRecord = Session.Installer.CreateRecord(0)
    objMSIRecord.StringData(0) = strMsgText
    Session.Message msiMessageTypeError, objMSIRecord
    Set objMSIRecord = Nothing
    Else
    WScript.Echo strMsgText
    End If
    End Sub

    Sub AddLineToDictionary(ByVal strText)
    Dim strPath
    Dim strName
    Dim strType
    Dim strSize

    strPath = Split(strText, ",")(0)
    strName = Split(strText, ",")(1)
    strSize = Split(strText, ",")(2)
    strType = Split(strText, ",")(3)

    '// Include the path to make the key unique. Without it, subsequent keys wouldn't get added
    '// because the key would already exist. I leave the path in the item because I can use
    '// Split to get at it, rather than string manipulation of the key
    dicFiles.Add strPath & "\" & strName, strSize & strNameSeparator & strType & strNameSeparator & strPath

    End Sub

    Function FileNameLikeMine(ByVal strFileExtension)
    '// Returns a file name the same as the script name
    '// except for the file extension.
    Dim strExtension

    strExtension = strFileExtension
    If Len(strExtension) < 1 Then
    strExtension = "txt"
    End If

    If strExtension = "." Then
    strExtension = "txt"
    End If

    If Left(strExtension,1) = "." Then
    strExtension = Mid(strExtension, 2)
    End If

    FileNameLikeMine = Left(strScriptFullName, InstrRev(strScriptFullName, ".")) & strExtension
    End Function

    Sub ForceCScriptExecution(ByVal blnQuoteArguments)
    Dim objShellRun
    Dim strArgument
    Dim strArguments
    Dim strCmdLine
    Dim intIndex

    '// If running in CScript, do nothing
    If UCase(Right(WScript.FullName, 11)) = "CSCRIPT.EXE" Then
    Exit Sub
    End If

    If WScript.Arguments.Count > 0 Then
    strArguments = ""
    'For Each strArgument In WScript.Arguments
    ' If Len(strArguments) = 0 Then
    ' strArguments = strArgument
    ' Else
    ' strArguments = strArguments & " " & strArgument
    ' End If
    'Next

    For intIndex = 0 To (WScript.Arguments.Count - 1)
    If Len(strArguments) = 0 Then
    strArguments = WScript.Arguments(intIndex)
    Else
    strArguments = strArguments & " " & WScript.Arguments(intIndex)
    End If
    Next

    If blnQuoteArguments Then
    strArguments = Chr(34) & strArguments & Chr(34)
    End If
    End If

    '// If running in WScript, execute the script using CScript
    '// and then quit this script
    If UCase(Right(WScript.FullName, 11)) = "WSCRIPT.EXE" Then
    Set objShellRun = CreateObject("WScript.Shell")
    'objShellRun.Run "CSCRIPT.EXE """ & WScript.ScriptFullName & """", 1, False

    strCmdLine = "CSCRIPT.EXE "

    If InStr(WScript.ScriptFullName, " ") > 0 Then
    strCmdLine = strCmdLine & Chr(34)
    End If

    strCmdLine = strCmdLine & WScript.ScriptFullName

    If InStr(WScript.ScriptFullName, " ") > 0 Then
    strCmdLine = strCmdLine & Chr(34)
    End If

    If Len(strArguments) > 0 Then
    strCmdLine = strCmdLine & " "
    strCmdLine = strCmdLine & strArguments
    End If

    objShellRun.Run strCmdLine, 1, False

    Set objShellRun = Nothing
    WScript.Quit
    End If

    '// If script engine is anything else, quit with an error
    WScript.Echo "Unknown scripting engine."
    WScript.Quit
    End Sub

    '/////////////////////////////////////////////////////////////////////
    '//
    '// Name: ParseArgs
    '// Purpose: Parse the arguments using Split function and return as a dictionary object
    '// Allows simple existence and value checks throughout the rest of the script.
    '// The order that the switches are used on the command line does not matter.
    '//
    '// Syntax: You can use switches formatted in the following ways:
    '// SWITCH=<VALUE>
    '// SWITCH="<value with spaces>"
    '// /SWITCH=<VALUE>
    '// /SWITCH
    '// SWITCH=value1;value2;value3
    '//
    '// Usage and notes: If a switch is present more than once, the *last* value is used
    '//
    '// Limitations: You cannot use "/switch value" syntax: "=" is required
    '//
    '/////////////////////////////////////////////////////////////////////
    Sub ParseArgs
    Dim arrArgument
    Dim strArgument

    On Error Resume Next
    For Each strArgument In WScript.Arguments
    If InStr(strArgument, "=") > 0 Then
    arrArgument = Split(strArgument, "=", 2)

    '/ If value is specified multiple times, last one wins
    If dicArguments.Exists(Trim(arrArgument(0))) Then
    dicArguments.Remove(Trim(arrArgument(0)))
    End If

    If UBound(arrArgument) >= 1 Then
    dicArguments.Add Trim(arrArgument(0)), Trim(arrArgument(1))
    Else
    dicArguments.Add Trim(arrArgument(0)),""
    End If
    Else
    dicArguments.Add strArgument
    End If
    Next
    On Error Goto 0
    End Sub

    Function ProcessLaunch(ByVal strProcessName, ByVal strProcessPath)
    Dim objProcess
    Dim objStartup
    Dim objConfig
    Dim lngReturn

    Const intSW_HIDE = 0 '// Hides the window and activates another window.
    Const intSW_NORMAL = 1 '// Activates and displays a window.
    '// If the window is minimised or maximised, the system restores it to the original size and position.
    '// An application specifies this flag when displaying the window for the first time.
    Const intSW_SHOWMINIMIZED = 2 '// Activates the window, and displays it as a minimised window.
    Const intSW_SHOWMAXIMIZED = 3 '// Activates the window, and displays it as a maximised window.
    Const intSW_SHOWNOACTIVATE = 4 '// Displays a window in its most recent size and position.
    '// This value is similar to SW_SHOWNORMAL, except that the window is not activated.
    Const intSW_SHOW = 5 '// Activates the window, and displays it at the current size and position.
    Const intSW_MINIMIZE = 6 '// Minimises the specified window, and activates the next top level window in the Z order.
    Const intSW_SHOWMINNOACTIVE = 7 '// Displays the window as a minimised window. This value is similar to SW_SHOWMINIMZED,
    '// except that the window is not activated.
    Const intSW_SHOWNA = 8 '// Displays the window at the current size and position. This value is similar to SW_SHOW,
    '// except that the window is not activated.
    Const intSW_RESTORE = 9 '// Activates and displays the window. If the window is minimised or maximised, the system
    '// restores it to the=original size and position. An application specifies this flag when
    '// restoring a minimised window.
    Const intSW_SHOWDEFAULT = 10 '// Sets the show state based on the SW_ value that is specified in the STARTUPINFO structure
    '// passed to the CreateProcess function by the program that starts the application.
    Const intSW_FORCEMINIMIZE = 11 '// Windows Server 2003, Windows 2000, and Windows XP:
    '// Minimises a window, even when the thread that owns the window is hung.
    '// Only use this flag when minimising windows from a different thread.

    ProcessLaunch = False

    Set objStartup = objWMIService.Get("Win32_ProcessStartup")
    Set objConfig = objStartup.SpawnInstance_
    objConfig.ShowWindow = intSW_NORMAL

    Set objProcess = objWMIService.Get("Win32_Process")

    'Err.Clear
    lngReturn = objProcess.Create(strProcessName, strProcessPath, objConfig, lngProcessID)

    If lngReturn = 0 Then
    strMsg = strProcessName & " PID:" & lngProcessID & " created." & vbCRLF
    Call Say(strMsg, blnIsCustomAction)
    Else
    strMsg = "Failed to launch " & strProcessName & vbCRLF
    strMsg = strMsg & "Error " & lngReturn & ":"
    Select Case lngReturn
    Case 2
    strMsg = strMsg & "Access denied."
    Case 3
    strMsg = strMsg & "Insufficient privilege."
    Case 8
    strMsg = strMsg & "Unknown failure."
    Case 9
    strMsg = strMsg & "Path not found."
    Case 21
    strMsg = strMsg & "Invalid parameter."
    End Select

    Call Say(strMsg, blnIsCustomAction)
    Exit Function
    End If

    '// For this project, we don't need to watch the process
    'Call WatchProcess(lngProcessID)
    ProcessLaunch = True
    End Function

    '**************************************************************
    Sub KillProcess(ByVal lngProcessID)

    Dim strQuery
    Dim objProcess
    Dim colProcess

    strQuery = "Select * from Win32_Process where ProcessID=" & lngProcessID

    Set colProcess = objWMIService.ExecQuery(strQuery)
    If colProcess.Count <> 0 Then
    For Each objProcess In colProcess
    objProcess.Terminate()

    strMsg = "Process " & lngProcessID & " timed out " & Now() & vbCRLF
    Call Say(strMsg, blnIsCustomAction)
    objEventSink.Cancel()
    blnProcessTerminated =True
    Next
    End If
    End Sub

    '**************************************************************
    Sub WatchProcess(ByVal lngProcessID)

    Dim strQuery

    strQuery = "SELECT * FROM __InstanceOperationEvent " & "WITHIN 1 WHERE TargetInstance ISA 'Win32_Process' AND TargetInstance.ProcessID='" & lngProcessID & "'"

    objWMIService.ExecNotificationQueryAsync objEventSink, strQuery
    End Sub

    '**************************************************************
    Sub EVENTSINK_OnObjectReady(ByVal objInstance, ByVal objAsyncContext)

    If objInstance.Path_.Class = "__InstanceDeletionEvent" Then
    strMsg = "Process " & objInstance.TargetInstance.ProcessID & " terminated at " & Now() & vbCRLF
    Call Say(strMsg, blnIsCustomAction)

    objEventSink.Cancel()
    blnProcessTerminated = True
    WScript.Quit
    End If

    End Sub

    Sub EVENTSINK_OnCompleted(ByVal objInstance, ByVal objAsyncContext)

    strMsg = "ExecQueryAsync completed"
    Call Say(strMsg, blnIsCustomAction)
    blnProcessTerminated = True

    End Sub

    Class clsRegistry

    '// This class makes it simple to manipulate the registry on the local or a remote computer.
    '// Internally it uses the WMI StdRegProv class methods.
    '//
    '// It provides a simpler set of methods than the StdRegProv methods:
    '//
    '// * Rather than numeric values, this object's methods use string input: For example, "HKLM" instead of 0x80000002.
    '//
    '// * Rather than separate Get...Value() methods for each data type, it provides a single ReadValue() method.
    '// The get_RegResult property will contain the registry value's data, and the get_RegValueType property
    '// will contain the registry value's data type as a string (e.g. "REG_SZ").
    '//
    '// * Rather than separate Set...Value() methods for each data type, it provides a single WriteValue() method
    '// that lets you specify the data type as a string parameter.
    '//
    '// * The DeleteKey() method provides a DeleteSubKeys parameter. If True, then it will attempt to delete all subkeys
    '// of the specified subkey.
    '//
    '// * The ExistKey() and ExistValue() methods return True if the specified key or value exists in a specified subkey,
    '// or False otherwise.
    '//
    '// This class also implements the EnumValues(), EnumValuesAndData(), and EnumKey() methods:
    '//
    '// * The array outputs of these methods are accessible from the EnumResult property, which returns a reference to a
    '// Scripting.Dictionary object.
    '//
    '// * After calling the EnumValues() method, the EnumResult dictionary will contain the value names and types.
    '// The types will be stored as strings (e.g. "REG_SZ").
    '//
    '// * After calling the EnumValuesAndData() method, the EnumDict dictionary will contain the value names and contents
    '// of each value. If a value contains a REG_BINARY, the contents will be a string containing a series of the hex bytes
    '// in the data (like the registry editor). If a value contains a REG_MULTI_SZ, the multiple strings will be separated
    '// by a "|" character. This method exists mainly as a quick way for a program to output all of the values in a registry subkey.
    '//
    '// * After calling the EnumKey() method, the EnumResult dictionary will contain the names of the subkeys.
    '// The "value" parts of the dictionary will be empty strings.
    '//
    '// * For JScript, the dictToJSArray() method converts a dictionary to a JScript array.

    Dim REG_SZ
    Dim REG_EXPAND_SZ
    Dim REG_BINARY
    Dim REG_DWORD
    Dim REG_MULTI_SZ
    Dim ERR_INVALID_DATA
    Dim strSeparatorCharacter

    Dim g_RegTypes
    Dim g_EnumDict
    Dim g_RegProv
    Dim g_RegResult
    Dim g_RegValueType

    Private Sub Class_Initialize()

    REG_SZ = 1
    REG_EXPAND_SZ = 2
    REG_BINARY = 3
    REG_DWORD = 4
    REG_MULTI_SZ = 7
    ERR_INVALID_DATA = 13
    strSeparatorCharacter = "|"

    ' Contains constants and some numbers for quick lookup.
    Set g_RegTypes = CreateObject("Scripting.Dictionary")

    ' Dictionary object for EnumKey() and EnumValues().
    Set g_EnumDict = CreateObject("Scripting.Dictionary")

    ' Case-insensitive key comparisons.
    g_RegTypes.CompareMode = vbTextCompare
    g_EnumDict.CompareMode = vbTextCompare

    ' Populate the dictionary with needed data.
    With g_RegTypes
    .Add "HKCR", &H80000000
    .Add "HKEY_CLASSES_ROOT", &H80000000
    .Add "HKCU", &H80000001
    .Add "HKEY_CURRENT_USER", &H80000001
    .Add "HKLM", &H80000002
    .Add "HKEY_LOCAL_MACHINE", &H80000002
    .Add "HKEY_USERS", &H80000003
    .Add "HKEY_CURRENT_CONFIG", &H80000005
    .Add "REG_SZ", REG_SZ
    .Add REG_SZ, "REG_SZ"
    .Add "REG_EXPAND_SZ", REG_EXPAND_SZ
    .Add REG_EXPAND_SZ, "REG_EXPAND_SZ"
    .Add "REG_BINARY", REG_BINARY
    .Add REG_BINARY, "REG_BINARY"
    .Add "REG_DWORD", REG_DWORD
    .Add REG_DWORD, "REG_DWORD"
    .Add "REG_MULTI_SZ", REG_MULTI_SZ
    .Add REG_MULTI_SZ, "REG_MULTI_SZ"
    End With

    ' No valid data yet
    g_RegResult = Null
    g_RegValueType = Null

    End Sub

    Private Sub Class_Terminate()
    Set g_EnumDict = Nothing
    Set g_RegTypes = Nothing
    End Sub

    ' PROPERTY get_RegResult()
    ' Returns the result data from a registry operation.
    Function get_RegResult()
    get_RegResult = g_RegResult
    End Function

    ' PROPERTY get_RegValueType()
    ' Returns the result data's data type.
    Function get_RegValueType()
    get_RegValueType = g_RegValueType
    End Function

    ' PROPERTY get_EnumDict()
    ' Returns a reference to the dictionary populated by the Enum...() methods.
    Function get_EnumDict()
    Set get_EnumDict = g_EnumDict
    End Function

    ' METHOD Connect()
    ' Connects to the specified computer using WMI; returns True for success,
    ' or the WMI error code if it fails. If the computer is already connected,
    ' it will not attempt to connect again and will return True.
    Function Connect(ByVal ComputerName)
    Dim Result

    Connect = False

    ComputerName = UCase(Trim(ComputerName))
    If Left(ComputerName, 2) = "\\" Then
    ComputerName = Mid(ComputerName, 3)
    End If

    On Error Resume Next

    Set g_RegProv = GetObject("winmgmts:{impersonationlevel=impersonate}!//" & ComputerName & "/root/default:StdRegProv")
    Result = Err.Number
    On Error GoTo 0

    If Err.Number <> 0 Then
    Exit Function
    End If

    Connect = True
    End Function

    ' If Condition is True, return TrueValue; otherwise, return FalseValue.
    Function IIf(ByVal Condition, ByVal TrueValue, ByVal FalseValue)
    If Condition Then
    IIf = TrueValue
    Else
    IIf = FalseValue
    End If
    End Function

    ' METHOD CheckAccess()
    ' Returns True for success, False for failure.
    ' HiveName is a string representing the registry hive (e.g. "HKLM").
    ' Required is a numeric value representing the desired access level.
    ' If the WMI CheckAccess method succeeded, update g_RegResult.
    Function CheckAccess(ByVal HiveName, ByVal SubKeyName, ByVal Required)
    Dim Result
    Dim bGranted

    CheckAccess = False

    Result = g_RegProv.CheckAccess(g_RegTypes(HiveName), SubKeyName, Required, bGranted)

    g_RegResult = IIf(Result = 0, bGranted, Null)
    g_RegValueType = Null

    If Result <> 0 Then
    Exit Function
    End If

    CheckAccess = True
    End Function

    ' METHOD CreateKey()
    ' Returns True for success, False for failure.
    ' HiveName is a string representing the registry hive (e.g. "HKLM").
    Function CreateKey(ByVal HiveName, ByVal SubKeyName)
    Dim Result

    CreateKey = False

    Result = g_RegProv.CreateKey(g_RegTypes(HiveName), SubKeyName)

    If Result <> 0 Then
    Exit Function
    End If

    CreateKey = True
    End Function

    ' METHOD DeleteKey()
    ' Returns True for success, False for failure.
    ' HiveName is a string representing the registry hive (e.g. "HKLM").
    ' If DeleteSubKeys is True, then the method will attempt to delete all
    ' subkeys of the specified subkey before deleting the specified subkey.
    ' If DeleteSubKeys is True and the method encounters an error deleting
    ' a subkey under the specified subkey, it will abort.
    Function DeleteKey(ByVal HiveName, ByVal SubKeyName, ByVal DeleteSubKeys)
    Dim Result
    Dim strRegSubKey
    Dim strRegKey
    Dim Names
    Dim I

    DeleteKey = False

    '// If the key isn't present, then DeleteKey will be True!

    '// In order to use ExistKey, we have to split SubKeyName
    '// at the final '\'. This is imposed on us by the way
    '// that the WMI registry object works.

    '// If there's no backslash in SubKeyName, we have to fail
    I = InStrRev(SubKeyName, "\")
    If I = 0 Then
    Exit Function
    End If

    strRegSubKey = Left(SubKeyName, I - 1)
    strRegKey = Right(SubKeyName, Len(SubKeyName) - I)

    If Not ExistKey(HiveName, strRegSubKey, strRegKey) Then
    DeleteKey = True
    Exit Function
    End If

    If DeleteSubKeys Then
    Result = g_RegProv.EnumKey(g_RegTypes(HiveName), SubKeyName, Names)
    If (Result = 0) And (Not IsNull(Names)) Then
    For I = 0 To UBound(Names)
    DeleteKey = DeleteKey(HiveName, _
    SubKeyName & "\" & Names(I), DeleteSubKeys)
    If DeleteKey <> 0 Then
    Exit Function
    End if
    Next
    End If
    End If

    Result = g_RegProv.DeleteKey(g_RegTypes(HiveName), SubKeyName)

    If Result <> 0 Then
    Exit Function
    End If

    DeleteKey = True
    End Function

    ' METHOD WriteValue()
    ' Returns True for success, False for failure.
    ' HiveName is a string representing the registry hive (e.g. "HKLM").
    ' ValueType is a string representing the value's type (e.g. "REG_SZ").
    ' If you specify "REG_BINARY" or "REG_MULTI_SZ" for the value type,
    ' RegData must contain a safearray (VB array) of data. If you are using
    ' JScript, you can use the toVBarray() method to convert the JScript
    ' array to a safearray, but keep in mind that it must be a zero-based
    ' array with contiguous elements.
    Function WriteValue(ByVal HiveName, ByVal SubKeyName, ByVal ValueName, ByVal ValueType, ByVal RegData)
    Dim Result

    WriteValue = False
    If ValueName = "" Then
    Result = g_RegProv.SetStringValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    Else
    Select Case UCase(ValueType)
    Case "REG_SZ"
    Result = g_RegProv.SetStringValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    Case "REG_EXPAND_SZ"
    Result = g_RegProv.SetExpandedStringValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    Case "REG_BINARY"
    Result = g_RegProv.SetBinaryValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    Case "REG_DWORD"
    Result = g_RegProv.SetDWORDValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    Case "REG_MULTI_SZ"
    Result = g_RegProv.SetMultiStringValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    Case Else
    Result = ERR_INVALID_DATA
    End Select
    End If

    If Result <> 0 Then
    Exit Function
    End If

    WriteValue = True
    End Function

    ' METHOD ExistValue()
    ' Returns True if the specified value exists, or False if not.
    Function ExistValue(ByVal HiveName, ByVal SubKeyName, ByVal ValueName)
    Dim Exists
    Dim Result
    Dim Names
    Dim Types
    Dim I

    Exists = False

    Result = g_RegProv.EnumValues(g_RegTypes(HiveName), SubKeyName, Names, Types)

    If (Result = 0) And (Not IsNull(Names)) Then
    For I = 0 To UBound(Names)
    Exists = UCase(Names(I)) = UCase(ValueName)
    If Exists Then
    Exit For
    End If
    Next
    End If

    ExistValue = Exists
    End Function

    ' METHOD ReadValue()
    ' Returns True for success, False for failure.
    ' HiveName is a string representing the registry hive (e.g. "HKLM").
    ' If the WMI method succeeds, the Result property will contain the
    ' registry data and the ValueType property will contain a string
    ' representing the data type (e.g. "REG_SZ").
    Function ReadValue(ByVal HiveName, ByVal SubKeyName, ByVal ValueName)
    Dim Result
    Dim Names
    Dim Types
    Dim I
    Dim RegData

    ReadValue = False
    ' If ValueName is blank, retrieve the key's (Default) value (REG_SZ)
    If ValueName = "" Then
    Result = g_RegProv.GetStringValue(g_RegTypes(HiveName), SubKeyName, ValueName, RegData)
    If Result = 0 Then
    g_RegResult = RegData: g_RegValueType = "REG_SZ"
    Else
    g_RegResult = Null: g_RegValueType = Null
    End If
    Else
    Result = g_RegProv.EnumValues(g_RegTypes(HiveName), SubKeyName, Names, Types)
    If (Result = 0) And (Not IsNull(Names)) Then
    For I = 0 To UBound(Names)
    If UCase(Names(I)) = UCase(ValueName) Then
    Select Case Types(I)
    Case REG_SZ
    Result = g_RegProv.GetStringValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    g_RegValueType = IIf(Result = 0, g_RegTypes(REG_SZ), Null)
    Exit For
    Case REG_EXPAND_SZ
    Result = g_RegProv.GetExpandedStringValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    g_RegValueType = IIf(Result = 0, g_RegTypes(REG_EXPAND_SZ), Null)
    Exit For
    Case REG_BINARY
    Result = g_RegProv.GetBinaryValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    g_RegValueType = IIf(Result = 0, g_RegTypes(REG_BINARY), Null)
    Exit For
    Case REG_DWORD
    Result = g_RegProv.GetDWORDValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    g_RegValueType = IIf(Result = 0, g_RegTypes(REG_DWORD), Null)
    Exit For
    Case REG_MULTI_SZ
    Result = g_RegProv.GetMultiStringValue(g_RegTypes(HiveName), _
    SubKeyName, _
    ValueName, _
    RegData)
    g_RegValueType = IIf(Result = 0, g_RegTypes(REG_MULTI_SZ), Null)
    Exit For
    Case Else
    Result = ERR_INVALID_DATA
    g_RegResult = Null
    g_RegValueType = Null
    Exit For
    End Select
    End If
    Next
    g_RegResult = IIf(Result = 0, RegData, Null)
    End If
    End If

    If Result <> 0 Then
    Exit Function
    End If

    ReadValue = True
    End Function

    ' METHOD DeleteValue()
    ' Returns True for success, False for failure.
    ' HiveName is a string representing the registry hive (e.g. "HKLM").
    Function DeleteValue(ByVal HiveName, ByVal SubKeyName, ByVal ValueName)
    Dim Result

    DeleteValue = False

    '// If the value isn't present, then DeleteValue will be True!

    If Not ExistValue(HiveName, SubKeyName, ValueName) Then
    DeleteValue = True
    Exit Function
    End If

    Result = g_RegProv.DeleteValue(g_RegTypes(HiveName), SubKeyName, ValueName)

    If Result <> 0 Then
    Exit Function
    End If

    DeleteValue = True
    End Function

    ' METHOD ExistKey()
    ' Returns True if the specified subkey exists, or False if not.
    Function ExistKey(ByVal HiveName, ByVal SubKeyName, ByVal KeyName)
    Dim Exists
    Dim Result
    Dim Names
    Dim I

    Exists = False

    Result = g_RegProv.EnumKey(g_RegTypes(HiveName), SubKeyName, Names)

    If (Result = 0) And (Not IsNull(Names)) Then
    For I = 0 To UBound(Names)
    Exists = UCase(KeyName) = UCase(Names(I))
    If Exists Then
    Exit For
    End If
    Next
    End If

    ExistKey = Exists
    End Function

    ' METHOD EnumKey()
    ' Returns True for success, False for failure.
    ' Populates the EnumDict dictionary's key names with the subkeys in the
    ' specified subkey. The dictionary's value names will be blank strings.
    Function EnumKey(ByVal HiveName, ByVal SubKeyName)
    Dim Result
    Dim Names
    Dim I

    EnumKey = False

    Result = g_RegProv.EnumKey(g_RegTypes(HiveName), SubKeyName, Names)

    g_EnumDict.RemoveAll

    If (Result = 0) And (Not IsNull(Names)) Then
    For I = 0 To UBound(Names)
    g_EnumDict.Add Names(I), ""
    Next
    End If

    'If Result = 0 Then
    If (Result = 0) And (Not IsNull(Names)) Then
    EnumKey = True
    End If

    End Function

    ' METHOD EnumValues()
    ' Returns True for success, False for failure.
    ' Populates the EnumDict property's key/value pairs with
    ' the value entries and their corresponding data types.
    Function EnumValues(ByVal HiveName, ByVal SubKeyName)
    Dim Result
    Dim Names
    Dim Types
    Dim I

    EnumValues = False

    Result = g_RegProv.EnumValues(g_RegTypes(HiveName), SubKeyName, Names, Types)

    g_EnumDict.RemoveAll

    If (Result = 0) And (Not IsNull(Names)) Then
    For I = 0 To UBound(Names)
    g_EnumDict.Add Names(I), g_RegTypes(Types(I))
    Next
    End If

    'If Result = 0 Then
    If (Result = 0) And (Not IsNull(Names)) Then
    EnumValues = True
    End If

    End Function

    ' Returns the byte N in hexadecimal notation with a leading zero.
    Function ToHex(ByVal N)
    ToHex = IIf(N < &H10, "0" & Hex(N), Hex(N))
    End Function

    ' METHOD EnumValuesAndData()
    ' Returns True for success, False for failure.
    ' Populates the EnumDict property's key/value pairs with
    ' the value entries and their contents. For REG_BINARY and REG_MULTI_SZ
    ' values, they will be represented as strings with | strSeparatorCharacters.
    Function EnumValuesAndData(ByVal HiveName, ByVal SubKeyName)
    Dim Result
    Dim Names
    Dim Types
    Dim I
    Dim RegData
    Dim J
    Dim S

    EnumValuesAndData = False
    Result = g_RegProv.EnumValues(g_RegTypes(HiveName), SubKeyName, Names, Types)

    g_EnumDict.RemoveAll

    If (Result = 0) And (Not IsNull(Names)) Then
    For I = 0 To UBound(Names)
    Select Case Types(I)
    Case REG_SZ
    Result = g_RegProv.GetStringValue(g_RegTypes(HiveName), _
    SubKeyName, _
    Names(I), _
    RegData)
    If Result = 0 Then
    g_EnumDict.Add Names(I), RegData
    End If
    Case REG_EXPAND_SZ
    Result = g_RegProv.GetExpandedStringValue(g_RegTypes(HiveName), _
    SubKeyName, _
    Names(I), _
    RegData)
    If Result = 0 Then
    g_EnumDict.Add Names(I), RegData
    End If
    Case REG_BINARY
    Result = g_RegProv.GetBinaryValue(g_RegTypes(HiveName), _
    SubKeyName, _
    Names(I), _
    RegData)
    If Result = 0 Then
    S = ""
    For J = 0 To UBound(RegData)
    S = IIf(S <> "", S & " " & ToHex(RegData(J)), ToHex(RegData(J)))
    Next
    g_EnumDict.Add Names(I), S
    End If
    Case REG_DWORD
    Result = g_RegProv.GetDWORDValue(g_RegTypes(HiveName), _
    SubKeyName, _
    Names(I), _
    RegData)
    If Result = 0 Then
    g_EnumDict.Add Names(I), RegData
    End If
    Case REG_MULTI_SZ
    Result = g_RegProv.GetMultiStringValue(g_RegTypes(HiveName), _
    SubKeyName, _
    Names(I), _
    RegData)
    If Result = 0 Then
    S = ""
    For J = 0 To UBound(RegData)
    S = IIf(S <> "", S & strSeparatorCharacter & RegData(J), RegData(J))
    Next
    g_EnumDict.Add Names(I), S
    End If
    Case Else
    Result = ERR_INVALID_DATA
    End Select
    Next
    End If

    'If Result = 0 Then
    If (Result = 0) And (Not IsNull(Names)) Then
    EnumValuesAndData = True
    End If

    End Function

    End Class
Please log in to comment

Answers

0

Sounds like you don't need to do anything with subfolders, so you can probably simplify a bit like this (untested):

 

strWatchFolder ="c:\ACHTEST\"   
strProcessedFolder ="c:\ACHFTP\"   'Moves files here after

Set fso = CreateObject("Scripting.FileSystemObject")

'Loop through files in the Watch folder
For Each oFile in fso.GetFolder(strWatchFolder).Files
    If LCase(fso.GetExtensionName(oFile))="ach" Then
        ProcessFile oFile.Path
    End If
Next
 

Sub ProcessFile(strFilePath)
    ON ERROR RESUME NEXT
    Const ForReading = 1

    Set objTextFile = fso.OpenTextFile(strFilePath, ForReading)

    sRec9 = 0
    Do Until objTextFile.AtEndOfStream' Loop until end of file.
        sRecord  = objTextFile.Readline' Read line into variable.
        If Left(sRecord, 1) = "9" Then
            sRec9 = 1                        ' EOF record found so change flag
            sTotalDebit = FormatCurrency((Mid(sRecord, 32, 12) / 100),2)
            sTotalCredit = FormatCurrency((Mid(sRecord, 44, 12) / 100),2)
            Exit Do
        End If
    Loop

    ' Close file.
    objTextFile.Close

    If sRec9 = 0 Then
        MsgBox "BAD FILE - EOF record not found" & vbCrLf & vbCrLf & strFilePath,vbExclamation,"Bad File"     ' EOF record not found
    Else
        Response = MsgBox("Please verify File is current: " & strFilePath & vbCrLf & vbCrLf _
            & "OK To Transfer to Spectrum?", vbQuestion + vbYesNo,"Verify File")
        If Response = vbNo Then 
            MsgBox "Transfer Aborted",vbInformation,"Aborted"     ' Abort Transfer
        Else
            err.clear
            fso.MoveFile oFile.Path, strProcessedFolder
            If err.number Then
                MsgBox "Error #" & err.number & " " & err.description,vbExclamation,"Error"
            Else
                MsgBox "Transfer to HP Successful",vbInformation,"Success"
            End If
        End If
    End If

End Sub

 
Answered 07/23/2013 by: joeostrander
Third Degree Blue Belt

  • dugullett i try it without the quote i got nothing
Please log in to comment
Answer this question or Comment on this question for clarity
Admin Script Editor
Admin Script Editor is an integrated scripting environment available free here at ITNinja

Share