I have a batch file that uses the following script to recycle MyAppPool.
cscript.exe %windir%\system32\iisapp.vbs /a MyAppPool /r
However when MyAppPool is Stopped, then I am not able to recycle it. What I want is to check weather MyAppPool is Stopped, if stopped , then Start it, recycle it and then Stop again.
Well I am a complete newbie in this IIS thing and have never worked in it. I am using Window Server 2003 and IIS6.
You can write your own .vbs script, to lookup the .State of the AppPool, and start it when it's stopped. Something like:
//EDIT:
Option Explicit
If WScript.Arguments.Count <> 1 Then
Wscript.Echo "No AppPoolName provided. Iterate through all AppPools"
iterate_and_start_all_apps()
Else
Dim AppPoolName
AppPoolName = Wscript.Arguments(0)
'
' Choose what to do here and uncomment that Sub
'
' start_given_app(AppPoolName)
' start_one_app_if_stopped(AppPoolName)
' start_recycle_stop_app(AppPoolName)
End If
' This Sub is runs if no argument is passed to the script
Sub iterate_and_start_all_apps()
Dim objAppPools, objAppPool
Set objAppPools = GetObject("IIS://Localhost/W3SVC/AppPools")
For Each objAppPool in objAppPools
Set objAppPool = GetObject("IIS://Localhost/W3SVC/AppPools/" & objAppPool.Name )
If objAppPool.AppPoolState <> 2 Then
Wscript.Echo objAppPool.Name & " is not running."
WScript.Echo objAppPool.Name & ", AppPoolState: " & objAppPool.AppPoolState & _
", Win32Error: " & objAppPool.Win32Error & " ("& hex(objAppPool.Win32Error)&")"
Wscript.Echo State2Desc(objAppPool.AppPoolState)
objAppPool.Start
If Err.Number = 0 Then
Wscript.Echo objAppPool.Name & " started."
End If
End If
Next
Set objAppPool = Nothing
Set objAppPools = Nothing
End Sub
'
' start an application pool if the .State is stopped
'
Sub start_one_app_if_stopped(applicationpool)
Dim iisObjectPath : iisObjectPath = ("IIS://Localhost/W3SVC/AppPools/" & applicationpool)
Dim iisObject : Set iisObject = GetObject(iisObjectPath)
If iisObject.AppPoolState <> 2 Then
iisObject.Start
If (Err.Number <> 0) Then
WScript.Echo "Error starting: " & ObjectPath
WScript.Quit (Err.Number)
Else
WScript.Echo applicationpool & " started."
End If
End If
Set iisObject = nothing
Set iisObjectPath = nothing
End Sub
'
' if an application pool is stopped, start + recycle + stop it
'
Sub start_recycle_stop_app(applicationpool)
Dim iisObjectPath : iisObjectPath = ("IIS://Localhost/W3SVC/AppPools/" & applicationpool)
Dim iisObject : Set iisObject = GetObject(iisObjectPath)
If iisObject.AppPoolState <> 2 Then
iisObject.Start
If (Err.Number <> 0) Then
WScript.Echo "Error starting: " & ObjectPath
WScript.Quit (Err.Number)
Else
WScript.Echo applicationpool & " started."
End If
iisObject.recycle
' we need to sleep for some time because recyle takes some time
wscript.sleep(3000)
iisObject.Stop
End If
Set iisObject = nothing
Set iisObjectPath = nothing
End Sub
'
' just issue a start command to start an application pool
'
Sub start_given_app(applicationpool)
Dim iisObjectPath : iisObjectPath = ("IIS://Localhost/W3SVC/AppPools/" & applicationpool)
Dim iisObject : Set iisObject = GetObject(iisObjectPath)
IIsObject.Start
If (Err.Number <> 0) Then
WScript.Echo "Error starting: " & ObjectPath
WScript.Quit (Err.Number)
Else
WScript.Echo applicationpool & " started."
End If
Set iisObject = nothing
Set iisObjectPath = nothing
End Sub
'
' support function
'
Function State2Desc(nState)
Select Case nState
Case 1
State2Desc = "Starting"
Case 2
State2Desc = "Started"
Case 3
State2Desc = "Stopping"
Case 4
State2Desc = "Stopped"
Case Else
State2Desc = "Unknown state"
End Select
End Function
(part taken from http://www.saotn.org/iis-60-start-gestopte-application-pools/, which is a script to start all application pools).
Save as 'startapp.vbs' and run with:
cscript.exe /nologo startapp.vbs name_of_appPool
if you start it without an argument, then the script will iterate through all applications pools in the the metabase and start them if they're not running.
I think you'll need the "start_one_app_if_stopped" Sub, so uncoment that line (line 13) and run the .vbs script with an command line argument:
cscript.exe /nologo startapp.vbs name_of_appPool
HTH
Related
I have a simple vbscript that count the number of files/subfolders in a folder, if the number greater than 5, it will pop up a message to user. I can run this script manually under admin or normal user account, but after I scheduled it in task scheduler as admin, it shows task running, [task started] [action started] [created task process] but it never ends and I never see the message box pops up under user accounts. Is there anything wrong?
Code:
Set filesys = CreateObject("Scripting.FileSystemObject")
Set shell = CreateObject("Shell.Application")
Set RTMFolder = filesys.GetFolder("C:\work\RTM")
Set PMFolder = filesys.GetFolder("C:\work\Powermill")
Set RTMFiles = RTMFolder.Files
Set PMFiles = PMFolder.SubFolders
NumberOfRTM = RTMFiles.Count
NumberofPM = PMFiles.Count
'Wscript.echo NumberOfRTM
Set wshShell = WScript.CreateObject( "WScript.Shell" )
strComputerName = wshShell.ExpandEnvironmentStrings( "%COMPUTERNAME%" )
If NumberOfRTM >= 5 Then
msgbox "Dear user on " & strComputerName & vbcrlf & " " & vbcrlf & "There are more than 5 RTM files saved on C:\WORK\RTM folder, Please move them to K drive.", &h51000, "Clean up C:\work\RTM"
shell.Open "C:\WORK\RTM"
End If
If NumberofPM >= 5 Then
msgbox "Dear user on " & strComputerName & vbcrlf & " " & vbcrlf & "There are more than 5 Powermill files saved on C:\WORK\Powermill folder, Please Clean it up.", &h51000, "Clean up C:\work\Powermill"
shell.Open "C:\WORK\Powermill"
End If
'Release memory
Set RTMFolder = Nothing
Set PMFolder = Nothing
Set RTMFiles = Nothing
Set PMFiles = Nothing
Try your program/script to be c:\windows\syswow64\cscript.exe or even c:\windows\system32\cscript.exe and then have the argument be c:\path_to_your_vbs\your.vbs
I am doing some automation work and I need to run multiple VB scripts in order to create, fill and save excel files. I have already done it successfully, but the code seems very slow to run.
My guess is, it's because every script always creates an Excel Application Object, then saves it and quits Excel like below :
On Error Resume Next
Dim ExcelPath
ExcelPath = WScript.Arguments(0)
'Excel File Paht is a String. First argument in Run Script Function, must be between quotes (""). Eg:"C:\test.xlsx"'
If Err.Number <> 0 Then
WScript.StdOut.WriteLine("Error: " + Err.Description)
WScript.Quit
End If
Dim SheetName
SheetName = WScript.Arguments(1)
'Sheet Name is a String and the second argument in run script function, must to be between quotes (""). Eg: "Sheet1"'
If Err.Number <> 0 Then
WScript.StdOut.WriteLine("Error: " + Err.Description)
WScript.Quit
End If
Dim CellRange
CellRange = WScript.Arguments(2)
'Cell Range is a String . Third Argument in Run Script function, must to be between quotes (""). Eg: "A1:D10"'
If Err.Number <> 0 Then
WScript.StdOut.WriteLine("Error: " + Err.Description)
WScript.Quit
End If
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open(ExcelPath)
Set objSheet = objWorkbook.Sheets(SheetName)
If Err.Number <> 0 Then
WScript.StdOut.WriteLine("Error: " + Err.Description)
WScript.Quit
End If
objExcel.Application.Visible = False
objExcel.DisplayAlerts = False
objSheet.Range(CellRange).Merge
objSheet.Range(CellRange).HorizontalAlignment = -4108
objWorkbook.Save
objWorkbook.Close SaveChanges = True
objExcel.Application.Quit
Set objExcel = Nothing
If Err.Number <> 0 Then
WScript.StdOut.WriteLine("Error: " + Err.Description)
WScript.Quit
End If
I just want to know if there is any way to run like 25 different scripts in sequence without always create this object and save. So In my mind I would have an structure like this :
1. Open_excel.vbs
2. Create Sheet.vbs
3. Insert Values.vbs
4. Format Cell.vbs
5. Save File.vbs
6. Quit Excel.vbs
Thanks in advance.
The code when run manually (right click and run) it works perfectly, but the issue arises when it is automated using schedule.
When automated the code runs fine but right at the end of running the code it fails with the above error message.
The code looks fine, variables are set as they should and the code runs fine when done manually.
Sub processJobs(dbCurrent As NotesDatabase)
Dim vwLookup As NotesView
Dim docReq As NotesDocument
Dim dtMonthAgo As New NotesDateTime(Today)
Dim dtDelDate As NotesDateTime
Dim itmDelDate As NotesItem
Dim sender As NotesName
Dim receiver As NotesName
Dim nmServer As NotesName
Dim lngNoOfDays As Long
Dim mail As Email
Dim intCount As Integer
Dim intCountFailed As Integer
Dim strSendTo As String
On Error GoTo ErrorHandler
On Error 4000 GoTo RecipientNameBlank
On Error 4294 GoTo RecipientNotInNAB
Call AgentLog.LogAction("--------- Process Job ---------")
Call dtMonthAgo.AdjustMonth( -1 ) ' set the dtMonthAgo date to one month ago
Call dtMonthAgo.Setanytime() ' remove the time component from the date
Set vwLookup = dbCurrent.Getview("JobView")
vwLookup.Autoupdate = False
Set docReq = vwLookup.Getfirstdocument()
intCount = 0
intCountFailed = 0
Do Until docReq Is Nothing
Set itmDelDate = docReq.GetFirstItem("DeliveryDate")
If itmDelDate.Type = 1024 Then
Set dtDelDate = itmDelDate.DateTimeValue
Call dtDelDate.SetAnyTime
If dtMonthAgo.TimeDifference(dtDelDate) > 0 Then
intCount = intCount + 1
Set mail = New Email ' send email...
mail.Subject = "Processed Job"
mail.HTML = getCompletionHTML(docReq, mail.WebURL)
Set sender = New NotesName(docReq.JobBy(0))
Set receiver = New NotesName(docReq.DespatchTo(0))
Set nmServer = New NotesName(dbCurrent.Server)
If receiver.Organization = nmServer.Organization Then
strSendTo = receiver.Abbreviated
' send a copy to..
If sender.Abbreviated <> receiver.Abbreviated Then
mail.CopyTo = docReq.JobBy(0)
End If
Else
strSendTo = sender.Abbreviated
End If
mail.Send(strSendTo)
Call agentLog.LogAction(strSendTo & " - Job No: " & docReq.JobNo(0))
flagDoc:
' flag the job...
Call docReq.Replaceitemvalue("CompletionJob", "Y")
Call docReq.Replaceitemvalue("CompletionJobDate", Now)
Call docReq.Save(True, False)
End If
End If
Set docReq = vwLookup.Getnextdocument(docReq)
Loop
Call AgentLog.LogAction("")
Call AgentLog.LogAction("Attempted to send " & CStr(intCount) & " Job")
Call AgentLog.LogAction("Failed to send " & CStr(intCountFailed) & " Job")
Call AgentLog.LogAction("--------- End of job process ---------")
ErrorHandler:
If Not AgentLog Is Nothing Then
Call AgentLog.LogError(Err, "errorHandler: " & CStr(Err) & " " & Error$ & " in " & LSI_Info(2))
End If
Resume getOut
23/05/2019 00:00:05 errorHandler: 91 Object variable not set in PROCESSJOBS(Object variable not set)
The agent was supposed to loop through the view, get names of recipients, set the variables and then send the email automatically.
By automation, it does loop through the view and get/set names of recipient but fails straight after getting the last name that the object variable is not set.
Running the code manually does not pose any problem at all, but this code needs to be run automatically.
In your ErrorHandler, log (or print) the line where the error occured.
ErrHandler:
Print "Got error " & Error$ & " on line " & cstr(Erl)
example copied from IBM
You need an Exit Sub statement to prevent your code from falling through into your error handler.
Call AgentLog.LogAction("")
Call AgentLog.LogAction("Attempted to send " & CStr(intCount) & " Job")
Call AgentLog.LogAction("Failed to send " & CStr(intCountFailed) & " Job")
Call AgentLog.LogAction("--------- End of job process ---------")
Exit Sub ' **** You need this
ErrorHandler:
If Not AgentLog Is Nothing Then
Call AgentLog.LogError(Err, "errorHandler: " & CStr(Err) & " " & Error$ & " in " & LSI_Info(2))
End If
Resume getOut
You also don't appear to be initializing AgentLog, though that might be a global.Is it successfully writing those lines to the agent log when you run it scheduled? If not, perhaps there's a problem with accessing the agent log database on the server where it is scheduled.
I sometimes use the MSForms.DataObject object from the Microsoft Forms 2.0 Object Library in Excel VBA. It is absolutely wonderful for reading / writing text data from / to the clipboard. Recently, I stumbled across this article which shows how to instantiate the object using late binding and found that it works beautifully in VBA. Now, I don't have to worry about adding the reference library each time I port my code to new projects.
That discovery made me wonder if it were possible to use the same object in VBScript. There have been several instances in the past when I wanted to manipulate the clipboard with VBScript but all my research at the time indicated that it wasn't possible (aside from using internet explorer, mshta, clip, etc). To my surprise, the DataObject worked exactly as expected when I tried to read the clibboard. However, it would not put data back into the clipboard and threw an error which makes no sense to me. Below are the details.
Error Number: -2147221008 (800401F0)
Error Description: DataObject:PutInClipboard CoInitialize has not been called.
So, is there a workaround for the error I'm getting or is it simply part of the same VBScript limitation described on MSDN and this answer?
Here is the VBScript code I used for testing on my 64 bit Windows 7 PC:
Option Explicit
Dim DObj
Sub TestClipboard()
Dim ClipData
VerifyArchitecture
If Not InitClipboardObject Then
Terminate "Unable to initialize the clipboard object"
ElseIf Not ClipboardPaste(ClipData) Then
Terminate "Unable to retrieve the clipboard data"
End If
' The message box will have the current clipboard text (if any exist)
MsgBox "The clipboard contains the following text:" & _
vbCrLf & vbCrLf & ClipData
ClipData = "Text we put in the clipboard"
' However, this function will not succeed.
If Not ClipboardCopy(ClipData) Then Terminate "Unable to put data into the clipboard"
End Sub
Function InitClipboardObject()
On Error Resume Next
' If the code is run in VBA, the following reference library
' can be used as an alternative to late binding:
' Microsoft Forms 2.0 Object Library
' Note: The reference library will not show up on the
' list unless a userform has already been added in Excel.
' If not, browse for the FM20.DLL file
Set DObj = GetObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
InitClipboardObject = Err = 0
End Function
' Put data in the clipboard similar to pressing Ctrl + C
Function ClipboardCopy(ByVal Data)
On Error Resume Next
DObj.SetText Data
' This line of code will throw the following error
' Error Number: -2147221008 (800401F0)
' Description: DataObject:PutInClipboard CoInitialize has not been called.
' However, it works perfectly in VBA
DObj.PutInClipboard
ClipboardCopy = Err = 0
End Function
' Retrieve data from the clipboard similar to pressing Ctrl + V
Function ClipboardPaste(ByRef Data)
On Error Resume Next
DObj.GetFromClipboard
Data = DObj.GetText(1)
ClipboardPaste = Err = 0
End Function
' This sub will re-load the script using the 32 bit host
' if it is loaded on the 64 bit version. This is necessary
' since the clipboard object is 32 bit.
Sub VerifyArchitecture()
' The code in this sub is a modified version of Vozzie's answer
' and I do not take credit for the idea:
' https://stackoverflow.com/a/15320768/2734431
Dim Arch, Arg, Args, Cmd, ExeFullName, ExeShortName
Dim Path32, Path64, ProcEnv, q, Reload, ScriptName
Dim WinDir, WShell
q = Chr(34)
Reload = False
ExeFullName = WScript.FullName
ScriptName = WScript.ScriptFullName
ExeShortName = Mid(ExeFullName, InStrRev(ExeFullName, "\") + 1)
Set WShell = CreateObject("WScript.Shell")
Set ProcEnv = WShell.Environment("Process")
WinDir = ProcEnv("windir") & "\"
Path32 = WinDir & "SysWOW64\"
Path64 = WinDir & "System32\"
Arch = ProcEnv("PROCESSOR_ARCHITECTURE")
For Each Arg In WScript.Arguments
Args = " " & q & Arg & q
Next
Cmd = q & Path32 & ExeShortName & q & " " & q & ScriptName & q & Args
If InStr(LCase(ExeFullName), LCase(Path64)) <> 0 And Arch = "AMD64" Then
Reload = True
WShell.Run Cmd
End If
Set WShell = Nothing
Set ProcEnv = Nothing
If Reload Then Terminate ""
End Sub
' This sub is designed to clear any global variables, optionally
' display an error message, and stop the script
Sub Terminate(ByVal ErrMsg)
Dim ErrNbr
Set DObj = Nothing
If ErrMsg <> "" Then
ErrNbr = "Error"
If Err <> 0 Then
ErrNbr = ErrNbr & " " & Err & " (" & Hex(Err) & ")"
ErrMsg = ErrMsg & vbCrLf & vbCrLf
ErrMsg = ErrMsg & "Code Error: " & Err.Description
End If
' &H10 = vbCritical
MsgBox ErrMsg, &H10, ErrNbr
End If
WScript.Quit
End Sub
I'm having trouble with some VBA programming since I'm totally new to it.
I've been given the task to create a macro/vba application in Word/excel that retrieves Lastname, Firstname | telephone number | Department | Manager from the Active Directory.
So I've been searching the internet for the last days but nothing really works for me.
A Template that gets the current Users First-/Lastname, email etc. was given to work on. I am having a hard time on transferring the code to what i need to do now.
So what I've been trying for the past hours now, was getting a list of all the Users from the Active Directory. But the Code I use was from a VBScript I found on the internet. I changed what I could to make it work with VBA but I always get an error when trying to run it.
The code is the following:
Sub test()
' get OU
'
strOU = "OU=Users,DC=domain,DC=com"
' connect to active directory
'
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open "Provider=ADsDSOObject;"
' create command
'
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
' execute command to get all users
'
objCommand.commandtext = "LDAP://" & strOU & ">;" & _
"(&(objectclass=user)(objectcategory=person));" & _
"adspath,distinguishedname,sAMAccountName;subtree"
On Error Resume Next
Set objRecordSet = objCommand.Execute
If Err.Number <> 0 Then MsgBox "Exception occured: " & Err.Description
On Error GoTo 0
'Dim RecordSet As New ADODB.RecordSet
Set objRecordSet = objCommand.Execute
'Show info for each user in OU
'
Do Until objRecordSet.EOF
'Show required info for a user
'
Debug.Print obj.RecordSet.Fields(“adspath”).Value
Debug.Print obj.RecordSet.Fields(“distinguishedname”).Value
Debug.Print obj.RecordSet.Fields(“sAMAccountName”).Value
' Move to the next user
'
obj.RecordSet.MoveNext
Loop
' Clean up
'
obj.RecordSet.Close
Set obj.RecordSet = Nothing
Set objCommand = Nothing
objConnection.Close
Set objConnection = Nothing
End Sub
and in this line it all stops everytime:
Set objRecordSet = objCommand.Execute
if I remove the If Err.Number <> 0 Then MsgBox "Exception occured: " & Err.Description
On Error GoTo 0 part it just freezes and crashes word.
OK, let's go top down:
strOU = "OU=Users,DC=domain,DC=com"
With this nobody can help you. You must know the AD structure of your AD. If this is wrong, then you get "Table not found" from LDAP.
objCommand.commandtext = "LDAP://" & strOU & ">;" & _
"(&(objectclass=user)(objectcategory=person));" & _
"adspath,distinguishedname,sAMAccountName;subtree"
This lacks a <. It should be:
objCommand.commandtext = "<LDAP://" & strOU & ">;" & _
"(&(objectclass=user)(objectcategory=person));" & _
"adspath,distinguishedname,sAMAccountName;subtree"
Then
Debug.Print obj.RecordSet.Fields(“adspath”).Value
Debug.Print obj.RecordSet.Fields(“distinguishedname”).Value
Debug.Print obj.RecordSet.Fields(“sAMAccountName”).Value
Multiple problems here:
Typographically double quotes are not allowed as string delimiter in VBA source code.
Your Object is named objRecordset and not obj.Recordset.
So this should be:
Debug.Print objRecordset.Fields("adspath").Value
Debug.Print objRecordset.Fields("distinguishedname").Value
Debug.Print objRecordset.Fields("sAMAccountName").Value
Replace obj.Recordset with objRecordset also in the rest of the code.