excel vba ping list of computers - vba

I am working on a project. My goal is, to ping all of the computers from an excel list, but can't figure out why it isn't working. I am quite new at this programming language, and I am sure that I miss out something, because I get the error message: Object required
so here is my code
the main:
Sub pingall_Click()
Dim c As Range
c = Target.Name
For Each c In Range("A1:N50")
If (Left(c, 1) = "C" Or Left(c, 1) = "T") And IsNumeric(Right(c, 6)) And Len(c) = 7 Then
c = sPing(c)
If c = "timeout" Then
MsgBox "timeout"
ElseIf c < 16 And c > -1 Then
MsgBox "ok"
ElseIf c > 15 And c < 51 Then
MsgBox "not ok"
ElseIf c > 50 And c < 4000 Then
MsgBox "big delay"
Else
MsgBox "error"
End If
End If
Next c
End Sub
The function:
Public Function sPing(sHost) As String
Dim oPing As Object, oRetStatus As Object
Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & sHost & "'")
For Each oRetStatus In oPing
If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
sPing = "timeout" 'oRetStatus.StatusCode
Else
sPing = sPing & vbTab & oRetStatus.ResponseTime & Chr(10)
End If
Next
End Function
I can get the result if I write sPing(""), but I want it to get the name of pc-s that are in the list.
This is just a test version of the script, I am testing it with one pc for now, that is why I use "MsgBox".
Thank you

The 2nd line inside the Sub pingall_Click() subroutine is the one throwing the Object Required error. i.e. the following line.
c = Target.Name
If you comment it out or delete it, it works. (I tried it.)
Also, you should not be assigning the return value from the function sPing back to c.
Because doing so will overwrite the name of the Server / IP address you have in the cell, since the forloop is looping over 1 cell at a time using the c variable.
So instead, assign it back to a new string variable, and then do whatever you want with it.

Related

Why am I getting a run time error 2185 on a form and not on another?

I'm kinda new to MS Access and I'm sort of learning while coding, so forgive me if my question is a bit weird.
I have created a form based on a table, and in the form I have a text box that the user would type something and it should filter the table and show the results based on what the user typed. There are two forms with pretty much the same code on them (named Rec and Cx). In one of them (Rec) the above description works just fine, but the other (Cx) don't and I get a run-time error 2185. Let me show you some code:
Private Sub strConsRecDesc_KeyUp(KeyCode As Integer, Shift As Integer)
FiltroRec = ""
FilterTextDesc = ""
If Len("" & Me.strConsRecDesc.Text) > 0 Then
intLenDesc = Len(Me.strConsRecDesc.Text)
RequeryForm
strConsRecDesc.SetFocus
Me.FilterOn = True
If intLenDesc > Len(Me.strConsRecDesc.Text) Then
Me.strConsRecDesc = Me.strConsRecDesc & " "
Else
Me.strConsRecDesc = FilterTextDesc
End If
strConsRecDesc.SelStart = intLenDesc
Else
RequeryForm
strConsRecDesc.SetFocus
End If
End Sub
I heard it is good practice to lable variables and fields based on data type, so here int stands for integer, str for strings and Desc refers to the Description field.
Based on what is typed in the field strConsRecDesc I filter the table using the RequeryForm in there, that basically checks all the fields in the form that the user can write into. Let me show you the part for the description field:
strConsRecDesc.SetFocus
If Len(strConsRecDesc.Value) > 0 Then
FilterTextDesc = Me!strConsRecDesc.Value
If Len(FiltroRec) > 0 Then
FiltroRec = FiltroRec & " And "
End If
FiltroRec = FiltroRec & "[recDescricao] LIKE '*" & FilterTextDesc & "*'"
End If
In this form (Rec), I can write, i.e. this is a test and no record is shown, because there is no record with this is a test written in it, and that is correct. If I type something that matches the criteria it works just fine.
However, in the other form (the Cx one), I have the following code for KeyUp:
Private Sub strConsCxDesc_KeyUp(KeyCode As Integer, Shift As Integer)
FiltroCx = ""
FilterTextDesc = ""
If Len("" & Me.strConsCxDesc.Text) > 0 Then
intLenDesc = Len(Me.strConsCxDesc.Text)
RequeryForm
strConsCxDesc.SetFocus
Me.FilterOn = True
If intLenDesc > Len(Me.strConsCxDesc.Text) Then
Me.strConsCxDesc = Me.strConsCxDesc & " "
Else
Me.strConsCxDesc = FilterTextDesc
End If
strConsCxDesc.SelStart = intLenDesc
Else
RequeryForm
strConsCxDesc.SetFocus
End If
End Sub
And the equivalent RequeryForm for the Cx is:
strConsCxDesc.SetFocus
If Len(strConsCxDesc.Value) > 0 Then
FilterTextDesc = Me!strConsCxDesc.Value
If Len(FiltroCx) > 0 Then
FiltroCx = FiltroCx & " And "
End If
FiltroCx = FiltroCx & "[cxDescricao] LIKE '*" & FilterTextDesc & "*'"
End If
But in the Cx one if I type this is a test in the strConsCxDesc textbox I get a run-time error 2185.
I understand that with just this bit of code it is kinda hard to grasp what I'm trying to do, but I really don't know why I'm getting this error if the code is the same.
I appreciate any help, and I'm sorry for my bad english, it's not my mother language.
Thanks in advance.

