Expected Sub, Function or Property Error

ndev2k

New Member
Joined
Dec 16, 2016
Messages
16
I am trying to implement a piece of vba code I found on the web to run a reverse DNS (NSLookup) from an IP address.
However whenever I call the function I am receiving an error
Compile Error
Expected Sub, Function or Property
Could one of the experts please take a look over the code for any obvious errors?
Thanks

Code:
Private Sub DNSLookup_Click()
    Range("C2:C10000").Select
    Selection.ClearContents
    Range("A2").Select
    
    For x = 2 To Sheets("Sheet1").Range("A10000").End(xlUp).Row
        Dim IPAddy As String
        IPAddy = Sheets("Sheet1").Cells(x, 1).Value
        Sheets("Sheet1").Cells(x, 3) = NSLookup (IPAddy)
    Next x
End Sub

Code:
Public Function NSLookup(lookupVal As String, Optional addressOpt As Integer) As String
    Const ADDRESS_LOOKUP = 1
    Const NAME_LOOKUP = 2
    Const AUTO_DETECT = 0
   
    'Skip everything if the field is blank
    If lookupVal <> "" Then
        Dim oFSO As Object, oShell As Object, oTempFile As Object
        Dim sLine As String, sFilename As String
        Dim intFound As Integer
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        Set oShell = CreateObject("Wscript.Shell")
       
        'Handle the addresOpt operand
        'Regular Expressions are used to complete a substring match for an IP Address
        'If an IP Address is found, a DNS Name Lookup will be forced
        If addressOpt = AUTO_DETECT Then
            ipLookup = FindIP(lookupVal)
            If ipLookup = "" Then
                addressOpt = ADDRESS_LOOKUP
            Else
                addressOpt = NAME_LOOKUP
                lookupVal = ipLookup
            End If
        'Do a regular expression substring match for an IP Address
        ElseIf addressOpt = NAME_LOOKUP Then
            lookupVal = FindIP(lookupVal)
        End If
       
        'Run the nslookup command
        sFilename = oFSO.GetTempName
        oShell.Run "cmd /c nslookup " & lookupVal & " > " & sFilename, 0, True
        Set oTempFile = oFSO.OpenTextFile(sFilename, 1)
        Do While oTempFile.AtEndOfStream <> True
            sLine = oTempFile.Readline
            cmdStr = cmdStr & Trim(sLine) & vbCrLf
        Loop
        oTempFile.Close
        oFSO.DeleteFile (sFilename)
       
        'Process the result
        intFound = InStr(1, cmdStr, "Name:", vbTextCompare)
        If intFound = 0 Then
            NSLookup = ""
            Exit Function
        ElseIf intFound > 0 Then
            'TODO: Cleanup with RegEx
            If addressOpt = ADDRESS_LOOKUP Then
                loc1 = InStr(intFound, cmdStr, "Address:", vbTextCompare) + InStr(intFound, cmdStr, "Addresses:", vbTextCompare)
                loc2 = InStr(loc1, cmdStr, vbCrLf, vbTextCompare)
                nameStr = Trim(Mid(cmdStr, loc1 + 8, loc2 - loc1 - 8))
            ElseIf addressOpt = NAME_LOOKUP Then
                loc1 = InStr(intFound, cmdStr, "Name:", vbTextCompare)
                loc2 = InStr(loc1, cmdStr, vbCrLf, vbTextCompare)
                nameStr = Trim(Mid(cmdStr, loc1 + 5, loc2 - loc1 - 5))
            End If
        End If
        NSLookup = nameStr
    Else
        NSLookup = "N/A"
    End If
End Function
Function FindIP(strTest As String) As String
    Dim RegEx As Object
    Dim valid As Boolean
    Dim Matches As Object
    Dim i As Integer
    Set RegEx = CreateObject("VBScript.RegExp")
       
    RegEx.Pattern = "\b(?:\d{1,3}\.){3}\d{1,3}\b"
    valid = RegEx.test(strTest)
    If valid Then
        Set Matches = RegEx.Execute(strTest)
        FindIP = Matches(0)
    Else
        FindIP = ""
    End If
End Function
 

Some videos you may like

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

Kyle123

Well-known Member
Joined
Jan 24, 2012
Messages
2,708
There's nothing wrong with the code you have posted. I suspect you have more code in the workbook than you have posted here - the error lies there
 

ndev2k

New Member
Joined
Dec 16, 2016
Messages
16
Thanks for the response

I do have more code in the workbook which pings the IP address and is working as expected.

I have added the code above and it is only that code that is causing issues.

The full workbook code is below. The NSLookup function has been added into a module if that makes any difference

