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
 

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
Please remind yourself of the forum rules on cross-posting and add the appropriate links.

Do you have an object/module called nslookup?
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,565
Messages
6,114,337
Members
448,568
Latest member
Honeymonster123

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top