"member" equivalent

Discussion in 'AutoCAD' started by sdanis, Mar 30, 2005.

  1. sdanis

    sdanis Guest

    Is there an equivalent function in VBA for the Lisp function "MEMBER"?
     
    sdanis, Mar 30, 2005
    #1
    1. Advertisements

  2. Not VBA but a scripting Dictionary has an exists method and
    a remove method. Use in VBA by referencing the Microsoft
    Scripting Runtime

    Or manually check in an array or Collection.
     
    Paul Richardson, Mar 30, 2005
    #2
    1. Advertisements

  3. sdanis

    sdanis Guest

    Hey Paul, how's the leg?
    I'm not familiar with the MS Scripting Runtime.
    What I want to do is this.
    I have a selection set of blocks in the dwg.
    I simple want to compare them to check for duplicate specific attribute "names".
     
    sdanis, Mar 30, 2005
    #3
  4. Hey Scotty,

    Leg is feeling much better, Thanks.
    On my way back!

    You will need to iterate your
    selection set and remove
    objects as needed.

    I wrote some test code. Did a few
    checks seem ok.

    Paul

    '<code>
    Sub ssAtttesta()
    Dim ss As AcadSelectionSet
    Dim genObj As acadObject
    Dim oBlock As AcadBlockReference
    Dim iJc As Integer: iJc = 0
    Dim iKc As Integer: iKc = 0
    Dim iLc As Integer: iKc = 0
    Dim oAttributes
    Dim removeObjs() As AcadEntity

    Set ss = ThisDrawing.SelectionSets.Add("SS")
    ss.SelectOnScreen

    For iJc = 0 To ss.Count - 1

    If TypeOf ss(iJc) Is AcadBlockReference Then

    Set oBlock = ss(iJc)

    If oBlock.HasAttributes Then
    oAttributes = oBlock.GetAttributes

    For iKc = LBound(oAttributes) To UBound(oAttributes)

    Select Case oAttributes(iKc).TagString

    Case "ENTERNAME"

    Select Case oAttributes(iKc).TextString

    Case "Fred"
    'if found add to removeObjs
    ReDim Preserve removeObjs(iLc)
    Set removeObjs(iLc) = ss(iJc)
    iLc = iLc + 1

    End Select

    End Select

    Next iKc

    End If

    End If

    Next iJc

    If Not UBound(removeObjs) < 0 Then
    ss.RemoveItems removeObjs
    ss.Update
    'erase for testing
    ss.Erase
    End If

    ThisDrawing.SelectionSets("SS").Delete

    End Sub
    '<code/>
     
    Paul Richardson, Mar 30, 2005
    #4
  5. sdanis

    sdanis Guest

    tHANKS, i NEEDED THAT :)
     
    sdanis, Mar 30, 2005
    #5
  6. your welcome Anytime.
     
    Paul Richardson, Mar 30, 2005
    #6
  7. Dim iLc As Integer: iKc = 0
    'don't need to set one of those habbits, but should be "iLc = 0"
    'don't need

    Also, You might want to use the upper bounds
    of removeObjs to calc the incrementor. Less
    chance of error.

    Flunk Dan yet?
     
    Paul Richardson, Mar 30, 2005
    #7
  8. sdanis

    sdanis Guest

    Haven't flunked him YET but I keep an eye on him to make sure he's not cheating!! ;-)
     
    sdanis, Mar 31, 2005
    #8
  9. sdanis

    bcoward Guest

    Scott,

    Here is a class that compliments Paul's recommendation. Check out the Exists Function as you Member equivilent.


    ' Class : CDictionary
    ' Description : This class demonstrates using the Dictionary object
    '
    ' To use the Dictionary object, you mst create a Reference
    ' to the Windows Scripting Runtime file (SCRRUN.DLL)
    '
    ' Comparison modes
    Public Enum EnumCompareModes
    dicBinary = 1
    dicText = 2
    End Enum

    ' Private variables to manage property values
    Private m_objDictionary As Scripting.Dictionary
    Private m_eCompareMode As EnumCompareModes
    Private m_lngCount As Long

    Private Sub Class_Initialize()
    ' Set initial values to defaults which may be overridden
    ' with property settings
    '
    On Error GoTo PROC_ERR

    ' Default to text compare
    m_eCompareMode = dicBinary

    ' Create the object
    Set m_objDictionary = New Dictionary

    PROC_EXIT:
    Exit Sub

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "Class_Initialize"
    Resume PROC_EXIT

    End Sub

    Public Property Get CompareMode() As EnumCompareModes
    ' Returns: The current setting of the CompareMode property
    '
    CompareMode = m_eCompareMode

    End Property

    Public Property Let CompareMode(eValue As EnumCompareModes)
    ' eValue: Comparison mode as defined by the EnumCompareModes
    ' enumerated type.
    '
    m_eCompareMode = eValue

    End Property

    Public Property Get Count() As Long
    ' Returns: The number of objects in the dictionary
    '
    On Error GoTo PROC_ERR

    ' Update the count
    m_lngCount = m_objDictionary.Count

    Count = m_lngCount

    PROC_EXIT:
    Exit Sub

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "Count"
    Resume PROC_EXIT

    End Property

    Public Property Get Dictionary() As Scripting.Dictionary
    ' Returns: A handle the current dictionary object
    '
    On Error GoTo PROC_ERR

    Set Dictionary = m_objDictionary

    PROC_EXIT:
    Exit Sub

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "Dictionary"
    Resume PROC_EXIT

    End Property

    Public Property Get Item(varKey As Variant) As Variant
    ' Returns: The item in the dictionary with the specified key
    ' Parameters: varKey - The key of the item
    '
    On Error GoTo PROC_ERR

    If IsObject(m_objDictionary.Item(varKey)) Then
    Set Item = m_objDictionary.Item(varKey)
    Else
    Item = m_objDictionary.Item(varKey)
    End If

    PROC_EXIT:
    Exit Sub

    PROC_ERR:
    MsgBox "Item: " & Err.Number & ". " & Err.Description, , _
    "Item"
    Resume PROC_EXIT

    End Property

    Public Property Get Items() As Variant
    ' Comments : Returns the Dictionary items as an array
    ' Parameters: None
    ' Returns : Array of keys
    '
    On Error GoTo PROC_ERR

    Items = m_objDictionary.Items

    PROC_EXIT:
    Exit Property

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "Items"
    Resume PROC_EXIT

    End Property

    Public Property Get Key(varKey As Variant) As Variant
    ' Returns: The key in the dictionary with the specified key.
    ' Parameters: varKey - The key of the item
    '
    On Error GoTo PROC_ERR
    If IsObject(m_objDictionary.Item(varKey).Key) Then
    Set Key = m_objDictionary(varKey).Key
    Else
    Key = m_objDictionary(varKey).Key
    End If

    PROC_EXIT:
    Exit Property

    PROC_ERR:
    MsgBox "Item: " & Err.Number & ". " & Err.Description, , _
    "Key"
    Resume PROC_EXIT

    End Property

    Public Property Get Keys() As Variant
    ' Comments : Returns the Dictionary keys as an array
    ' Parameters: None
    ' Returns : Array of keys
    '
    On Error GoTo PROC_ERR

    Keys = m_objDictionary.Keys

    PROC_EXIT:
    Exit Property

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "Keys"
    Resume PROC_EXIT

    End Property

    Public Sub Add( _
    varKey As Variant, _
    varItem As Variant)
    ' Comments : Adds the specified item to the Dictionary
    ' Parameters: varKey - Unique key for the item. Keys are required
    ' for all items in the Dictionary.
    ' varItem - item value
    ' Returns : Nothing
    '
    On Error GoTo PROC_ERR

    m_objDictionary.Add varKey, varItem

    PROC_EXIT:
    Exit Sub

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "Add"
    Resume PROC_EXIT

    End Sub

    Public Function Exists(varKey As Variant) As Boolean
    ' Comments : Determines if the specified item exists in the dictionary
    ' Comparison is done according to the setting of the
    ' CompareMode property.
    ' Parameters: varKey - key of the item to find
    ' Returns : True if the item exists, False otherwise.
    '
    Dim lngCounter As Long
    Dim aTmpKeys() As Variant

    On Error GoTo PROC_ERR

    Select Case m_eCompareMode
    Case dicBinary
    ' Binary mode appears to work correctly, so we'll just set
    ' the dictionary object's property and let the DLL to the work
    m_objDictionary.CompareMode = vbBinaryCompare
    Exists = m_objDictionary.Exists(varKey)

    Case dicText
    ' Text mode (case insenstive) doesn't work because the vbTextCompare
    ' constant documented in the VB 6 documentation doesn't compile.
    ' We work around this by doing our own (slow) comparison.

    ' First copy the keys to an array
    aTmpKeys = m_objDictionary.Keys

    ' Loop through to see if it exists
    For lngCounter = 0 To UBound(aTmpKeys)
    If LCase(varKey) = LCase(aTmpKeys(lngCounter)) Then
    Exists = True
    ' As soon as its found, bail out of the loop
    Exit For
    Else
    Exists = False
    End If
    Next lngCounter

    End Select

    PROC_EXIT:
    Exit Function

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "Exists"
    Resume PROC_EXIT

    End Function

    Public Sub Remove(varKey As Variant)
    ' Comments : Removes the specified item from the Dictionary
    ' Parameters: varKey - key of the item to remove
    ' Returns : Nothing
    '
    On Error GoTo PROC_ERR

    m_objDictionary.Remove varKey

    PROC_EXIT:
    Exit Sub

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "Remove"
    Resume PROC_EXIT

    End Sub

    Public Sub RemoveAll()
    ' Comments : Removes all items from the Dictionary
    ' Parameters: None
    ' Returns : Nothing
    '
    On Error GoTo PROC_ERR

    m_objDictionary.RemoveAll

    PROC_EXIT:
    Exit Sub

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "RemoveAll"
    Resume PROC_EXIT

    End Sub

    Public Sub SortDictionary(fKey As Boolean)
    ' Comments : Sorts the Dictionary items
    ' Parameters: fKey - True to sort by Key, False to sort by Item
    ' Returns : Nothing
    '
    Dim lngCounter As Long
    Dim avarColumn1() As Variant
    Dim avarColumn2() As Variant
    Dim avarTmp() As Variant

    On Error GoTo PROC_ERR

    If fKey Then
    ' Sort by key, so get the Keys into the first dim of the array
    avarColumn1 = m_objDictionary.Keys
    avarColumn2 = m_objDictionary.Items
    Else
    ' Sort by item, so get the Items into the first dim of the array
    avarColumn1 = m_objDictionary.Items
    avarColumn2 = m_objDictionary.Keys
    End If

    ' Grow the tmp array
    ReDim avarTmp(0 To UBound(avarColumn1), 1) As Variant

    ' Create a single array
    For lngCounter = 0 To UBound(avarColumn1)
    avarTmp(lngCounter, 0) = avarColumn1(lngCounter)
    avarTmp(lngCounter, 1) = avarColumn2(lngCounter)
    Next lngCounter

    ' Sort the array
    DoSort avarTmp

    ' Clear all keys/items from the dictionary
    m_objDictionary.RemoveAll

    ' Get the local array back into the dictionary
    For lngCounter = 0 To UBound(avarTmp)
    If fKey Then
    m_objDictionary.Add avarTmp(lngCounter, 0), avarTmp(lngCounter, 1)
    Else
    m_objDictionary.Add avarTmp(lngCounter, 1), avarTmp(lngCounter, 0)
    End If
    Next lngCounter

    PROC_EXIT:
    Exit Sub

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "SortDictionary"
    Resume PROC_EXIT

    End Sub

    Private Sub DoSort(avarIn() As Variant)
    ' Comments : Sorts the passed variant array
    ' Parameters: avarIn() - array of variants
    ' Returns : Nothing
    '
    Dim intLowBounds As Integer
    Dim intHighBounds As Integer
    Dim intX As Integer
    Dim intY As Integer
    Dim varTmp As Variant
    Dim varTmp2 As Variant

    On Error GoTo PROC_ERR

    ' Get the bounds of the array
    intLowBounds = LBound(avarIn)
    intHighBounds = UBound(avarIn)

    ' For each element in the array
    For intX = intLowBounds To intHighBounds - 1

    ' for each element in the array
    For intY = intX + 1 To intHighBounds

    ' If a value lower in the array is greater than a values higher in the
    ' array, swap them
    If avarIn(intX, 0) > avarIn(intY, 0) Then
    varTmp = avarIn(intX, 0)
    varTmp2 = avarIn(intX, 1)
    avarIn(intX, 0) = avarIn(intY, 0)
    avarIn(intX, 1) = avarIn(intY, 1)
    avarIn(intY, 0) = varTmp
    avarIn(intY, 1) = varTmp2
    End If

    Next intY

    Next intX

    PROC_EXIT:
    Exit Sub

    PROC_ERR:
    MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
    "DoSort"
    Resume PROC_EXIT

    End Sub


    Best of luck,

    Bob Coward
    CADS, Inc

    800-366-0946
     
    bcoward, Apr 1, 2005
    #9
  10. Nice, Thanks.

    Bob, Do you have a sample implementing
    the copyObjects method they way you
    described below in "Making whole
    drawing as a block". It's tweeking my
    last brain cell. tks..
     
    Paul Richardson, Apr 1, 2005
    #10
  11. sdanis

    bcoward Guest

    Paul,

    I was just getting ready to wrap up for the night because I have to be in the field by 5:30am....rain and all

    What I have been working on is that Custom Cursor thingy you asked about whereby the crosshairs reflect a scale relative to the drawings scale factor.

    Tomorrow I'll put the copyobj stuff together, test and send it off. I don't expect to be in till late evening but I've mounted my laptop in my work van so I can jot code conveniently through the day.

    On another note, I'm planning a trip to the Rockland, Maine project. Send me your brother's contact information, I'd like to start some dialog with him and possibly introduce to my team for future use....I'm presently carcassing the built-ins during my spare time and days off.

    Tomorrow...til then

    Bob Coward
    CADS, Inc
     
    bcoward, Apr 1, 2005
    #11
  12. sdanis

    sdanis Guest

    Hey Guys, thanks for the input. I really appreciate it.
    Bob you old dog, how's it going?
    Coming to Maine Huh.,
    Let me know when you're coming through Portland and we'll hook up.

    Scott
     
    sdanis, Apr 1, 2005
    #12
    1. Advertisements

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments (here). After that, you can post your question and our members will help you out.