Unable to pin .exe with parameter to Taskbar/Start Menu - windows

I'm trying to write a .vbs script to pin an .exe to my taskbar and start menu.
However, the .exe will only run if I pass in a package parameter.
Here's the target of the shortcut:
"C:\Program Files (x86)\Launch\AppLauncher.exe" package=TEST
I currently have the following for code but I get the error message attached when I try and run it.
Const a = """"
arrActions = Array( _
"pin", "Start Menu", """C:\Program Files (x86)\Launch\AppLauncher.exe"" package=TEST", _
"pin", "Taskbar", """C:\Program Files (x86)\Launch\AppLauncher.exe"" package=TEST" _ )
For intAction = 0 To (UBound(arrActions) - 2) Step 3
arrFileNames = Array(arrActions(intAction + 2))
'strMode can be "Pin" or "Unpin"
strMode = arrActions(intAction)
'strLocation can be "Start Menu" or "Taskbar" or "Both"
strLocation = arrActions(intAction + 1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShellApp = CreateObject("Shell.Application")
Set objShell = CreateObject("WScript.Shell")
If LCase(strLocation) = "both" Then
arrLocations = Array("Start Menu", "Taskbar")
Else
arrLocations = Array(strLocation)
End If
For Each strLocation In arrLocations
If LCase(strMode) <> "pin" And LCase(strMode) <> "unpin" Then
WScript.Echo "Mode is incorrect. Please set to ""pin"" or ""unpin""."
WScript.Quit
ElseIf LCase(strLocation) <> "start menu" And LCase(strLocation) <> "taskbar" Then
WScript.Echo "Location is incorrect. Please set to ""Start Menu"" or ""Taskbar""."
WScript.Quit
Else
strMode = LCase(strMode)
If strMode = "pin" Then
strVerb = LCase(strMode & " to " & strLocation)
strMessage = " has been " & strMode & "ned to the " & strLocation & "."
ElseIf strMode = "unpin" Then
strVerb = LCase(strMode & " from " & strLocation)
strMessage = " has been " & strMode & "ned from the " & strLocation & "."
End If
For Each strFilePath In arrFileNames
If LCase(strFilePath) = "unpin_all" And strMode = "unpin" Then
strPinLocation = objShell.ExpandEnvironmentStrings("%APPDATA%") & _
"\Microsoft\Internet Explorer\Quick Launch\User Pinned\" & _
Replace(strLocation, " ", "") & "\"
For Each objFile In objFSO.GetFolder(strPinLocation).Files
strFullPath = objFile.Path
'Set objFile = objFSO.GetFile(objFile.Path)
Set objFolder = objShellApp.Namespace(objFile.ParentFolder & "\")
Set objFolderItem = objFolder.ParseName(objFile.Name)
Set colVerbs = objFolderItem.Verbs
For Each objVerb In colVerbs
If LCase(Replace(objVerb.name, "&", "")) = strVerb Then
objVerb.DoIt
WScript.Echo strFullPath & strMessage
End If
Next
Next
Else
If objFSO.FileExists(strFilePath) = True Then
Set objFile = objFSO.GetFile(strFilePath)
Set objFolder = objShellApp.Namespace(objFile.ParentFolder & "\")
Set objFolderItem = objFolder.ParseName(objFile.Name)
Set colVerbs = objFolderItem.Verbs
blnOptionFound = False
For Each objVerb In colVerbs
If LCase(Replace(objVerb.name, "&", "")) = strVerb Then
objVerb.DoIt
blnOptionFound = True
End If
Next
If blnOptionFound = True Then
WScript.Echo strFilePath & strMessage
Else
WScript.Echo "Unable to " & strMode & " " & strFilePath & _
" from the " & strLocation & ". The verb does not exist."
End If
Else
WScript.Echo "Could not find " & strFilePath
End If
End If
Next
End If
Next
Next
Error message

Related

VB script to scan latest log file for errors

I have a VB script which scans the mentioned log file for errors and sends a notification through an email.
How can I scan the latest log file in the folder? For example, Filename1.070615 (Filename1.mmddyy) is a log file. After a certain size, the logfile switches to new file with the same name but different date: Filename1.070615.
cdoSendUsingPort = 2, _
Const ForReading = 1
Dim intStartAtLine, strFileCreateddate, i, strResults, strTextToScanFor, bStartFromScratch
Dim strLastCheckedFor, strArrayToString, strSubject, strMailFrom, strMailTo
strMailto = "<Emailaddress>"
strMailFrom = "<FromAddress>"
strSubject = "Log scanner"
strSMTPServer = "x.x.x.x"
FileToRead = "D:\LOG\filename1.mmddyy"
arrTextToScanFor = Array("error","another thing")
Set WshShell = WScript.CreateObject("WScript.Shell")
searchkey = replace(replace(filetoread,":",""),"\","_")
On Error Resume Next
strLastFileCheckedCreateDate = WshShell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CreateDate")
strLastFileLastLineChecked = WshShell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked")
strLastCheckedFor = WshSHell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CheckForString")
iLastCheckedLine = WshSHell.RegRead("HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked")
On Error GoTo 0
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
Set varFile = objFSO.GetFile(FileToRead)
arrLastCheckedForText = split(strLastCheckedFor,",")
strFileCreateDate = varfile.datecreated
strFileModifiedDate = varfile.datelastmodified
sStatus = "<li>Using mail server: " & strSMTPServer & "</li><li>Running from: " & wscript.scriptfullname & "</li>"
Set objTextFile = objFSO.OpenTextFile(FileToRead, ForReading)
objTextFile.ReadAll
iLineCount = objTextFile.Line
objTextFile.close
If strLastCheckedFor = "" Then
bStartFromScratch = true
sStatus = sStatus & "<li>First run of script against string search</li>" & vbcrlf
ElseIf ubound(arrTextToScanFor) <> ubound(arrLastCheckedForText) Then
bStartFromScratch = true
sStatus = sStatus & "<li>Count of string search criteria has changed</li>" & vbcrlf
Else
For each strItem in arrTextToScanFor
Else
bStartFromScratch = true
'MsgBox strResults
End If
If bStartFromScratch = true Then
sStatus = sStatus & "<li>String search criteria does not match prior search</li>" & vbcrlf
End If
Next
End If
If cint(iLineCount) < cint(iLastCheckedLine) Then
bStartFromScratch = true
sStatus = sStatus & "<li>Last line checked (" & iLastCheckedLine & ") is greater than total line count (" & iLineCount & ") in file</li>"
End If
If CStr(strFileCreateDate) = CStr(strLastFileCheckedCreateDate) and bStartFromScratch <> true Then
intStartAtLine = strLastFileLastLineChecked
If bStartFromScratch <> true then
sStatus = sStatus & "<li>Continuing search from line " & intStartAtLine & "</li>" & vbcrlf
End If
ElseIf strFileCreateDate <> strLastFileCheckedCreateDate or bStartFromScratch = true Then
intStartAtLine = 0
If bStartFromScratch <> true then
sStatus = sStatus & "<li>File created date has changed, starting search from line 0</li>" & vbcrlf
End If
End If
i = 0
Dim strNextLine
For each strItem in arrTextToScanFor
strArrayToString = strArrayToString & delim & strItem
delim = ","
Next
Set objTextFile = objFSO.OpenTextFile(FileToRead, ForReading)
Do While objTextFile.AtEndOfStream <> True
If i < CInt(intStartAtLine) Then
objTextFile.skipline
Else
'MsgBox i
strNextLine = objTextFile.Readline
For each strItem in arrTextToScanFor
If InStr(LCase(strNextLine),LCase(strItem)) Then
strResults = "<span style='font-family:courier-new;color:#696969'><span style='font-weight:bold;background-color:#BEF3F3'>Line " & i & ":</span> " & replace(lcase(strNextLine),lcase(strItem),"<span style='background-color:#FFFF81'>" & strItem & "</span>") & "</span><br>" & vbcrlf & strResults
bSendMail = true
End If
Next
End If
i = i + 1
Loop
objTextFile.close
Set WshShell = CreateObject("WScript.Shell")
'Let's save our settings for next time.
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\FileChecked", FileToRead, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CreateDate", strFileCreateDate, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastLineChecked", i, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\LastScanned", Now, "REG_SZ"
WshShell.RegWrite "HKCU\Software\RDScripts\CheckTXTFile\" & searchkey & "\CheckForString",strArrayToString, "REG_SZ"
set WshShell = nothing
strFileSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>File path:</td><td>" & FileToRead & "</td></tr>"
strFileCreateDateSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Created date:</td><td>" & strFileCreateDate & "</td></tr>"
strFileModifiedDateSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Modified date:</td><td>" & strFileModifiedDate & "</td></tr>"
strArraySummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Text string(s):</td><td>" & strArrayToString & "</td></tr>"
strFileLineSummary = "<tr><td style='font-family:calibri;font-weight:bold;color:darkblue;width:200px'>Last line checked:</td><td>" & i & "</td></tr>"
strSummary = strFileSummary & strFileCreateDateSummary & strFileModifiedDateSummary & strArraySummary & strFileLineSummary
strBodyContent = "<table style='font-family:calibri;'>" & strSummary & "</table><br><br><span style='font-size:large;'>Entries:</span><br>" & strResults & "<div style='padding-top:30px;font-size:x-small'><br><div style='font-weight:bold;font-family:calibri;color:black;'>Job Details:<ul style='font-weight:normal;font-family:calibri;color:darkgray;'>" & sStatus & "</ul></div></div>"
on error goto 0
'Send the email if need be.
If bSendMail = true Then Call sendmail(strMailFrom,strMailTo,strSubject,strBodyContent)
'------------------------------------------------------------------------
'Function EmailFile - email the warning file
'------------------------------------------------------------------------
Function SendMail(strFrom,strTo,strSubject,strMessage)
Dim iMsg, iConf, Flds
On Error GoTo 0
'// Create the CDO connections.
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
'// SMTP server configuration.
With Flds
.Item(cdoSendUsingMethod) = cdoSendUsingPort
'// Set the SMTP server address here.
.Item(cdoSMTPServer) = strSMTPServer
.Update
End With
'// Set the message properties.
With iMsg
Set .Configuration = iConf
.To = strMailTo
.From = strMailFrom
.Subject = strSubject
.htmlbody = strMessage
End With
'iMsg.HTMLBody = strMessage
'// Send the message.
iMsg.Send ' send the message.
If CStr(err.number) <> 0 Then
Else
End If
End Function
It would be a bit easier if your log files were named filename1.yymmdd.
Nevertheless, we can use a regex to not only verify the filename but also swap the date components to put them in our desired format!
Set re = New RegExp
re.Pattern = "^(filename1\.)(\d{2})(\d{2})(\d{2})$"
Set fso = CreateObject("Scripting.FileSystemObject")
For Each objFile In fso.GetFolder("d:\log").Files
If re.Test(objFile.Name) Then
strCompareName = re.Replace(objFile.Name, "$1$4$2$3")
If strCompareName > strLatest Then strLatest = strCompareName
End If
Next
' Switch the name back...
strLatest = re.Replace(strLatest, "$1$3$4$2")
WScript.Echo "The latest file is: " & strLatest
This line:
strCompareName = re.Replace(objFile.Name, "$1$4$2$3")
changes the format from mmddyy to yymmdd and saves it in a string for comparison.
Once we've finished our comparisons, we just need to take the latest file we found and reverse the process:
strLatest = re.Replace(strLatest, "$1$3$4$2")
to get the original filename back!

Using VBS to Backup a file

I managed to find this script to use and backup my files, this is a little more complicated then I need it to be.
I do not need to enter a backup path - from and too every time I run it however this is a handy option for other projects but I would like to backup from a set file path and save to a set file path to save time.
The other issue with this script is the Cancel button does not work, this is an issue I have had before and fixed but I cannot remember how to make the Cancel button function.
Option Explicit
Dim objFSO, strSourceFolder, strDestFolder, strExclusion, strPrompt
Set objFSO = CreateObject("Scripting.FileSystemObject")
strSourceFolder = InputBox("Enter the Source directory path you wish to backup")
strDestFolder = InputBox("Enter the Destination directory path you wish to backup your Data to... (C:/Backup, //Backup-Server/Remotebackup")
Wscript.Echo "Click (OK) to start the Backup!"
CopyFolderStructure strSourceFolder, strDestFolder, strExclusion
Function CopyFolderStructure(strSource, strDestination, strExcludedExt)
Const OVER_WRITE_FILES = True
Dim objDir, objFolder, objFiles, strCurExt, intX, arrExt, blnExclude
Set objDir = objFSO.GetFolder(strSource)
If Not objFSO.FolderExists(strDestination & "\" & objDir.Name) Then
objFSO.CreateFolder(strDestination & "\" & objDir.Name)
End If
If Not IsNoData(strExcludedExt) Then
arrExt = Split(strExcludedExt, ",")
blnExclude = False
End If
For Each objFiles In objFSO.GetFolder(strSource).Files
If Not IsNoData(strExcludedExt) Then
strCurExt = objFSO.GetExtensionName(objFiles.Name)
For intX = 0 To UBound(arrExt)
If LCase(strCurExt) = arrExt(intX) Then
blnExclude = True
Exit For
Else
blnExclude = False
End If
Next
If Not blnExclude Then
objFSO.CopyFile strSource & "\" & objFiles.Name, strDestination & "\" & objDir.Name & "\" & objFiles.Name, OVER_WRITE_FILES
End If
Else
objFSO.CopyFile strSource & "\" & objFiles.Name, strDestination & "\" & objDir.Name & "\" & objFiles.Name, OVER_WRITE_FILES
End If
Next
For Each objFolder In objFSO.GetFolder(strSource).SubFolders
CopyFolderStructure objFolder.Path, strDestination & "\" & objDir.Name, strExcludedExt
Next
End Function
Function BrowseForFolderDialogBox(strTitle)
Const WINDOW_HANDLE = 0
Const NO_OPTIONS = &H0001
Dim objShellApp
Dim objFolder
Dim objFldrItem
Dim objPath
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.BrowseForFolder(WINDOW_HANDLE, strTitle , NO_OPTIONS)
If IsNoData(objFolder) Then
WScript.Echo "You choose to cancel. This will stop this script."
Wscript.Quit
Else
Set objFldrItem = objFolder.Self
objPath = objFldrItem.Path
BrowseForFolderDialogBox = objPath
Set objShellApp = Nothing
Set objFolder = Nothing
Set objFldrItem = Nothing
End If
End Function
Function IsNoData(varVal2Check)
On Error Resume Next
If IsNull(varVal2Check) Or IsEmpty(varVal2Check) Then
IsNoData = True
Else
If IsDate(varVal2Check) Then
IsNoData = False
Elseif varVal2Check = "" Then
IsNoData = True
ElseIf Not IsObject(varVal2Check) Then
IsNoData = False
Else
IsNoData = False
End If
End If
End Function
Wscript.Echo "Backup Has Completed Successfully"
Next code snippet could help (see Arguments Property (WScript Object), InputBox Function and MsgBox Function reference). Note that the Echo method behaves differently depending on which WSH engine you are using.
Option Explicit
Dim objFSO, strSourceFolder, strDestFolder, strExclusion, strPrompt
Dim iBut, sRes, sMes, objArgs
sRes = Wscript.ScriptName
sMes = vbCRLF & "(click (Cancel) button to discard)"
Set objArgs = WScript.Arguments
If objArgs.Count > 1 Then
strSourceFolder = objArgs( 0)
strDestFolder = objArgs( 1)
Else
strSourceFolder = "C:/DataToBackup"
strDestFolder = "D:/Backup"
strSourceFolder = InputBox( "Path you wish to backup" & sMes _
, "Source directory", strSourceFolder)
sRes = sRes & vbNewLine & "strSourceFolder """ & strSourceFolder & """"
If strSourceFolder = "" Then
strDestFolder = ""
Else
strDestFolder = InputBox( "Path you wish to backup your Data to" & sMes _
, "Destination directory", strDestFolder)
sRes = sRes & vbNewLine & "strDestFolder """ & strDestFolder & """"
End If
End If
If strDestFolder = "" Then
sRes = sRes & vbNewLine & "Backup Cancelled!"
Wscript.Echo sRes
Wscript.Quit
Else
iBut=MsgBox(sRes & sMes, vbOKCancel + vbQuestion _
, "Click (OK) to start the Backup!")
If iBut <> vbOK Then Wscript.Quit
End If
'''' for debugging only:
Wscript.Quit '''' for debugging only:
'''' for debugging only:
Set objFSO = CreateObject("Scripting.FileSystemObject")
CopyFolderStructure strSourceFolder, strDestFolder, strExclusion
'''''' and so on...

attempting to run multiple scripts, have them all output to one file, and all use the same IP address

I have a couple questions and am hoping this is the correct place.
basically what i want to do is to be able to remotely get info about a domain computer.
i have 3 seperate scripts that give me 1( IP configuration, comp name ... ), 2 ( installed software ) and 3 ( mapped drives ).
the first two ask for the IP/computer name and the 3rd i have to input that into the script... i would like to only have to input the IP address once and have it work for all 3
secondly i would like the output file that this info is put into to be named like the installed software script does and then just have the other two scripts add ( ammend ) to the already created output.
I am super new to vbs so any help would be awesome
SCRIPT 1 ( gets IP configuration )
dim strComputer 'for computer name or IP
dim colAdapters 'collection of adapters
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile("output.txt", True)
strComputer = ""
'open a dialog box asking for the computer name/IP
do
strComputer = inputbox( "Please enter a computername/IP, or . for local computer", "Input" )
Loop until strComputer <> "" 'run until a name/IP is entered
Set objWMIService = GetObject ("winmgmts:" & "!\\" & strComputer & "\root\cimv2") 'open the WMI service on the remote PC
Set colAdapters = objWMIService.ExecQuery ("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")
'go through the list of adapters and gather data
For Each objAdapter in colAdapters
objFile.Writeline "Host name: " & objAdapter.DNSHostName
objFile.Writeline "DNS domain: " & objAdapter.DNSDomain
objFile.Writeline "DNS suffix search list: " & objAdapter.DNSDomainSuffixSearchOrder
objFile.Writeline "Description: " & objAdapter.Description
objFile.Writeline "Physical address: " & objAdapter.MACAddress
objFile.Writeline "DHCP enabled: " & objAdapter.DHCPEnabled
If Not IsNull(objAdapter.IPAddress) Then
For i = LBound(objAdapter.IPAddress) To UBound(objAdapter.IPAddress)
objFile.Writeline "IP address: " & objAdapter.IPAddress(i)
Next
End If
If Not IsNull(objAdapter.IPSubnet) Then
For i = LBound(objAdapter.IPSubnet) To UBound(objAdapter.IPSubnet)
objFile.Writeline "Subnet: " & objAdapter.IPSubnet(i)
Next
End If
If Not IsNull(objAdapter.DefaultIPGateway) Then
For i = LBound(objAdapter.DefaultIPGateway) To UBound(objAdapter.DefaultIPGateway)
objFile.Writeline "Default gateway: " & objAdapter.DefaultIPGateway(i)
Next
End If
objFile.Writeline "DHCP server: " & objAdapter.DHCPServer
If Not IsNull(objAdapter.DNSServerSearchOrder) Then
For i = LBound(objAdapter.DNSServerSearchOrder) To UBound(objAdapter.DNSServerSearchOrder)
objFile.Writeline "DNS server: " & objAdapter.DNSServerSearchOrder(i)
Next
End If
objFile.Writeline "Primary WINS server: " & objAdapter.WINSPrimaryServer
objFile.Writeline "Secondary WINS server: " & objAdapter.WINSSecondaryServer
objFile.Writeline "Lease obtained: " & objAdapter.DHCPLeaseObtained
objFile.Writeline "Lease expires: " & objAdapter.DHCPLeaseExpires
Next
SCRIPT 2 ( gets installed software )
Option Explicit
Dim sTitle
sTitle = "InstalledPrograms.vbs by Bill James"
Dim StrComputer
strComputer = InputBox("Enter I.P. or name of computer to check for " & _
"installed software (leave blank to check " & _
"local system)." & vbcrlf & vbcrlf & "Remote " & _
"checking only from NT type OS to NT type OS " & _
"with same Admin level UID & PW", sTitle)
If IsEmpty(strComputer) Then WScript.Quit
strComputer = Trim(strComputer)
If strComputer = "" Then strComputer = "."
'Wscript.Echo GetAddRemove(strComputer)
Dim sCompName : sCompName = GetProbedID(StrComputer)
Dim sFileName
sFileName = sCompName & "_" & GetDTFileName() & "_Software.txt"
Dim s : s = GetAddRemove(strComputer)
If WriteFile(s, sFileName) Then
'optional prompt for display
If MsgBox("Finished processing. Results saved to " & sFileName & _
vbcrlf & vbcrlf & "Do you want to view the results now?", _
4 + 32, sTitle) = 6 Then
WScript.CreateObject("WScript.Shell").Run sFileName, 9
End If
End If
Function GetAddRemove(sComp)
'Function credit to Torgeir Bakken
Dim cnt, oReg, sBaseKey, iRC, aSubKeys
Const HKLM = &H80000002 'HKEY_LOCAL_MACHINE
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
sComp & "/root/default:StdRegProv")
sBaseKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\"
iRC = oReg.EnumKey(HKLM, sBaseKey, aSubKeys)
Dim sKey, sValue, sTmp, sVersion, sDateValue, sYr, sMth, sDay
For Each sKey In aSubKeys
iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, "DisplayName", sValue)
If iRC <> 0 Then
oReg.GetStringValue HKLM, sBaseKey & sKey, "QuietDisplayName", sValue
End If
If sValue <> "" Then
iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _
"DisplayVersion", sVersion)
If sVersion <> "" Then
sValue = sValue & vbTab & "Ver: " & sVersion
Else
sValue = sValue & vbTab
End If
iRC = oReg.GetStringValue(HKLM, sBaseKey & sKey, _
"InstallDate", sDateValue)
If sDateValue <> "" Then
sYr = Left(sDateValue, 4)
sMth = Mid(sDateValue, 5, 2)
sDay = Right(sDateValue, 2)
'some Registry entries have improper date format
On Error Resume Next
sDateValue = DateSerial(sYr, sMth, sDay)
On Error GoTo 0
If sdateValue <> "" Then
sValue = sValue & vbTab & "Installed: " & sDateValue
End If
End If
sTmp = sTmp & sValue & vbcrlf
cnt = cnt + 1
End If
Next
sTmp = BubbleSort(sTmp)
GetAddRemove = "INSTALLED SOFTWARE (" & cnt & ") - " & sCompName & _
" - " & Now() & vbcrlf & vbcrlf & sTmp
End Function
Function BubbleSort(sTmp)
'cheapo bubble sort
Dim aTmp, i, j, temp
aTmp = Split(sTmp, vbcrlf)
For i = UBound(aTmp) - 1 To 0 Step -1
For j = 0 to i - 1
If LCase(aTmp(j)) > LCase(aTmp(j+1)) Then
temp = aTmp(j + 1)
aTmp(j + 1) = aTmp(j)
aTmp(j) = temp
End if
Next
Next
BubbleSort = Join(aTmp, vbcrlf)
End Function
Function GetProbedID(sComp)
Dim objWMIService, colItems, objItem
Set objWMIService = GetObject("winmgmts:\\" & sComp & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select SystemName from " & _
"Win32_NetworkAdapter",,48)
For Each objItem in colItems
GetProbedID = objItem.SystemName
Next
End Function
Function GetDTFileName()
dim sNow, sMth, sDay, sYr, sHr, sMin, sSec
sNow = Now
sMth = Right("0" & Month(sNow), 2)
sDay = Right("0" & Day(sNow), 2)
sYr = Right("00" & Year(sNow), 4)
sHr = Right("0" & Hour(sNow), 2)
sMin = Right("0" & Minute(sNow), 2)
sSec = Right("0" & Second(sNow), 2)
GetDTFileName = sMth & sDay & sYr & "_" & sHr & sMin & sSec
End Function
Function WriteFile(sData, sFileName)
Dim fso, OutFile, bWrite
bWrite = True
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set OutFile = fso.OpenTextFile(sFileName, 2, True)
'Possibly need a prompt to close the file and one recursion attempt.
If Err = 70 Then
Wscript.Echo "Could not write to file " & sFileName & ", results " & _
"not saved." & vbcrlf & vbcrlf & "This is probably " & _
"because the file is already open."
bWrite = False
ElseIf Err Then
WScript.Echo err & vbcrlf & err.description
bWrite = False
End If
On Error GoTo 0
If bWrite Then
OutFile.WriteLine(sData)
OutFile.Close
End If
Set fso = Nothing
Set OutFile = Nothing
WriteFile = bWrite
End Function
SCRIPT 3 ( gets mapped drives )
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile("mappedoutput.txt", True)
' List Mapped Network Drives
On Error Resume Next
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_MappedLogicalDisk")
For Each objItem in colItems
objFile.Writeline "Compressed: " & objItem.Compressed
objFile.Writeline "Description: " & objItem.Description
objFile.Writeline "Device ID: " & objItem.DeviceID
objFile.Writeline "File System: " & objItem.FileSystem
objFile.Writeline "Free Space: " & objItem.FreeSpace
objFile.Writeline "Maximum Component Length: " & objItem.MaximumComponentLength
objFile.Writeline "Name: " & objItem.Name
objFile.Writeline "Provider Name: " & objItem.ProviderName
objFile.Writeline "Session ID: " & objItem.SessionID
objFile.Writeline "Size: " & objItem.Size
objFile.Writeline "Supports Disk Quotas: " & objItem.SupportsDiskQuotas
objFile.Writeline "Supports File-Based Compression: " & _
objItem.SupportsFileBasedCompression
objFile.Writeline "Volume Name: " & objItem.VolumeName
objFile.Writeline "Volume Serial Number: " & objItem.VolumeSerialNumber
objFile.Writeline
Next
Again thank you
Can you put all the three scripts as 1 single script? In that case, you will need to input the IP address only once.
Or else write another script which will ask for the IP address and call these scripts by using cscript and passing the IPaddress to them as a parameter. Try this code for that:
strcomputer = inputbox("Enter the IP address")
set obj1 = createobject("wscript.shell")
set obj2 = createobject("wscript.shell")
set obj3 = createobject("wscript.shell")
pgm1 = "cscript script1.vbs " & strcomputer
pgm2 = "cscript script2.vbs " & strcomputer
pgm3 = "cscript script3.vbs " & strcomputer
obj1.run pgm1,3,true
obj2.run pgm2,3,true
obj3.run pgm3,3,true
set obj1 = nothing
set obj2 = nothing
set obj3 = nothing
In above code, script1.vbs, script2.vbs, script3.vbs are your 3 scripts and you are executing them one by one using a new script.
In script1.vbs, add this line of code :
strcomputer = wscript.Arguments.item(0)
It will store the 1rst argument that you have passed from your new script to script1.vbs, into the variable 'strcomputer'(in your case, the IP address).
Similarly, in both script2.vbs and script3.vbs also, add the statement
strcomputer = wscript.Arguments.item(0)
Regarding your output file, I am not sure what you are asking for. Maybe this can help:
Use the below to write to a file (overwrites if data is already present):
Set fso1 = CreateObject("Scripting.FileSystemObject" )
Set file1 = fso1.OpenTextFile("C:\New\textfile1.txt",2,true)
Use the below to add data or append to a file (does NOT overwrite):
Set fso1 = CreateObject("Scripting.FileSystemObject" )
Set file1 = fso1.OpenTextFile("C:\New\textfile1.txt",8,true)
Use the below to read from a file:
Set fso1 = CreateObject("Scripting.FileSystemObject" )
Set file1 = fso1.OpenTextFile("C:\New\textfile1.txt",1,true)

VB Script Error - Worked before but now not confusingly

i am getting a error
The VB file reads col1 and finds the matching image name in the directory and the renames that file to col2 it produces a report to show what images haven't been renamed and placed the ones that have in a folder called rename
i have attached the code so you can see
strDocMap = "C:\img\DocMap.xlsx"
strInputFolder = "C:\img\"
strOutputFolder = "C:\img\renamed\"
strLogFile = "C:\img\RenamingLog.txt"
strPattern = "\d{5}"
Set regExpression = New RegExp
With regExpression
.Global = True
.IgnoreCase = True
.Pattern = strPattern
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Const xlUp = -4162
Const xlFormulas = -4123
Const xlPart = 2
Const xlByRows = 1
Const xlNext = 1
Set objWB = objExcel.Workbooks.Open(strDocMap, False, True)
Set objSheet = objWB.Sheets(1)
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Right(strInputFolder, 1) <> "\" Then strInputFolder = strInputFolder & "\"
If Right(strOutputFolder, 1) <> "\" Then strOutputFolder = strOutputFolder & "\"
If objFSO.FolderExists(strOutputFolder) = False Then objFSO.CreateFolder strOutputFolder
Set objLog = objFSO.CreateTextFile(strLogFile, True)
objLog.WriteLine "Script started " & Now
objLog.WriteLine "Enumerating files in folder: " & strInputFolder
objLog.WriteLine "Renaming files to folder: " & strOutputFolder
objLog.WriteLine String(80, "=")
For Each objFile In objFSO.GetFolder(strInputFolder).Files
Set colMatches = regExpression.Execute(objFile.Name)
If colMatches.Count > 0 Then
If colMatches.Count = 1 Then
For Each objMatch In colMatches
strOldNum = objMatch.Value
Set objCell = objSheet.Cells.Find(strOldNum, objSheet.Range("A1"), xlFormulas, xlPart, xlByRows, xlNext, False, False)
If Not objCell Is Nothing Then
strNewNum = objCell.Offset(0, 1).Value
If strNewNum <> "" Then
strNewPath = strOutputFolder & strNewNum & "." & objFSO.GetExtensionName(objFile.Path)
' Check if a file already exists without the appended letter
blnValid = True
If objFSO.FileExists(strNewPath) = True Then
blnValid = False
' Start at "a"
intLetter = 97
strNewPath = strOutputFolder & strNewNum & Chr(intLetter) & "." & objFSO.GetExtensionName(objFile.Path)
Do While objFSO.FileExists(strNewPath) = True
intLetter = intLetter + 1
strNewPath = strOutputFolder & strNewNum & Chr(intLetter) & "." & objFSO.GetExtensionName(objFile.Path)
If intLetter > 122 Then Exit Do
Loop
If intLetter <= 122 Then blnValid = True
End If
If blnValid = True Then
objLog.WriteLine "Renaming " & objFile.Name & " to " & Mid(strNewPath, InStrRev(strNewPath, "\") + 1)
objFSO.MoveFile objFile.Path, strNewPath
Else
objLog.WriteLine "Unable to rename " & objFile.Name & ". Letters exhausted."
End If
End If
End If
Next
Else
objLog.WriteLine objFile.Name & " contains " & colMatches.Count & " matches. Manual adjustment required."
End If
End If
Next
objLog.WriteLine String(80, "=")
objLog.WriteLine "Script finished " & Now
objWB.Close False
objExcel.Quit
objLog.Close
MsgBox "Done"
Thanks
Jack
If line 68
objLog.WriteLine objFile.Name & " contains " & colMatches.Count & " matches. Manual adjustment required."
is really the culprit, I would argue:
The objects objLog, objFile, and colMatches were used before -
acquittal
The methods .WriteLine, .Name, and .Count look good - acquittal
Concatenation (&) should work on string literals and not
null/empty/nothing elements - acquittal
By elimination: objFile.Name contains a funny letter (not
convertable to 'ASCII'). Easy check: Replace "objFile.Name" with a
string literal.
Evidence
Dim s
For Each s In Array(Empty, Null, ChrW(1234))
On Error Resume Next
goFS.CreateTextFile("tmp.txt", True).WriteLine s
WScript.Echo Err.Description
On Error GoTo 0
Next
output:
====================================
Type mismatch
Invalid procedure call or argument
====================================

Script timesout in the middle of execution

I wrote a small script to help re-organize my .mp3 collection. When I run this script, sometimes it will process several thousand files till it would hit an error condition (normally a move of a file that had a special character in its name/path that I hadn't counted for), but it would often exit the script with the text
Script execution time was exceeded on script "C:\DevSpace\mp3move.vbs".
Script execution was terminated.
Im not sure why this is happening. In an effort to figure out where this occured I added several msgbox lines, and what I found is that a msgbox would popup, but then it would auto-close very quickly.
Here is the code - i appoligize for not getting the formatting correctly in the forum
'Takes all .MP3 files in the source dir, reads the Artist tag associated with that file
'Checks for a dir named after the artist in the destination dir
'If the folder artist/album does not exists, it will create it
'Then move the .mp3 file to the dest dir
Dim oAppShell, oFSO, oFolder, oFolderItems
Dim strPath, i
Dim sInfo
iDebug=0
sInfo = "Item Description"
strPath = "K:\_preprocess"
sDestination = "K:\Music"
Set oAppShell = CreateObject("Shell.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
If not oFSO.FolderExists(strPath) Then
WScript.Echo "Folder " & strPath & " is inaccessble"
End If
Set oFolder = oAppShell.NameSpace(strPath)
Set oFolderItems = oFolder.Items()
sCreate = ""
sExist = ""
sMoved = ""
If (not oFolderItems is nothing) Then
if oFolderItems.Count = 0 then
Wscript.echo "no files found in this folder: " & strPath
WScript.Quit
end If
If iDebug = 1 Then
i = oFolderItems.count
WScript.Echo i
End If
For Each oItem in oFolderItems
If iDebug = 1 Then
i = i - 1
End If
If oItem.Type = "MP3 audio file (mp3)" or oItem.Type = "MP3 Format Sound (.mp3)"_
Or oItem.Type = "Windows Media Audio file" or oItem.Type = "MP3 Format Sound" then
'get artist name
sArtist = oFolder.GetDetailsOf(oItem, 20)
If iDebug = 1 Then
MsgBox oItem.name
MsgBox sArtist
End If
'if 'The Beatles' change to 'Beatles, the'
If InStr(LCase(sArtist),"the") = 1 Then
sArtist = Mid(sArtist,5) & ", the"
End If
'remove \ from band name
If InStr(sArtist,"\") > 0 Then
sArtist = Replace(sAlbum,"\","")
End If
If InStr(sArtist,"/") > 0 Then
sArtist = Replace(sAlbum,"/","")
End If
If iDebug = 1 Then
MsgBox sArtist
End If
'if folder does not exist create
'MsgBox sDestination & "\" & sArtist
If oFSO.FolderExists(sDestination & "\" & sArtist) Then
'MsgBox "EXIST"
sExist = sExist & sDestination & "\" & sArtist & " exists" & vbCrLf
Else
'MsgBox "CREATE " & sDestination & "\" & sArtist
rtn = oFSO.CreateFolder(sDestination & "\" & sArtist)
sCreate = sCreate & sDestination & "\" & sArtist & " created" & vbCrLf
End If
'get album name
sAlbum = oFolder.GetDetailsOf(oItem, 14)
'remove special characters from album name
If InStr(sAlbum,":") > 0 Then
sAlbum = Replace(sAlbum,":","")
End if
If InStr(sAlbum,"?") > 0 Then
sAlbum = Replace(sAlbum,"?","")
End If
If InStr(sAlbum,"...") > 0 Then
sAlbum = Replace(sAlbum,"...","")
End If
If InStr(sAlbum,"/") > 0 Then
sAlbum = Replace(sAlbum,"/","")
End If
If InStr(sAlbum,"\") > 0 Then
sAlbum = Replace(sAlbum,"\","")
End If
'create dir artist/album
If oFSO.FolderExists (sDestination & "\" & sArtist & "\" & sAlbum) Then
'sExist = sExist & sDestination & "\" & sArtist & sAlbum & " exists" & vbCrLf
Else
'MsgBox sDestination & "\" & sArtist & "\" & sAlbum
rtn = oFSO.CreateFolder (sDestination & "\" & sArtist & "\" & sAlbum)
'sCreate = sCreate & sDestination & "\" & sArtist & " created" & vbCrLf
End If
'move file
sSource = strPath & "\" & oItem.name & ".mp3"
sDest = sDestination & "\" & sArtist & "\" & sAlbum & "\"
If iDebug=1 Then
MsgBox sSource & vbCrLf & sDest
End If
If oFSO.FileExists (sSource) Then
oFSO.MoveFile sSource, sDest
'sMoved = sMoved & sSource & " moved to " & sDest & vbcrlf
'MsgBox smoved
Else
MsgBox sSource & " not moved"
End If
End If
If iDebug = 1
WScript.Sleep 1000
WScript.Echo i
End If
Next
If iDebug=1
WScript.Echo i
End if
'MsgBox sCreate
'MsgBox sExist
'MsgBox sMoved
End If
You should set the WScript.Timeout property to a higher value.
See example here
The problem existed with my input files. Some of the .mp3 files I was using to test with had non-ascii characters in the tags, and that caused the program to freeze

Resources