How to test the internet connection behind a proxy? - powershell

I have this vbscript that works well on Windows 7 32-bit without proxy
In order to improve it, I seek for this solution: How to test internet connection behind a proxy ?
The solution perhaps it will be in VBScript or Powershell or Batch, much as I find a way to check whether i am connected or not behind a proxy !
The piece of code to improve it when i'm behind a proxy
If there is a trick to check if i'm connected to internet when i'm behind a proxy this is my question ?
If CheckConnection = true then
Msgbox "i'm connected to internet",vbinformation+vbSystemModal,"Check connection to internet"
Else
Msgbox "i'm not connected to internet",vbCritical+vbSystemModal,"Check connection to internet"
End if
'***************************************************************************
Function CheckConnection()
CheckConnection = False
strComputer = "smtp.gmail.com"
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}!\\").ExecQuery _
("select * from Win32_PingStatus where address = '" & strComputer & "'")
For Each objStatus in objPing
If objStatus.Statuscode = 0 Then
MyLoop = False
CheckConnection = True
Exit Function
End If
Next
End Function
'******************************************************************************
The hole code :
Option Explicit
Dim Title,MyScriptPath,DJBuzzRadio,MyLoop,strComputer,objPing,objStatus,FSO,FolderScript,URLICON,Icon
Title = "Radio DJ Buzz Live by © Hackoo © 2015"
MyScriptPath = WScript.ScriptFullName
Set FSO = Createobject("Scripting.FileSystemObject")
FolderScript = FSO.GetParentFolderName(MyScriptPath) 'Chemin du dossier ou se localise le Vbscript
Icon = FolderScript & "\akg.ico"
URLICON = ChrW(104)&ChrW(116)&ChrW(116)&ChrW(112)&ChrW(58)&ChrW(47)&ChrW(47)&ChrW(104)&ChrW(97)&ChrW(99)&ChrW(107)&ChrW(111)&ChrW(111)&ChrW(46)&ChrW(97)&ChrW(108)&ChrW(119)&ChrW(97)&ChrW(121)&ChrW(115)&ChrW(100)&ChrW(97)&ChrW(116)&ChrW(97)&ChrW(46)&ChrW(110)&ChrW(101)&ChrW(116)&ChrW(47)&ChrW(97)&ChrW(107)&ChrW(103)&ChrW(46)&ChrW(105)&ChrW(99)&ChrW(111)
If Not FSO.FileExists(Icon) Then Call Download(URLICON,Icon)
DJBuzzRadio = ChrW(104)&ChrW(116)&ChrW(116)&ChrW(112)&ChrW(58)&ChrW(47)&ChrW(47)&ChrW(119)&ChrW(119)&ChrW(119)&ChrW(46)&ChrW(99)&ChrW(104)&ChrW(111)&ChrW(99)&ChrW(114)&ChrW(97)&ChrW(100)&ChrW(105)&ChrW(111)&ChrW(115)&ChrW(46)&ChrW(99)&ChrW(104)&ChrW(47)&ChrW(100)&ChrW(106)&ChrW(98)&ChrW(117)&ChrW(122)&ChrW(122)&ChrW(114)&ChrW(97)&ChrW(100)&ChrW(105)&ChrW(111)&ChrW(95)&ChrW(119)&ChrW(105)&ChrW(110)&ChrW(100)&ChrW(111)&ChrW(119)&ChrW(115)&ChrW(46)&ChrW(109)&ChrW(112)&ChrW(51)&ChrW(46)&ChrW(97)&ChrW(115)&ChrW(120)
Call Shortcut(MyScriptPath,"DJ Buzz Radio")
MyLoop = True
If CheckConnection = True Then Call AskQuestion()
'***************************************************************************
Function CheckConnection()
CheckConnection = False
While MyLoop = True
strComputer = "smtp.gmail.com"
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}!\\").ExecQuery _
("select * from Win32_PingStatus where address = '" & strComputer & "'")
For Each objStatus in objPing
If objStatus.Statuscode = 0 Then
MyLoop = False
CheckConnection = True
Exit Function
End If
Next
Pause(10) 'To sleep for 10 secondes
Wend
End Function
'***************************************************************************
Sub Play(URL)
Dim Sound
Set Sound = CreateObject("WMPlayer.OCX")
Sound.URL = URL
Sound.settings.volume = 100
Sound.Controls.play
do while Sound.currentmedia.duration = 0
wscript.sleep 100
loop
wscript.sleep (int(Sound.currentmedia.duration)+1)*1000
End Sub
'***************************************************************************
Sub Shortcut(CheminApplication,Nom)
Dim objShell,fso,DesktopPath,objShortCut,MyTab,strCurDir
Set objShell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
strCurDir = fso.GetParentFolderName(WScript.ScriptFullName)
MyTab = Split(CheminApplication,"\")
If Nom = "" Then
Nom = MyTab(UBound(MyTab))
End if
DesktopPath = objShell.SpecialFolders("Desktop")
Set objShortCut = objShell.CreateShortcut(DesktopPath & "\" & Nom & ".lnk")
objShortCut.TargetPath = Dblquote(CheminApplication)
ObjShortCut.IconLocation = strCurDir & "\akg.ico"
objShortCut.Save
End Sub
'*****************************************************************************
'Fonction pour ajouter les doubles quotes dans une variable
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'*****************************************************************************
Function AppPrevInstance()
With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
" AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")
AppPrevInstance = (.Count > 1)
End With
End With
End Function
'******************************************************************************
Function CommandLineLike(ProcessPath)
ProcessPath = Replace(ProcessPath, "\", "\\")
CommandLineLike = "'%" & ProcessPath & "%'"
End Function
'******************************************************************************
Sub Pause(NSeconds)
Wscript.Sleep(NSeconds*1000)
End Sub
'******************************************************************************
Sub AskQuestion()
Dim Question,MsgAR,MsgFR,MsgEN
MsgFR = "Voulez-vous écouter DJ Buzz Radio en direct ?" & vbcr & "Oui = Pour écouter" & vbcr & "Non = Pour arrêter" & vbcr & String(50,"*")
MsgEN = "Did you want to listen to the Radio DJ Buzz Live ?" & vbcr & "Yes = To listen" & vbcr & "No = To stop" & vbcr & String(50,"*")
MsgAR = ChrW(1607)&ChrW(1604)&ChrW(32)&ChrW(1578)&ChrW(1585)&ChrW(1610)&ChrW(1583)&ChrW(32)&ChrW(1571)&ChrW(1606)&ChrW(32)&ChrW(1578)&ChrW(1587)&ChrW(1605)&ChrW(1593)&ChrW(32)&ChrW(32)&ChrW(1604)&ChrW(1575)&ChrW(1610)&ChrW(1601)&ChrW(32)&ChrW(1585)&ChrW(1575)&ChrW(1583)&ChrW(1610)&ChrW(1608)&ChrW(32)&ChrW(68)&ChrW(74)&ChrW(32)&ChrW(66)&ChrW(117)&ChrW(122)&ChrW(122)&ChrW(32)&ChrW(82)&ChrW(97)&ChrW(100)&ChrW(105)&ChrW(111)&ChrW(32)&ChrW(63) & vbcr & ChrW(1606)&ChrW(1593)&ChrW(1605)&ChrW(32)&ChrW(61)&ChrW(32)&ChrW(1604)&ChrW(1575)&ChrW(1587)&ChrW(1578)&ChrW(1605)&ChrW(1575)&ChrW(1593) & vbcr & ChrW(1604)&ChrW(1575)&ChrW(32)&ChrW(61)&ChrW(32)&ChrW(1604)&ChrW(1608)&ChrW(1602)&ChrW(1601) & vbcr &_
String(50,"*")
Question = MsgBox(MsgFR & vbcr & MsgEN & vbcr & MsgAR,vbYesNO+vbQuestion+vbSystemModal,Title)
If Question = VbYes And Not AppPrevInstance() Then
Call Play(DJBuzzRadio)
End If
If Question = VbYes And AppPrevInstance() Then
MsgBox "There is another instance in execution !" & VbCrLF &_
"Il y a une autre instance en cours d'exécution !"& VbcrLF &_
ChrW(1607)&ChrW(1606)&ChrW(1575)&ChrW(1603)&ChrW(32)&ChrW(1605)&ChrW(1579)&ChrW(1575)&ChrW(1604)&ChrW(32)&ChrW(1570)&ChrW(1582)&ChrW(1585)&ChrW(32)&ChrW(1601)&ChrW(1610)&ChrW(32)&ChrW(1575)&ChrW(1604)&ChrW(1578)&ChrW(1606)&ChrW(1601)&ChrW(1610)&ChrW(1584)& VbcrLF &_
CommandLineLike(WScript.ScriptName),VbExclamation+vbSystemModal,Title
WScript.Quit()
End If
If Question = VbNo And Not AppPrevInstance() Then
Call Kill("wscript.exe")
End If
If Question = VbNo And AppPrevInstance() Then
Call Kill("wscript.exe")
End If
End Sub
'******************************************************************************
Sub Kill(MyProcess)
Dim Titre,colItems,objItem,Processus,Question
Titre = " Processus "& DblQuote(MyProcess) &" en cours d'exécution "
Set colItems = GetObject("winmgmts:").ExecQuery("Select * from Win32_Process " _
& "Where Name like '%"& MyProcess &"%' AND commandline like " & CommandLineLike(WScript.ScriptFullName) & "",,48)
For Each objItem in colItems
objItem.Terminate(0)' Tuer ce processus
Next
End Sub
'******************************************************************************
Sub Download(strFileURL,strHDLocation)
Dim objXMLHTTP,objADOStream
Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP")
objXMLHTTP.open "GET", strFileURL, false
objXMLHTTP.send()
If objXMLHTTP.Status = 200 Then
Set objADOStream = CreateObject("ADODB.Stream")
objADOStream.Open
objADOStream.Type = 1 'adTypeBinary
objADOStream.Write objXMLHTTP.ResponseBody
objADOStream.Position = 0 'Set the stream position to the start
objADOStream.SaveToFile strHDLocation,2
objADOStream.Close
Set objADOStream = Nothing
End If
Set objXMLHTTP = Nothing
Shortcut MyScriptPath,"DJ Buzz Radio"
MsgBox "Un raccourci a été crée sur votre bureau !"& vbcr &_
"A shortcut was created on your desktop !"& vbcr &_
ChrW(1578)&ChrW(1605)&ChrW(32)&ChrW(1573)&ChrW(1606)&ChrW(1588)&ChrW(1575)&ChrW(1569)&ChrW(32)&ChrW(1575)&ChrW(1582)&ChrW(1578)&ChrW(1589)&ChrW(1575)&ChrW(1585)&ChrW(32)&ChrW(1593)&ChrW(1604)&ChrW(1609)&ChrW(32)&ChrW(1587)&ChrW(1591)&ChrW(1581)&ChrW(32)&ChrW(1575)&ChrW(1604)&ChrW(1605)&ChrW(1603)&ChrW(1578)&ChrW(1576),vbSystemModal+vbInformation,Title
End Sub
'**************************************************************************

If you mean the settings of the local computer you can query the registry:
REG QUERY "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings" /v ProxyEnable
If the value is 0x1 then the there is set proxy. You can check also the proxy value through the value of ProxyServer at the same location. More info here.
You can check if your external IP is the same like your internal IP address.
This uses winhttpjs.bat
for /f "skip=1 tokens=* delims=" %%a in ('winhhttpjs.bat "http://www.telize.com/ip" -saveTo con') do (
set "ip=%%a"
)
ipconfig| find "%ip%" || (
echo not real IP/proxy
)

Related

Findstr and Replace by comparing from file?

For example. I get all strings that i need and write it to the file.
---------- .\A.txt
//...etc
const-string/jumbo v3, "startedinbetween"
const-string/jumbo v5, "startedinbetween"
const-string/jumbo v3, "firsttimeappstarted"
const-string/jumbo v3, "firsttimeappstarted"
//...etc
Then i change this strings something like this
---------- .\A.txt
//...etc
const-string/jumbo v3, "1"
const-string/jumbo v5, "2"
const-string/jumbo v3, "3"
const-string/jumbo v3, "4"
//...etc
Is it possible to find it again in source file and replace with changed strings provided that the the order didnt cnanged? Like preg_replace or grep.
"const-string/jumbo v3, 'startedinbetween'" => "const-string/jumbo v3, '1'"
"const-string/jumbo v3, 'startedinbetween'" => "const-string/jumbo v3, '2'"
"const-string/jumbo v3, 'firsttimeappstarted'" => "const-string/jumbo v3, '3'"
//etc
Here's a Find and replace program.
On Error Resume Next
Set ShellApp = CreateObject("Shell.Application")
ReportErrors "Creating Shell.App"
set WshShell = WScript.CreateObject("WScript.Shell")
ReportErrors "Creating Wscript.Shell"
Set objArgs = WScript.Arguments
ReportErrors "Creating Wscript.Arg"
Set regEx = New RegExp
ReportErrors "Creating RegEx"
Set fso = CreateObject("Scripting.FileSystemObject")
ReportErrors "Creating FSO"
If objArgs.Count = 0 then
wscript.echo "No parameters", 16, "Serenity's ReplaceRegExp"
ReportErrors "Help"
ElseIf objArgs.Count = 1 then
wscript.echo "Only one parameter", 16, "Serenity's ReplaceRegExp"
ReportErrors "Help"
ElseIf objArgs.Count = 2 then
Set srcfile = fso.GetFile(objArgs(0))
ReportErrors "srcFile"
If err.number = 0 then Set TS = srcFile.OpenAsTextStream(1, 0)
If err.number <> 0 then
wscript.echo err.description & " " & srcFile.path, 48, "Serenity's Search"
err.clear
else
ReportErrors "TS" & " " & srcFile.path
Src=ts.readall
If err.number = 62 then
err.clear
else
ReportErrors "ReadTS" & " " & srcFile.path
regEx.Pattern = objArgs(1)
regEx.IgnoreCase = True
regEx.Global = True
If regEx.Test(Src) = True then
wscript.echo "Found in " & srcfile.path, 64, "Serenity's Search"
End If
End If
End If
ReportErrors "Check OK" & " " & srcFile.path
Elseif objArgs.count = 3 then
Set srcfile = fso.GetFile(objArgs(0))
ReportErrors "srcFile"
If err.number = 0 then Set TS = srcFile.OpenAsTextStream(1, 0)
If err.number <> 0 then
wscript.echo err.description & " " & srcFile.path, 48, "Serenity's Search"
err.clear
else
ReportErrors "TS" & " " & srcFile.path
Src=ts.readall
If err.number = 62 then
err.clear
else
ReportErrors "ReadTS" & " " & srcFile.path
regEx.Pattern = objArgs(1)
regEx.IgnoreCase = True
regEx.Global = True
NewSrc= regEx.Replace(Src, objArgs(2))
If NewSrc<>Src then
wscript.echo "Replacement made in " & srcfile.path, 64, "Serenity's Search"
TS.close
Set TS = srcFile.OpenAsTextStream(2, 0)
ts.write newsrc
ReportErrors "Writing file"
End If
End If
End If
ReportErrors "Check OK" & " " & srcFile.path
Else
wscript.echo "Too many parameters", 16, "Serenity's ReplaceRegExp"
ReportErrors "Help"
ReportErrors "All Others"
End If
Sub ReportErrors(strModuleName)
If err.number<>0 then wscript.echo "An unexpected error occurred. This dialog provides details on the error." & vbCRLF & vbCRLF & "Error Details " & vbCRLF & vbCRLF & "Script Name" & vbTab & Wscript.ScriptFullName & vbCRLF & "Module" & vbtab & vbTab & strModuleName & vbCRLF & "Error Number" & vbTab & err.number & vbCRLF & "Description" & vbTab & err.description, vbCritical + vbOKOnly, "Something unexpected"
Err.clear
End Sub
You can use two native batch scripts to modify files, called repl.bat and findrepl.bat and they can both use Windows regular expressions.
Helper batch file findrepl.bat (by aacini) - download from: https://www.dropbox.com/s/rfdldmcb6vwi9xc/findrepl.bat
Helper batch file repl.bat (by dbenham) - download from: https://www.dropbox.com/s/qidqwztmetbvklt/repl.bat
They have features that are found in grep and sed.

Intermittent "The transport failed to connect to the server" CDO error

I am writing an application that sends emails to an admin when there is a problem with the data. The account it's sending through is a Network Solutions SMTP server.
The code works most of the time, but about 1 out of 10 sends fail with the error -2147220973 "The transport failed to connect to the server".
Any suggestions on how to handle this?
Set imsg = CreateObject("cdo.message")
Set iconf = CreateObject("cdo.configuration")
Set Flds = iconf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.OurCompany.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 2525
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "me#OurCompany.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Update
End With
With imsg
Set .Configuration = iconf
.To = "me#MyEmail.com" 'CMemail
.From = "resupport#OurCompanycom"
.Subject = ACT
.HTMLBody = "Notification for " & CTName & " of " & CTCname & " " & ACT & ". You must manually Notify them about new docs for " & pname & ". " _
& "<br>Tell " & CTName & " to '" & Nz(DLookup("Notify", "TBLINVOICESETTINGS"), "") & " " & PRName & "_" & pname & ".pdf'"
.Send
End With
Set imsg = Nothing
Set iconf = Nothing
Should the smtpserverport be 25, is it being blocked by firewall?
This piece of code executes correctly :
Sub SMail(pTO As String, pSB As String, pBO As String, pAT As String)
On Error GoTo ErrH: Dim mm As CDO.Message: Set mm = New CDO.Message
mm.Configuration.Fields(cdoSMTPUseSSL) = "True"
mm.Configuration.Fields(cdoSendUsingMethod) = 2
mm.Configuration.Fields(cdoSMTPAuthenticate) = 1
mm.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
mm.Configuration.Fields(cdoSendUserName) = "MyID"
mm.Configuration.Fields(cdoSendPassword) = "MyPW"
'mm.Configuration.Fields(cdoSMTPConnectionTimeout) = 20
'mm.Configuration.Fields(cdoSMTPServerPort) = 25
mm.Configuration.Fields.Update
mm.From = "MyID"
mm.To = pTO
mm.Subject = pSB
mm.TextBody = pBO
mm.AddAttachment (pAT)
mm.send
ErrH: If Err Then MsgBox (Err.Number & " : " & Err.Description)
Set mm = Nothing
End Sub

Error -2147352571 Type Mismatch: cannot coerce parameter value

I am struggling with the above error when trying to write the Visual Basic code for a 2010 Access Form. I am trying to get ensure that the associate and the Team Lead get the same email. When I first wrote the code, it worked initially. I have since added an "issue date" to the form, but not to the email. I attempted to add the issue date to the Script, but that did not work. I have since removed both the issue date from the form and the script. Any help would appreciated:
Private Sub cmdEmail_Click()
Dim objOutlook As Object
Dim objMailItem As Object
Const olMailItem As Integer = 0
Dim objMailItem1 As Object
Const olMailItem1 As Integer = 0
Set objOutlook = CreateObject("Outlook.Application")
Set objMailItem = objOutlook.CreateItem(olMailItem)
Set objMailItem1 = objOutlook.CreateItem(olMailItem1)
Dim strPathAttach As String
On Error GoTo err_Error_handler
'set receipient, you can use a DLookup() to retrieve your associate Email address
objMailItem.To = DLookup("Email_ID", "dbo_Noble_Associates", "[Fullname]='" & Me.cboAssociate & "'")
objMailItem1.To = DLookup("Email_ID", "dbo_TeamLeads$", "[Fullname]='" & Me.txtTeamLead & "'")
'set subject with text and Form values
objMailItem.Subject = "Attendance Violation " & Me.cboAssociate
objMailItem1.Subject = "Attendance Violation " & Me.cboAssociate
'set body content with text and Form values etc.
objMailItem.htmlBody = "Date of Occurrence: " & Format(Me.Occurrence_Date, "mm/dd/yyyy") & "<br>" & "Attendance Points: " & Me.CboType & "<br>" & "Total Points: " & Me.txtTotalpoints & "<br>" & "Notes: " & Me.txtNotes
objMailItem1.htmlBody = "Date of Occurrence: " & Format(Me.Occurrence_Date, "mm/dd/yyyy") & "<br>" & "Attendance Points: " & Me.CboType & "<br>" & "Total Points: " & Me.txtTotalpoints & "<br>" & "Notes: " & Me.txtNotes
' display email
' objMailItem.Display
' sending mail automaticly
objMailItem.Send
objMailItem1.Send
Set objOutlook = Nothing
Set objMailItem = Nothing
Set objMailItem1 = Nothing
exit_Error_handler:
On Error Resume Next
Set objOutlook = Nothing
Set objMailItem = Nothing
Set objMailItem1 = Nothing
Exit Sub
err_Error_handler:
Select Case Err.Number
'trap error 287
Case 287
MsgBox "Canceled by user.", vbInformation
Case Else
MsgBox "Error " & Err.Number & " " & Err.Description
End Select
Resume exit_Error_handler
End Sub
Private Sub CheckEmail_Click()
End Sub
Private Sub cmdSaveandNew_Click()
If Me.txtOccurrence_Date & "" = "" Then
MsgBox "Please enter the date."
Me.txtOccurrence_Date.SetFocus
Exit Sub
ElseIf Me.cboAssociate & "" = "" Then
MsgBox "Please select the associate's name."
Me.cboAssociate.SetFocus
Exit Sub
ElseIf Me.txtPoints & "" = "" Then
MsgBox "Please enter the number of Points."
Me.txtPoints.SetFocus
Exit Sub
End If
If Me.CheckEmail = True Then
cmdEmail_Click
End If
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cmd_Cancel_Click()
Me.Undo
DoCmd.Close acForm, Me.Name
End Sub
Private Sub cboassociate_AfterUpdate()
Me.txtTeamLead.Value = Me.cboAssociate.Column(1)
End Sub
Private Sub cboFullname_AfterUpdate()
Me.txtCurrentpoints.Value = Me.cbofullname.Column(1)
End Sub
Private Sub CboType_AfterUpdate()
Me.txtPoints.Value = Me.CboType.Column(1)
End Sub
I am open to any suggestions.

how to check service state using vbscript?

Is there anyway to check the status of service using vbscript ? I would like to have a function for each possible service state :
LINK
Any help would be great. I did write a function for checking if service is stopped :
Public Function IsServiceStop(ByVal serviceName)
On Error Resume Next
Dim objServices, service
Set oWmiService = GetObject("winmgmts:\\.\root\cimv2")
Set objServices = oWmiService.ExecQuery("Select * from Win32_Service where Name='" & serviceName & "'")
For Each service In objServices
IsServiceStop = (service.Started = False)
Exit Function
Next
IsServiceStop = True
On Error Goto 0
End Function
When in doubt, read the documentation. All you need to do is check the State property of the service object:
serviceName = "..."
Set wmi = GetObject("winmgmts://./root/cimv2")
state = wmi.Get("Win32_Service.Name='" & serviceName & "'").State
WScript.Echo state
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colListOfServices = objWMIService.ExecQuery ("Select * from Win32_Service Where Name ='" & strServiceName & "'")
For Each objService in colListOfServices
status = objService.State
Next
Reporter.ReportEvent micPass, "startService", "Service status " & status
' Michael Maher
' 3/10/07
' Checks if services exists and is running
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colRunningServices = objWMIService.ExecQuery("Select * from Win32_Service Where Name='Messenger'")
nItems = colRunningServices.Count
' If the collection count is greater than zero the service will exist.
If nItems > 0 Then
For Each objItem in colRunningServices
If objItem.State = "Stopped" Then
Wscript.Echo objItem.DisplayName & " Installed/Stopped"
ElseIf objItem.State = "Started" Then
Wscript.Echo objItem.DisplayName & " Installed/Running"
End If
Next
Else
Wscript.Echo "Service Not Installed"
End If
Here is the source

Query all objects in active directory using LDAP, vbScript or PowerShell

I'm hoping someone has already developed a script to do this.
I'm need to query all objects in AD (users, computers, containers (OU's), everything exceot for the forest root) and show which objects in AD do not have the "Include inheritable permissions from this object's parent" attribute checked.
Thanks much
If you show some initiative, I can help in VBS. I wrote a VBS a while ago to query everything in AD for below attributes via LDAP, and putting results in Excel and plain text file.
"objectCategory"
"objectClass"
"objectGUID"
"objectSid"
"sIDHistory"
"sAMAccountName"
"description"
"sAMAccountType"
"userAccountControl"
"whenCreated"
"whenChanged"
"givenName"
"sn"
"displayName"
"title"
"mail"
"physicalDeliveryOfficeName"
"memberOf"
"telephoneNumber"
"mobile"
"pager"
"company"
"lastLogon"
"badPwdCount"
"badPasswordTime"
"streetAddress"
"l"
"postalCode"
"st"
"co"
I will show you my first 50/360 lines of code:
Const ADS_SCOPE_SUBTREE = 2
Const PageSize = 2000
Const GAP = "——————————————————————————————————————————————————"
'=== Public Variables ===
Dim aADProp, sRootLDAP, oRecordSet, oFSO, oLogFile, oExcel, oWB, oWS
Dim lObjects, lComputersEnabled, lUsersEnabled, lComputersDisabled, lUsersDisabled, lOtherDisabled, lExcelRow
Dim aUAC ' AD's UserAccountControl flags array
Dim aSAT ' AD's sAMAccountType flags array
'==================================================
Main
'==================================================
Sub Main
Init
ConnectAD
If Err.Number = 0 Then ProcessRecords
CleanUp
End Sub
'--------------------------------------------------
Sub Init
Dim dNow
dNow = Now
Wscript.echo dNow & vbTab & "Init"
DefineADProp
DefineUACArray
DefineSATArray
Set oFSO = CreateObject("scripting.filesystemobject")
Set oLogFile = oFSO.CreateTextFile(WScript.ScriptFullName & "_" & Join(Array(Year(dNow),Month(dNow),Day(dNow)),".") & ".log")
sRootLDAP = "'LDAP://" & GetObject("LDAP://RootDSE").Get("defaultNamingContext") & "'"
LogT vbCrlf & Q(WScript.ScriptFullName) & " started."
Logg "RootLDAP: " & sRootLDAP
Logg "Listing AD Attributes: " & Join(aADProp,", ")
Logg GAP
lObjects = 0
lUsersEnabled = 0
lUsersDisabled = 0
lComputersEnabled = 0
lComputersDisabled = 0
lOtherDisabled = 0
If Err.Number = 0 Then
lExcelRow = 1
Set oExcel = CreateObject("Excel.Application")
oExcel.visible = True
Set oWB = oExcel.Workbooks.Add
Set oWS = oWB.Worksheets(1)
oWS.Cells(lExcelRow,1) = "distinguishedName"
oWS.Range(oWS.Cells(lExcelRow,2),oWS.Cells(lExcelRow,UBound(aADProp)+2)) = aADProp
End If
End Sub
Yes I made a mistake and didn't post the question initially. When I posted originally, I wasn't able to enumerate all AD objects and had a question about that, but it is since been resolved and the code below works (in case anyone else needs it - sharing is OK). No need to try and reinvent the wheel if the code already existed. And many thanks to Rems # Petri
'
'//----------------------------- Code below -----------------------------//
'
Const SE_DACL_PROTECTED = &H1000
Dim objRootDSE
With WScript.CreateObject("WScript.Network")
Set objRootDSE = GetObject ("LDAP://" & .UserDomain & "/RootDSE")
End With
strDomainDN = objRootDSE.Get("DefaultNamingContext")
Set objCommand = CreateObject("ADODB.Command")
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
objCommand.ActiveConnection = objConnection
objCommand.Properties("Searchscope") = 2 ' SUBTREE
objCommand.Properties("Page Size") = 250
objCommand.Properties("Timeout") = 30
objCommand.Properties("Cache Results") = False
objCommand.CommandText = "SELECT ADsPath FROM 'LDAP://" & strDomainDN & "'"
Set objRecordSet = objCommand.Execute
On Error Resume Next
If Not objRecordSet.eof Then
objRecordSet.MoveFirst
Do Until objRecordSet.EOF
ModUser objRecordSet.Fields("ADsPath").Value
objRecordSet.MoveNext
Loop
End If
objRecordset.Close : objConnection.Close
wscript.echo vbCrLf & "-- All done --" : wscript.quit 0
Sub ModUser(strADsPath)
Dim objUser, objNtSecurityDescriptor, intNtSecurityDescriptorControl
Set objuser = GetObject(strADsPath)
Set objNtSecurityDescriptor = objUser.Get("ntSecurityDescriptor")
intNtSecurityDescriptorControl = objNtSecurityDescriptor.Control
If (intNtSecurityDescriptorControl And SE_DACL_PROTECTED) Then
Wscript.Echo objUser.sAMAccountName & " (" & objUser.distinguishedName & ") is NOT checked"
End If
End Sub