Setting CheckBoxes from another userform in VBA

I have a userform which contains a number of checkboxes from 1 to 100. I have written some very simple code so that when you submit the form it creates a binary string that represents the state of those 100 checkboxes, where 0 is false and 1 is true. The code to do this is here:
Private Sub BusRulesSubmit_Click()
Dim myBinaryString As String
Dim nm As String
Dim c As Control
For busRuleIdx = 1 To 100
nm = "CheckBox" & busRuleIdx
Set c = Controls(nm)
If c.Value = True Then
myBinaryString = myBinaryString & "1"
Else
myBinaryString = myBinaryString & "0"
End If
Next
msgBox myBinaryString
End Sub
I now want to open this Userform from another form, where I have a similar binary string, and use this string to set the values of the checkboxes to true or false as appropariate. However I am having issues when setting my control. The code is here:
Private Sub populateBusRules()
Dim c As Control
Dim myBRBinary As String
myBRBinary = "000000000011100000000000000000000000000000000000000000000000000000000010000000000000000000000000000"
For busRuleIdx = 1 To 100
nm = "BusinessRules.CheckBox" & busRuleIdx
Set c = Controls(nm)
If Mid(myBRBinary, buRuleIdx - 1, 1) = 1 Then
c.Value = True
Else
c.Value = False
End If
Next
End Sub
When I run the above, I get a runtime error "Could not find the specified object" and when going to debug it highlights this problem where the code states "Set c = Controls(nm)" - and I can see that it is failing in the first round of the loop i.e. where nm = "BusinessRules.CheckBox1"
Interestingly if I run the code "Set c = Controls(BusinessRules.CheckBox1)" I get no such issue.
Any help would be much appreciated.
Thanks,
Paul.
I think the BusinessRules is giving you the issue. In the Controls collection, there is no Control named "BusinessRules.CheckBox1", only one named "CheckBox1" within the BusinessRules.Controls collection. Assuming there aren't other issues mentioned in the comments above (like the form being closed before this is called), then this should fix your issue

Type mismatch error using custom class subroutine in Excel VBA

