Is it possible to list all the open applications in debug.print?
I tried the below code which doesn't work.
Dim app As Application
For Each app In Windows.Applications
Debug.Print app.Name
Next app
Try something like this.
Dim strComputer As String
Dim objWMIService As Variant
Dim colItems As Variant
Dim objItem As Variant
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process", , 48)
For Each objItem In colItems
Debug.Print objItem.ProcessId & " " & objItem.Name & " " & objItem.Caption & " " & objItem.CommandLine & " " & objItem.ExecutablePath
Next
Related
I have a function to parse an xml document received from the tracking system of TNT courier,
this is example of a query url i'm using:
https://www.tnt.it/tracking/getXMLTrack?WT=1&ConsigNos=RL38536236
the function worked correctly on all PCs until yesterday,
when on some PCs the method .Load(URL) of DOMDocument object returns false result and the DocumentElement property is null,
the thing is: if i browse to that url (i used firefox, chrome, edge, iexplore)
the xml is showed correctly!
this is the code:
Function TrackTNTlist(LDV As String) As Collection
Dim TNTlist As New Collection
Dim Obj As MSXML2.DOMDocument60
Dim Verifica As Boolean
Dim XMLTNT As String
Dim NodoLista As IXMLDOMNodeList
Dim NodoSingolo As IXMLDOMNode
Dim Nome As IXMLDOMNode
Dim DataConsegna As IXMLDOMNode
Dim NomeRicevente As IXMLDOMNode
Dim Destinatario As IXMLDOMNode
Dim ConsignmentDetails As IXMLDOMNode
Dim DataPrevConsegna As IXMLDOMNode
Dim NuovaLDV As IXMLDOMNode
Dim Dest As String, DatiSped As String
On Error GoTo RigaErrore
XMLTNT = "https://www.tnt.it/tracking/getXMLTrack?WT=1&ConsigNos=" & LDV
Set Obj = New MSXML2.DOMDocument60
Obj.async = False
Verifica = Obj.Load(XMLTNT)
If Verifica = True Then
MsgBox "File XML " & XMLTNT & "loaded"
Else
MsgBox "File XML NOT loaded"
TNTlist.Add "ERROR - XML tracking data not loaded"
Exit Function
End If
Set NodoSingolo = Obj.DocumentElement.SelectSingleNode("Consignment/StatusDetails/StatusDescription")
If NodoSingolo Is Nothing Then
TNTlist.Add "LDV non trovata"
Else
Set NodoList = Obj.DocumentElement.SelectNodes("Consignment/StatusDetails")
Set ConsignmentDetails = Obj.DocumentElement.SelectSingleNode("Consignment/ConsignmentDetails")
DatiSped = ""
DatiSped = "LETTERA DI VETTURA: " & LDV & Chr(10)
If Not ConsignmentDetails Is Nothing Then
DatiSped = DatiSped & "RIF. MITTENTE: " & ConsignmentDetails.ChildNodes(0).Text & Chr(10)
DatiSped = DatiSped & "TIPO SERVIZIO: " & ConsignmentDetails.ChildNodes(1).Text & Chr(10)
DatiSped = DatiSped & "NUM. COLLI: " & ConsignmentDetails.ChildNodes(3).Text & Chr(10)
End If
Set NodoSingolo = Obj.DocumentElement.SelectSingleNode("Consignment/StatusDetails/StatusDescription")
Dest = ""
Set DataConsegna = Obj.DocumentElement.SelectSingleNode("Consignment/DeliveryDate")
Set NomeRicevente = Obj.DocumentElement.SelectSingleNode("Consignment/CollectionName")
Set Destinatario = Obj.DocumentElement.SelectSingleNode("Consignment/ReceiverDetails")
Set DataPrevConsegna = Obj.DocumentElement.SelectSingleNode("Consignment/DueDate")
Set NuovaLDV = Obj.DocumentElement.SelectSingleNode("Consignment/HeldInDepotDetails/HID1ReplacingDoc")
If NodoSingolo.Text = "Spedizione consegnata" Then
Dest = "CONSEGNATA A: " & Chr(13)
Else
Dest = "PREVISTA CONSEGNA A: " & Chr(10)
End If
If Not Destinatario Is Nothing Then
Dest = Dest & Destinatario.ChildNodes(4).Text
Dest = Dest & " (" & Destinatario.ChildNodes(6).Text & ")" & Chr(10)
End If
If Not DataPrevConsegna Is Nothing Then
Dest = Dest & DataPrevConsegna.ChildNodes(0).Text & Chr(10)
End If
If Not DataConsegna Is Nothing Then
Dest = Dest & "Data consegna: " & DataConsegna.Text & Chr(10)
End If
If Not NomeRicevente Is Nothing Then
Dest = Dest & "Ha ritirato: " & NomeRicevente.Text & Chr(10)
End If
If Not NuovaLDV Is Nothing Then
Dest = Dest & "NUOVA LETTERA DI VETTURA: " & NuovaLDV.Text & Chr(10)
End If
Dest = Dest & "Dettaglio tracking:" & Chr(10)
TNTlist.Add DatiSped & Chr(10) & Dest & Chr(10)
For Each Nome In NodoList
TNTlist.Add Nome.ChildNodes(1).Text
TNTlist.Add Nome.ChildNodes(2).Text
Next
End If
salto = 1
If salto <> 1 Then
Set NodoSingolo = Obj.DocumentElement.SelectSingleNode("Consignment/StatusDetails/StatusDescription")
If NodoSingolo Is Nothing Then
TNTlist.Add "LDV non trovata"
Else
If NodoSingolo.Text = "Spedizione consegnata" Then
Set DataConsegna = Obj.DocumentElement.SelectSingleNode("Consignment/DeliveryDate")
Set NomeRicevente = Obj.DocumentElement.SelectSingleNode("Consignment/CollectionName")
Set Destinatario = Obj.DocumentElement.SelectSingleNode("Consignment/ReceiverDetails")
Dest = Destinatario.ChildNodes(4).Text
Dest = Dest & " (" & Destinatario.ChildNodes(5).Text & ")"
TNTlist.Add NodoSingolo.Text & " : " & Dest & " - " & NomeRicevente.Text & " - " & DataConsegna.Text
TNTlist.Add DataConsegna.Text
End If
End If
End If
Set TrackTNTlist = TNTlist
Exit Function
RigaErrore:
MsgBox Err.Number & vbNewLine & Err.Description
Application.EnableEvents = True
Resume Next
End Function
the problem occurs only in few pcs,
they have the same system configuration,
below two screen shots, one from a pc where the function work correctly ad one from another where the problem occurs.
debug screenshot of correct execution
debug screenshot of error execution
in both pcs browsing to the url show the xml correctly.
Could anyone help me to understand what might cause the problem?
Thanks a lot!
Francesco
I have a macro in an Excel Workbook, that is connected to a button that says Export
When I click the button, it triggers the Export XML dialog and I have to manually search for a folder to export it into and enter the filename.
Since the folders in my Documents are named exactly the same as the value of the Cell A24, i would like it to direct itself into the correct folder and suggest me a filename based on the value of the Cell A24 with some extra text behind it.
So far i have this in the VBA:
Public Sub ExportToXML()
Dim strFilePath As String
Dim POFilePath As String
Dim FOFilePath As String
Dim POFileName As String
Dim FOFileName As String
Dim XMLDoc As MSXML2.DOMDocument
Dim xNode As MSXML2.IXMLDOMNode
Dim xAttribute As MSXML2.IXMLDOMAttribute
Dim xElement As MSXML2.IXMLDOMElement
Dim xElementRoot As MSXML2.IXMLDOMElement
Application.ScreenUpdating = False
MainSheetName = ActiveSheet.Name
POFilePath = "C:\Users\admin\Desktop\" & Range("A24")
FOFilePath = "C:\Users\admin\Desktop\" & Range("D22") & " " & Range("A22")
POFileName = "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
FOFileName = "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
If Range("A24").value = "0" Then
strFilePath = Application.GetSaveAsFilename(FOFilePath & FOFileName, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
Else
strFilePath = Application.GetSaveAsFilename(POFilePath & POFileName, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
End If
If strFilePath = "False" Then Exit Sub
This gives me the right filename suggestion, but it doesn't direct me to the folder and goes to Desktop.
Any help would be appriciated!
EDIT:
I tried merging the Strings together a bit more and came up with this:
Public Sub ExportToXML()
Dim strFilePath As String
Dim POFilePath As String
Dim FOFilePath As String
Dim XMLDoc As MSXML2.DOMDocument
Dim xNode As MSXML2.IXMLDOMNode
Dim xAttribute As MSXML2.IXMLDOMAttribute
Dim xElement As MSXML2.IXMLDOMElement
Dim xElementRoot As MSXML2.IXMLDOMElement
Application.ScreenUpdating = False
MainSheetName = ActiveSheet.Name
POFilePath = "C:\Users\admin\Desktop\" & Range("A24") & Range("A24").value & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
FOFilePath = "C:\Users\admin\Desktop\" & Range("D22") & " " & Range("A22") & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
If Range("A24").value = "0" Then
strFilePath = Application.GetSaveAsFilename(FOFilePath, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
Else
strFilePath = Application.GetSaveAsFilename(POFilePath, fileFilter:="XML files (*.xml),*.xml", Title:="Save FileAs...")
End If
If strFilePath = "False" Then Exit Sub
The problem is, that VBA thinks that in:
POFilePath = "C:\Users\admin\Desktop\" & Range("A24") & Range("A24").value & "_report " & Range("D13").value & " " & Range("F13").value & ".xml"
the first Range("A24") belongs to the filename part and doesn't continue on with the filepath. So if the value in A24 was "test", then this suggests saving the xml to Desktop with the filename testttest_report 11 2020
I'm just getting started on learning VBA and am a bit stumped on the following. I'd be grateful for your assistance.
With the following I'm getting: Compile Error: Duplication in Current Scope after ElseIf (ActiveSheet.Name) = "BA Tracker" Then at line folderPathWithName As String.
My assumption had been that what's in the initial If wouldn't impact the subsequent ElseIf. If that isn't the case then I'm really not sure what to take out of the ElseIf to make this work.
Thanks for your help.
Sub CopyFile()
Dim oFSO As Object
Dim SourceFile As String
Dim DestinationFolder As String
Dim startPath As String
Dim myName As String
Dim FileYear As String
Dim FileMonth As String
Dim AgentName As String
Dim Agreement As String
Dim CallDate As String
Dim wb As Workbook
Dim ws1112 As Worksheet
Dim ws2221 As Worksheet
Dim s As String
Dim r As String
Dim cst As String
Dim cd As String
Dim ass As String
Dim ty As String
Dim an As String
Dim ss As String
Dim si As String
Dim sour As String
FileYear = Range("A2")
FileMonth = Range("A3")
AgentName = Range("D1")
Agreement = Range("D2")
CallDate = Range("D3")
If (ActiveSheet.Name) = "Sitel Audit" Then
startPath = "C:\Users\matthew.varnham\Desktop\QA Improvements\" & FileYear & "\" & FileMonth & "\"
myName = ActiveSheet.Range("D1").Text ' Change as required to cell holding the folder title
' check if folder exists, if yes, end, if not, create
Dim folderPathWithName As String
folderPathWithName = startPath & Application.PathSeparator & myName
If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
End If
Set oFSO = CreateObject("Scripting.FileSystemObject")
SourceFile = "C:\Users\matthew.varnham\Desktop\QA Improvements\Customer service Inbound scorecard v9.xlsm"
DestinationFolder = "C:\Users\matthew.varnham\Desktop\QA Improvements\" & FileYear & "\" & FileMonth & "\" & AgentName & "\"
oFSO.CopyFile Source:=SourceFile, Destination:=DestinationFolder & "\" & AgentName & " - " & Agreement & ".xlsm"
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 12), Address:=("C:\Users\matthew.varnham\Desktop\QA Improvements\" & FileYear & "\" & FileMonth & "\" & AgentName & "\" & AgentName & " - " & Agreement & ".xlsm"), TextToDisplay:="OPEN"
Set ws1112 = Sheets("Sitel Audit")
s = ws1112.Range("D1").Value 'Agent Name
r = ws1112.Range("D3").Value 'Call Date
cst = ws1112.Range("D4").Value 'Call Start Time
cd = ws1112.Range("D5").Value 'Call Duration
ass = ws1112.Range("D6").Value 'Assessor Initials
ty = ws1112.Range("D7").Value 'Call Type
an = ws1112.Range("D2").Value 'Agreement Number
ss = ws1112.Range("D8").Value 'Sitel Score
si = ws1112.Range("E1").Value & FileYear & "\" & FileMonth & "\" & AgentName & "\" 'Sitel QA Folder
sour = ws1112.Range("A4").Value 'Sitel as Source
Set wb = Workbooks.Open("C:\Users\matthew.varnham\Desktop\QA Improvements\" & FileYear & "\" & FileMonth & "\" & AgentName & "\" & AgentName & " - " & Agreement & ".xlsm")
Set ws2221 = wb.Sheets("Observation Sheet")
ws2221.Range("B5:C5").Value = s 'Agent Name
ws2221.Range("E5").Value = r 'Call Date
ws2221.Range("F5").Value = cst 'Call Start Time
ws2221.Range("G5").Value = cd 'Call Duration
ws2221.Range("B8:C8").Value = ass 'Assessor Initials
ws2221.Range("B11:C11").Value = ty 'Call Type
ws2221.Range("E8:G8").Value = an 'Agreement Number
ws2221.Range("D4").Value = ss 'Sitel Score
ws2221.Range("G51").Value = si 'Sitel QA Folder
ws2221.Range("C3").Value = sour 'Sitel as Source
ElseIf (ActiveSheet.Name) = "BA Tracker" Then
startPath = "C:\Users\matthew.varnham\Desktop\QA Improvements\BA Tracker\" & FileYear & "\" & FileMonth & "\"
myName = ActiveSheet.Range("D1").Text ' Change as required to cell holding the folder title
' check if folder exists, if yes, end, if not, create
Dim folderPathWithName As String
folderPathWithName = startPath & Application.PathSeparator & myName
If Dir(folderPathWithName, vbDirectory) = vbNullString Then
MkDir folderPathWithName
End If
Set oFSO = CreateObject("Scripting.FileSystemObject")
SourceFile = "C:\Users\matthew.varnham\Desktop\QA Improvements\Customer service Inbound scorecard v9.xlsm"
DestinationFolder = "C:\Users\matthew.varnham\Desktop\QA Improvements\BA Tracker\" & FileYear & "\" & FileMonth & "\" & AgentName & "\"
oFSO.CopyFile Source:=SourceFile, Destination:=DestinationFolder & "\" & AgentName & " - " & Agreement & ".xlsm"
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell.Offset(0, 13), Address:=("C:\Users\matthew.varnham\Desktop\QA Improvements\BA Tracker\" & FileYear & "\" & FileMonth & "\" & AgentName & "\" & AgentName & " - " & Agreement & ".xlsm"), TextToDisplay:="OPEN"
Set ws1112 = Sheets("BA Tracker")
s = ws1112.Range("D1").Value 'Agent Name
r = ws1112.Range("D3").Value 'Call Date
cst = ws1112.Range("D4").Value 'Call Start Time
cd = ws1112.Range("D5").Value 'Call Duration
ass = ws1112.Range("D6").Value 'Assessor Initials
ty = ws1112.Range("D7").Value 'Call Type
an = ws1112.Range("D2").Value 'Agreement Number
ss = ws1112.Range("D8").Value 'Sitel Score
si = ws1112.Range("E1").Value & FileYear & "\" & FileMonth & "\" & AgentName & "\" 'Sitel QA Folder
sour = ws1112.Range("A4").Value 'Sitel as Source
Set wb = Workbooks.Open("C:\Users\matthew.varnham\Desktop\QA Improvements\BA Tracker\" & FileYear & "\" & FileMonth & "\" & AgentName & "\" & AgentName & " - " & Agreement & ".xlsm")
Set ws2221 = wb.Sheets("Observation Sheet")
ws2221.Range("B5:C5").Value = s 'Agent Name
ws2221.Range("E5").Value = r 'Call Date
ws2221.Range("F5").Value = cst 'Call Start Time
ws2221.Range("G5").Value = cd 'Call Duration
ws2221.Range("B8:C8").Value = ass 'Assessor Initials
ws2221.Range("B11:C11").Value = ty 'Call Type
ws2221.Range("E8:G8").Value = an 'Agreement Number
ws2221.Range("D4").Value = ss 'Sitel Score
ws2221.Range("G51").Value = si 'Sitel QA Folder
ws2221.Range("C3").Value = sour 'Sitel as Source
End If
Workbooks("SITEL - Inbound Tracker.XLSM").Close SaveChanges:=True
End Sub
You are declaring the variable folderPathWithName twice - once inside in the If block, and then within the 'ElseIf` block.
Just delete the line Dim folderPathWithName As String from within the ElseIf block, and move the line Dim folderPathWithName As String from within the If block to be with all of the other variable declarations.
I would suggest that you always declare all of your variables at the start of the procedure, rather than when you think that you will need them. This stops this from happening, and also keeps your code tidy.
Regards,
I have created a macro which takes the latest mail and send the reply all.
Now how do I search Inbox and sub folders and pick the latest one.
My code picks the mail only from Inbox.
Option Explicit
Public Sub TESTRUN()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim Subject As String
Subject = ThisWorkbook.Sheets("SendMail").Range("B5").Text
Debug.Print Subject
Dim fpath As String
fpath = ThisWorkbook.Sheets("SendMail").Range("A8").Value
Dim i As Long
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '01/01/1900' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '12/31/2100' And " & _
Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & "Like '%" & Subject & "%'"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]", False
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Dim Item As Object
Set Item = Items(i)
Debug.Print Item.Subject ' Print on Immediate Window
Debug.Print Item.ReceivedTime ' Print on Immediate Window
Dim ReplyAll As Outlook.MailItem
Set ReplyAll = Item.ReplyAll
With ReplyAll
.Subject = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1)
.HTMLBody = "<font size=""3"" face=""Calibri"">" & _
"Hi Veronica, <br><br>" & _
"The " & Left(ActiveWorkbook.Name, _
InStr(ActiveWorkbook.Name, ".") - 1) & _
"</B> has been prepared and ready for your review.<br>" & _
"</B> <br>" & _
"" & fpath & "" & .HTMLBody
.Display
Exit For
End With
End If
Next
End Sub
You could convert your code recursive function start from Inbox :Example
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
' // Process Current Folder
LoopFolders Inbox
Set Inbox = Nothing
End Sub
Private Function LoopFolders(ByVal ParentFldr As Outlook.MAPIFolder)
Dim Subject As String
Subject = ThisWorkbook.Sheets("SendMail").Range("B5").Text
Dim FPath As String
FPath = ThisWorkbook.Sheets("SendMail").Range("A8").Value
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '01/01/1900' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '12/31/2100' And " & _
Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & "Like '%" & Subject & "%'"
Dim Items As Outlook.Items
Set Items = ParentFldr.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]", False
Dim i As Long
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Dim Item As Object
Set Item = Items(i)
Debug.Print Item.Subject & " " & Item.ReceivedTime
Dim ReplyAll As Outlook.MailItem
Set ReplyAll = Item.ReplyAll
With ReplyAll
.Subject = ""
.HTMLBody = "" '
.Display
End With
Exit Function
End If
Next
Dim SubFldr As Outlook.MAPIFolder
' // Recurse through SubFldrs
If ParentFldr.Folders.Count > 0 Then
For Each SubFldr In ParentFldr.Folders
LoopFolders SubFldr
Debug.Print SubFldr.Name
Next
End If
End Function
I need help with a VBS script that produces an Excel sheet with specific user information.
It works... Sort of. The problem is that it seems to recycle information producing inaccurate results. Anybody know how I would go about making the script leave areas in the Excel document blank when no information is available? I know it's possible, just need a nudge in the right direction.
Thank you!
On Error Resume Next
Dim FSO
Dim objStream
Const TriStateFalse = 0
Const FILE_NAME = "Users.csv"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objStream = FSO.CreateTextFile(FILE_NAME, _
True, TristateFalse)
strSubnetPrefix = "192.168.1."
intBeginSubnet = 1
intEndSubnet = 254
For i = intBeginSubnet To intEndSubnet
strComputer = strSubnetPrefix & i
'strcomputer = inputbox("Enter Computer Name or IP")
if strcomputer = "" then
wscript.quit
else
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & strcomputer & "'")
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
'request timed out
'msgbox(strcomputer & " did not reply" & vbcrlf & vbcrlf & _
'"Please check the name and try again")
else
set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\cimv2")
Set colSettings = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
For Each objComputer in colSettings
objStream.WriteLine objComputer.name & "," & objcomputer.username & "," & objcomputer.domain _
& "," & strcomputer
'msgbox("System Name: " & objComputer.Name & vbcrlf & "User Logged in : " & _
'objcomputer.username & vbcrlf & "Domain: " & objComputer.Domain)
Next
end if
next
end if
Next
Msgbox("Done Collecting")
set objwmiservice = nothing
set colsettings = nothing
set objping = nothing
You use the EVIL global On Error Resume Next. That means: all errors are ignored/hidden and the script continues (more or less happily) in a for all practical purposes undefined state. Demo script:
Option Explicit
Dim a : a = Array(1,0,2)
Bad a
Good a
Sub Bad(a)
Dim i, n
On Error Resume Next
For i = 0 To UBound(a)
n = 4712 / a(i)
WScript.Echo "Bad", i, a(i), n
Next
End Sub
Sub Good(a)
Dim i, n
For i = 0 To UBound(a)
On Error Resume Next
n = 4712 / a(i)
If Err.Number Then n = "value to use in case of error"
On Error GoTo 0
WScript.Echo "Good", i, a(i), n
Next
End Sub
output:
cscript oern.vbs
Bad 0 1 4712
Bad 1 0 4712 <--- assignment failed, 'old' value of n retained, no clue about problem
Bad 2 2 2356
Good 0 1 4712
Good 1 0 value to use in case of error
Good 2 2 2356
The strictly local OERN makes sure that the specific problem (division by zero, ping failure) is dealt with, and all other exceptions are reported, so the program can be improved.
further food for thought
Your WMI call variables need to be reset to nothing before you set them again. This script should work better.
On Error Resume Next
Dim FSO
Dim objStream
Const TriStateFalse = 0
Const FILE_NAME = "Users.csv"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objStream = FSO.CreateTextFile(FILE_NAME, _
True, TristateFalse)
strSubnetPrefix = "192.168.1."
intBeginSubnet = 1
intEndSubnet = 254
For i = intBeginSubnet To intEndSubnet
strComputer = strSubnetPrefix & i
'strcomputer = inputbox("Enter Computer Name or IP")
if strcomputer = "" then
wscript.quit
else
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & strcomputer & "'")
For Each objStatus in objPing
If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
'request timed out
'msgbox(strcomputer & " did not reply" & vbcrlf & vbcrlf & _
'"Please check the name and try again")
else
set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & _
strComputer & "\root\cimv2")
Set colSettings = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
For Each objComputer in colSettings
objStream.WriteLine objComputer.name & "," & objcomputer.username & "," & objcomputer.domain _
& "," & strcomputer
'msgbox("System Name: " & objComputer.Name & vbcrlf & "User Logged in : " & _
'objcomputer.username & vbcrlf & "Domain: " & objComputer.Domain)
Next
set objwmiservice = nothing
set colsettings = nothing
end if
next
end if
set objping = nothing
Next
Msgbox("Done Collecting")