Guest
|
Posted:
Fri Sep 09, 2005 12:10 pm Post subject:
Trouble changing attribute-Values from within MSAccess |
|
|
Hello everyone,
I've found a pretty good function in the newsgroups, that allows me to
change a specific value of an attribute in a specific block in a
drawing. See code below. The function is working good from within
Autocad-VBA-Projects, but if you try to call this from within Access
using Automation (I replaced ThisDrawing with AcadDocument of course),
nothing happens. While debugging, I saw that although the ACadBlock was
found, the attributes did not.
Only an expert could help me with this trouble.
Thanks for your help.
P.S. I am using Access 2000 and Autocad 2005
Code:
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Function Att_Update(sBLName As String, sAttTag As String,
sNewAttVal As String) As Boolean
'+-- Change an Attributes' value given the block name and attribute tag
Dim oBlkRef As AcadBlockReference
Dim oSelSet As AcadSelectionSet
Dim oAttRef() As AcadAttributeReference
Dim iCodes(0 To 1) As Integer
Dim vCodeValues(0 To 1) As Variant
Dim iCntr As Integer
Dim ssName As String
ssName = CStr(timeGetTime)
Set oSelSet = ThisDrawing.SelectionSets.Add(ssName)
iCodes(0) = 0
vCodeValues(0) = "INSERT"
iCodes(1) = 2
vCodeValues(1) = sBLName
'set default return value
Att_Update = False
'get the blocks
oSelSet.Select Mode:=acSelectionSetAll, _
filtertype:=iCodes, _
filterdata:=vCodeValues
If sNewAttVal = "" Then sNewAttVal = " "
For Each oBlkRef In oSelSet
If oBlkRef.HasAttributes = True Then
oAttRef = oBlkRef.GetAttributes
For iCntr = LBound(oAttRef) To UBound(oAttRef)
If UCase(oAttRef(iCntr).TagString) = UCase(sAttTag) Then
oAttRef(iCntr).TextString = sNewAttVal
oAttRef(iCntr).Update
Exit For
End If
Next
Erase oAttRef
End If
Next
Exit_Here:
oSelSet.Delete
Erase oAttRef
If Not oBlkRef Is Nothing Then Set oBlkRef = Nothing
Exit Function
Error_Control:
Select Case Err.Number
Case -2147024809
'block doesn't exist
Resume Exit_Here
Case Else
MsgBox Err.Description, vbCritical
Err.Clear
Resume Exit_Here
End Select
End Function
|
|