Working in Excel VBA, I have a class module where I define my class 'Marker'. One of the properties of my class is TextLine(), which is an array that holds up to 5 strings. I have defined the two methods below in my class module. In another (regular) module, I fill markerArr() with my custom Marker objects. Loading each object's properties with data at each array index is working fine... However, after loading data into the object at each index, I try to use markerArr(count).ProcessLines but receive a type mismatch error. Since ProcessLines is a public sub in my class module, and markerArr(count) contains a Marker object, I can't seem to understand why this error is occurring... Am I overlooking something obvious?
'Serial number replacement processing function
Public Sub ProcessLines()
Dim strSerial As String
Dim toggle As Boolean
toggle = False
Dim i As Integer
For i = 0 To 4
If Trim(m_TxtLines(i)) <> "" Then
'Add linefeed char to non-empty text lines
m_TxtLines(i) = m_TxtLines(i) & Chr(10)
'Detect if it is a serialized line
If InStr(1, m_TxtLines(i), "XXXXXX-YYY") > 0 Then
m_Serial(i) = True
toggle = True
End If
End If
Next
'When at least one line on the marker is serialized, create and replace serial text
If toggle = True Then
'Only prompt for input once
If startSerNo < 1 And Num_Sers < 1 Then
startSerNo = InputBox("Enter the serial number to start printing at." & Chr(10) & _
"Entering 1 will result in -001, entering 12 will result in -012, etc.", "Starting Serial #", "1")
Num_Sers = InputBox("Enter the amount of serializations to perform." & Chr(10) & _
"This will control how many copies of the entire marker set are printed.", "Total Serializations", "1")
End If
strSerial = CreateSerial(startSerNo)
Dim j As Integer
For j = 0 To 4
If m_Serial(j) Then
m_TxtLines(j) = Replace(m_TxtLines(j), "XXXXXX-YYY", strSerial)
End If
Next
End If
End Sub
'Creates the string to replace XXXXXX-YYY by concatenating the SFC# with the starting serial number
Private Function CreateSerial(ByVal startNum As Integer)
Dim temp
temp = SFC_Num
Select Case Len(CStr(startNum))
Case 1
temp = temp & "-00" & startNum
Case 2
temp = temp & "-0" & startNum
Case 3
temp = temp & "-" & startNum
Case Else
temp = temp & "-001"
End Select
CreateSerial = temp
End Function
Your CreateSerial function takes an integer as a parameter, but you are attempting to pass a string. I've pointed out some problems:
If startSerNo < 1 And Num_Sers < 1 Then 'Here I assume, you have these semi-globals as a variant - you are using numeric comparison here
startSerNo = InputBox("Enter the serial number to start printing at." & Chr(10) & _
"Entering 1 will result in -001, entering 12 will result in -012, etc.", "Starting Serial #", "1") 'Here startSerNo is returned as a string from the inputbox
Num_Sers = InputBox("Enter the amount of serializations to perform." & Chr(10) & _
"This will control how many copies of the entire marker set are printed.", "Total Serializations", "1") 'here Num_Sers becomes a String too
End If
strSerial = CreateSerial(startSerNo) 'here you are passing a String to the CreateSerial function. Either pass an integer, or allow a variant as parameter to CreateSerial
'......more code.....
Private Function CreateSerial(ByVal startNum As Integer)

How to Count the Number of a Specific Character in a Cell with Excel VBA

