"member" equivalent

Is there an equivalent function in VBA for the Lisp function "MEMBER"?

 

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.

 

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".

 

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/>

 

tHANKS, i NEEDED THAT

 

your welcome Anytime.

 

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?

 

Haven't flunked him YET but I keep an eye on him to make sure he's not cheating!! ;-)

 

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

 

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,

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

 

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