Code:
Function GetPingResult(Host)
 
   Dim objPing As Object
   Dim objStatus As Object
   Dim strResult As String
 
   Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
       ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")
 
   For Each objStatus In objPing
      Select Case objStatus.StatusCode
         Case 0: strResult = "Connected"
         Case 11001: strResult = "Buffer too small"
         Case 11002: strResult = "Destination net unreachable"
         Case 11003: strResult = "Destination host unreachable"
         Case 11004: strResult = "Destination protocol unreachable"
         Case 11005: strResult = "Destination port unreachable"
         Case 11006: strResult = "No resources"
         Case 11007: strResult = "Bad option"
         Case 11008: strResult = "Hardware error"
         Case 11009: strResult = "Packet too big"
         Case 11010: strResult = "Request timed out"
         Case 11011: strResult = "Bad request"
         Case 11012: strResult = "Bad route"
         Case 11013: strResult = "Time-To-Live (TTL) expired transit"
         Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
         Case 11015: strResult = "Parameter problem"
         Case 11016: strResult = "Source quench"
         Case 11017: strResult = "Option too big"
         Case 11018: strResult = "Bad destination"
         Case 11032: strResult = "Negotiating IPSEC"
         Case 11050: strResult = "General failure"
         Case Else: strResult = "Unknown host"
      End Select
      GetPingResult = strResult
   Next
 
   Set objPing = Nothing
 
End Function
 
Sub GetIPStatus()
 
  Dim Cell As Range
  Dim ipRng As Range
  Dim Result As String
  Dim Wks As Worksheet
 
 
Set Wks = Worksheets("Sheet1")
 
Set ipRng = Wks.Range("A2")
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))
 
  For Each Cell In ipRng
 
    If Cell.Value <> "" Then
        Result = GetPingResult(Cell)
        Cell.Offset(0, 1) = Result
    Else
        Cell.Offset(0, 1) = "No IP specified!"
    End If
   
  Next Cell
 
End Sub
 
Private Sub Clear_Contents_Click()
    Range("A2:B10000").Select
    Selection.ClearContents
    Range("A2").Select
End Sub
 
Private Sub DNSLookup_Click()
    Range("C2:C10000").Select
    Selection.ClearContents
    Range("A2").Select
   
    For x = 2 To Sheets("Sheet1").Range("A10000").End(xlUp).Row
        Dim IPAddy As String
        Dim LookupResult As String
        IPAddy = Sheets("Sheet1").Cells(x, 1).Value
        LookupResult = NSLookup(IPAddy, 0)
        Sheets("Sheet1").Cells(x, 3) = LookupResult
    Next x
End Sub
 
Private Sub Ping_Click()
    Range("B2:C10000").Select
    Selection.ClearContents
    Range("A2").Select
    GetIPStatus
End Sub
 

ndev2k

New Member
Joined
Dec 16, 2016
Messages
16
I'm still struggling to get this working. any help would be appreciated
 

Kyle123

Well-known Member
Joined
Jan 24, 2012
Messages
2,708

ADVERTISEMENT

The issue is caused by some code you haven’t posted. Check all the sheet modules, normal modules etc for code outside a sub or function or a rogue end function instead of exit function. Failing that paste ALL the code in your workbook here, exactly as it is in your workbook, if there are comments etc before or after subs, we need those too, do a Ctrl+A copy and paste
 

ndev2k

New Member
Joined
Dec 16, 2016
Messages
16
I have moved all the code into the Workbook and there is absolutely no additional code in any modules, sheets..

This is the entirety of the code

Code:
Function GetPingResult(Host)
 
   Dim objPing As Object
   Dim objStatus As Object
   Dim strResult As String
 
   Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
       ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")
 
   For Each objStatus In objPing
      Select Case objStatus.StatusCode
         Case 0: strResult = "Connected"
         Case 11001: strResult = "Buffer too small"
         Case 11002: strResult = "Destination net unreachable"
         Case 11003: strResult = "Destination host unreachable"
         Case 11004: strResult = "Destination protocol unreachable"
         Case 11005: strResult = "Destination port unreachable"
         Case 11006: strResult = "No resources"
         Case 11007: strResult = "Bad option"
         Case 11008: strResult = "Hardware error"
         Case 11009: strResult = "Packet too big"
         Case 11010: strResult = "Request timed out"
         Case 11011: strResult = "Bad request"
         Case 11012: strResult = "Bad route"
         Case 11013: strResult = "Time-To-Live (TTL) expired transit"
         Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
         Case 11015: strResult = "Parameter problem"
         Case 11016: strResult = "Source quench"
         Case 11017: strResult = "Option too big"
         Case 11018: strResult = "Bad destination"
         Case 11032: strResult = "Negotiating IPSEC"
         Case 11050: strResult = "General failure"
         Case Else: strResult = "Unknown host"
      End Select
      GetPingResult = strResult
   Next
 
   Set objPing = Nothing
 
End Function
 
Sub GetIPStatus()
 
  Dim Cell As Range
  Dim ipRng As Range
  Dim Result As String
  Dim Wks As Worksheet
 
 
Set Wks = Worksheets("Sheet1")
 
Set ipRng = Wks.Range("A2")
Set RngEnd = Wks.Cells(Rows.Count, ipRng.Column).End(xlUp)
Set ipRng = IIf(RngEnd.Row < ipRng.Row, ipRng, Wks.Range(ipRng, RngEnd))
 
  For Each Cell In ipRng
  
    If Cell.Value <> "" Then
        Result = GetPingResult(Cell)
        Cell.Offset(0, 1) = Result
    Else
        Cell.Offset(0, 1) = "No IP specified!"
    End If
    
  Next Cell
 