I have a number of items in cells that are separated by dashes. I'm trying to normalize the database by splitting rows so that each row contains only one entry. How do you find/count strings in Excel VBA. I know you can do values for whole cells with
myVar = Application.WorksheetFunction.COUNTIF(Range("A1:Z100"),"Value")
I need to search a single cell and find out how many hyphens there are. Example
123-456-789 = 2
9876-12 = 1
Using hint from ron's function above I've created this formula and it worked fine :
=LEN(A1) - LEN(SUBSTITUTE(A1, "-", ""))
This will count the number of hyphens in the activecell
Sub test()
a = Len(ActiveCell)
my_txt = Replace(ActiveCell, "-", "", 1, -1, vbTextCompare)
b = Len(my_txt)
numb_occur = a - b
End Sub
Here's the UDF to count single string occurence in string:
Option Explicit
Function COUNTTEXT(ref_value As Range, ref_string As String) As Long
Dim i As Integer, count As Integer
count = 0
If Len(ref_string) <> 1 Then COUNTTEXT = CVErr(xlErrValue): Exit Function
For i = 1 To Len(ref_value.value)
If Mid(ref_value, i, 1) = ref_string Then count = count + 1
Next
COUNTTEXT = count
End Function
Here's using Array formula:
=SUM(IF(ISERROR(SEARCH("-",MID(A1,ROW(INDIRECT("$1:$" & LEN(A1))),1))),0,1))
Entered using Ctrl+Shift+Enter.
Hope this helps.
I found this answer:
Sub xcountCHARtestb()
'If countCHAR(RANGE("aq528"), ".") > 0 Then 'YES
If countCHAR(Selection, ".") > 0 Then 'YES
MsgBox "YES" & Space(10), vbQuestion ', "title"
Else
MsgBox "NO" & Space(10), vbQuestion ', "title"
End If
End Sub
Sub xcountCHARtesta() 'YES
MsgBox "There are " & countCHAR(Selection, "test") & " repetitions of the character string", vbQuestion 'YES
End Sub
Function countCHAR(myString As String, myCHAR As String) As Integer 'as: If countCHAR(Selection, ".") > 1 Then selection OR RANGE("aq528") '"any char string"
countCHAR = UBound(split(myString, myCHAR)) 'YES
End Function
This code might be of your help .. you can also use it as a UDF... :)
Function CountHypens(rng_Src As Range) As Long
'A VARIANT FOR SPLITTING CELL CONTENTS
Dim var As Variant
On Error Resume Next
var = Split(rng_Src.Value, "-", , vbTextCompare)
If Err.Number <> 0 Then
Debug.Print "This cell does not have any hyphens."
Else
CountHypens = UBound(var)
End If
Err.Clear: On Error GoTo 0
End Function
Follow up to: davex, by davex.. :)
I had been looking all over trying to find a way to test same for find text string in a formula.
This answer seems to work correctly for both formulas / not & fits in a 1 liner..
(am still pretty novice at vba, let me know if any better way(s) ) thanks.
If countChar(UCase(Selection.Formula), UCase("offset")) > 0 Then 'YES (thee? answer, works for both formulas / not)
'If countChar(Selection.Formula, "OFFSET") > 0 Then 'yes
'If countChar(Cells(ActiveCell.row, Selection.Column).Formula, "OFFSET") > 0 Then 'yes
'If countChar(Cells(ActiveCell.row, "BG").Formula, "OFFSET") > 0 Then 'yes
'If countChar(UCase(Selection), UCase("OffSET")) > 0 Then 'yes but not work on formula
'If Selection.Formula Like "*offset*" Then 'no (for eq)
MsgBox "YES" & Space(15), vbQuestion
Else
MsgBox "NO" & Space(15), vbQuestion
End If
NOTE: in place of variable "BG" above, i use permanent work cells to improve use for column BG example, work cell A3 has / shows: BG:BG
=SUBSTITUTE(SUBSTITUTE(CELL("address",$BG3),"$",""),ROW(),"")&":"&SUBSTITUTE(SUBSTITUTE(CELL("address",$BG3),"$",""),ROW(),"")
you will also need to dim the work cell, at the top / before the vba:
Dim A3 As String
A3 = RANGE("A3")
pardon, tried 3 times to get all of code into 1 box. really suggest putting a code stop start icon in the toolbar.

This array is fixed or temporarily locked

I am using split function and assigning the value in a variable and running the code in loop after few iterations its giving an error of "This array is fixed or temporarily locked (Visual Basic)"..
e.g; here value of movies_cat1 read from excel is in form of this------
"Movies->List All Movies , Movies->World Cinema->Asia , Movies->Movies by Language->Sinhalese , Movies->Drama"
For crow = 1 To 100
Value = Worksheets("Movies_categories").Range("A" & crow).Value
cat_final = Worksheets("Movies_categories").Range("B" & crow).Value
If Value = "y" Or Value = "Y" Then
'Loop for reading the data from tabsheet- Movies
For crowss = 5 To 3000
movies_cat1 = Worksheets("Movies").Range("B" & crowss).Value
movies_language = Worksheets("Movies").Range("C" & crowss).Value
If movies_language = "English" Then
Temp = Split(movies_cat, ",") 'run time Error:10 occurs here..
For Each boken_c In Temp
flag = 0
boken_c = Trim(boken_c)
If RTrim(LTrim(boken_c)) = LTrim(RTrim(cat_final)) Then
flag = 1
GoTo Line4:
End If
Next boken_c
End If
Next crowss
End If
Line4: Next crow
Error occurs at this statement: Temp = Split(movies_cat, ","), it says that the array is fixed or temporarily locked, because i think initially its taking 'temp' as a variable, but while returning the value of split function, variable 'Temp' becomes array after completion of first loop(i.e after crow = 6,7....)
Your line4 label is outside the for loop on the temp variable so when you goto it leaves it locked.
You really should restructure your code to not use a goto inside the for each loop.
Maybe:
For crow = 1 To 100
Value = Worksheets("Movies_categories").Range("A" & crow).Value
cat_final = Worksheets("Movies_categories").Range("B" & crow).Value
If Value = "y" Or Value = "Y" Then
'Loop for reading the data from tabsheet- Movies
For crowss = 5 To 3000
movies_cat1 = Worksheets("Movies").Range("B" & crowss).Value
movies_language = Worksheets("Movies").Range("C" & crowss).Value
If movies_language = "English" Then
Temp = Split(movies_cat, ",") 'run time Error:10 occurs here..
For Each boken_c In Temp
flag = 0
boken_c = Trim(boken_c)
If RTrim(LTrim(boken_c)) = LTrim(RTrim(cat_final)) Then
flag = 1
**Exit For**
End If
**If flag = 1 Then Exit For**
Next boken_c
End If
**If flag = 1 Then Exit For**
Next crowss
End If
Next crow
(Note the **d lines.)
I had this problem too with VBA. I cannot say I am proud of how I managed to get it, but it is supplied here just in can anyone else accidentally slips up on this.
It is quite interesting to debug as the failure occurs at the call to a sub or function - not at the point of failure. Luckily, you can follow the code through to the offending line of the called routine before it reports the error.
Call Sub1(gArray(3))
debug.print gArray(3)
...
Sub Sub1(i as integer)
Redim gArray(0)
End sub
Clearly the VB RT is not going to like this as by the time the debug.print executes, the array dimension does not exist. Ok why the hell would you want to pass a globally declared array anyway? Guilty as charged.
So in the example above you get the error at the call to Sub1, but the thing causing it is the Redim in the sub.
The moral to the story is do not pass global variables as parameters to subs. Another simple fix is to declare the Sub1 slightly differently:
Sub Sub1(ByVal i as integer)
This means the i variable is copied (but not returned) by the Sub.
Thanks, Deanna for the answer! I have a similar message on ReDim Preserve statement at the last line in next fragment of code:
If StrComp(Mid(s, 1, lE), txtE, vbBinaryCompare) = 0 Then
For i = iMdl To 1 Step -1
With blks(i)
If .lnEnd = 0 Then ' ".lnEnd" is a member of blks(i)
.lnEnd = ln
GoTo NXT
End If
End With
Next
errBegWith = errBegWith & ln & ", "
NXT:
End If
'...
ReDim Preserve blks(iMdl)
And after extracting assignment .lnEnd = ln from inside of the With the program works fine:
If StrComp(Mid(s, 1, lE), txtE, vbBinaryCompare) = 0 Then
For i = iMdl To 1 Step -1
If blks(i).lnEnd = 0 Then
blks(i).lnEnd = ln
GoTo NXT
End If
Next
errBegWith = errBegWith & ln & ", "
NXT:
End If
'...
ReDim Preserve blks(iMdl)