End Sub
 
Private Sub Clear_Contents_Click()
    Range("A2:B10000").Select
    Selection.ClearContents
    Range("A2").Select
End Sub
 
Private Sub DNSLookup_Click()
    Range("C2:C10000").Select
    Selection.ClearContents
    Range("A2").Select
    
    For x = 2 To Sheets("Sheet1").Range("A10000").End(xlUp).Row
        Dim IPAddy As String
        Dim LookupResult As String
        IPAddy = Sheets("Sheet1").Cells(x, 1).Value
        LookupResult = NSLookup(IPAddy, 0)
        Sheets("Sheet1").Cells(x, 3) = LookupResult
    Next x
End Sub
 
Private Sub Ping_Click()
    Range("B2:C10000").Select
    Selection.ClearContents
    Range("A2").Select
    GetIPStatus
End Sub
 
Public Function NSLookup(lookupVal As String, Optional addressOpt As Integer) As String
 
    Const ADDRESS_LOOKUP = 1
    Const NAME_LOOKUP = 2
    Const AUTO_DETECT = 0
   
    'Skip everything if the field is blank
    If lookupVal <> "" Then
        Dim oFSO As Object, oShell As Object, oTempFile As Object
        Dim sLine As String, sFilename As String
        Dim intFound As Integer
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        Set oShell = CreateObject("Wscript.Shell")
       
        'Handle the addresOpt operand
        'Regular Expressions are used to complete a substring match for an IP Address
        'If an IP Address is found, a DNS Name Lookup will be forced
        If addressOpt = AUTO_DETECT Then
            ipLookup = FindIP(lookupVal)
            If ipLookup = "" Then
                addressOpt = ADDRESS_LOOKUP
            Else
                addressOpt = NAME_LOOKUP
                lookupVal = ipLookup
            End If
        'Do a regular expression substring match for an IP Address
        ElseIf addressOpt = NAME_LOOKUP Then
            lookupVal = FindIP(lookupVal)
        End If
       
        'Run the nslookup command
        sFilename = oFSO.GetTempName
        oShell.Run "cmd /c nslookup " & lookupVal & " > " & sFilename, 0, True
        Set oTempFile = oFSO.OpenTextFile(sFilename, 1)
        Do While oTempFile.AtEndOfStream <> True
           sLine = oTempFile.Readline
            cmdStr = cmdStr & Trim(sLine) & vbCrLf
        Loop
        oTempFile.Close
        oFSO.DeleteFile (sFilename)
       
        'Process the result
        intFound = InStr(1, cmdStr, "Name:", vbTextCompare)
        If intFound = 0 Then
            NSLookup = ""
            Exit Function
        ElseIf intFound > 0 Then
            'TODO: Cleanup with RegEx
            If addressOpt = ADDRESS_LOOKUP Then
                loc1 = InStr(intFound, cmdStr, "Address:", vbTextCompare) + InStr(intFound, cmdStr, "Addresses:", vbTextCompare)
                loc2 = InStr(loc1, cmdStr, vbCrLf, vbTextCompare)
                nameStr = Trim(Mid(cmdStr, loc1 + 8, loc2 - loc1 - 8))
            ElseIf addressOpt = NAME_LOOKUP Then
                loc1 = InStr(intFound, cmdStr, "Name:", vbTextCompare)
                loc2 = InStr(loc1, cmdStr, vbCrLf, vbTextCompare)
                nameStr = Trim(Mid(cmdStr, loc1 + 5, loc2 - loc1 - 5))
            End If
        End If
        NSLookup = nameStr
    Else
        NSLookup = "N/A"
    End If
End Function
 
Public Function FindIP(strTest As String) As String
    Dim RegEx As Object
    Dim valid As Boolean
    Dim Matches As Object
    Dim i As Integer
    Set RegEx = CreateObject("VBScript.RegExp")
       
    RegEx.Pattern = "\b(?:\d{1,3}\.){3}\d{1,3}\b"
    valid = RegEx.test(strTest)
    If valid Then
        Set Matches = RegEx.Execute(strTest)
        FindIP = Matches(0)
    Else
        FindIP = ""
    End If
End Function
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
35,503
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

Please remind yourself of the forum rules on cross-posting and add the appropriate links.

Do you have an object/module called nslookup?
 

ndev2k

New Member
Joined
Dec 16, 2016
Messages
16
Right I've found the issue... There was some erroneous white space in the function..... Copy and paste fail.... Now I'm getting an error as it tries to open the temp file though saying filed not found
 

ndev2k

New Member
Joined
Dec 16, 2016
Messages
16
Please remind yourself of the forum rules on cross-posting and add the appropriate links.

Do you have an object/module called nslookup?

Sorry I was not aware of the cross posting guidelines... I posted this to stack overflow this morning in an attempt to get some help. Apologies
 

Watch MrExcel Video

Forum statistics

Threads
1,109,042
Messages
5,526,420
Members
409,701
Latest member
nitmani

This Week's Hot Topics

Top