Insert a block with attributes read from database

Hi,
I have a program which develops many blocks from a datbase(mdb). This block needs to be inserted in a drawing and the attributes need to be read from a different databse (mdb). It shouldnt prompt the user for the values.

Can anyone help me please?

In anticipation,
Lara

 

Are you looking for someone to help you with this or someone to write it
for you?

If it's help you need, post the code you currently have.

If it's a program you require, you might consider advertising your
budget for this project in pn.classifieds.

 

Sub DrawingCreation()
Dim conn As New ADODB.Connection

Dim LstrFileName As String
Dim LrsFileNames As New ADODB.Recordset
Dim LrsDetails As New ADODB.Recordset

Dim EntityColor As ACAD_COLOR
Dim EntityType As String

Dim EntityLine As AcadLine
Dim EntityEllipse As AcadEllipse

‘define line variables
Dim LineStartPoint(0 To 2) As Double
Dim LineEndPoint(0 To 2) As Double

'define ellipse variables
Dim EllipseCenterPt(0 To 2) As Double
Dim EllipseAxisConstA As Double
Dim EllipseAxisConstB As Double
Dim EllipseMajorAxis(0 To 2) As Double
Dim EllipseRadiusRatio As Double
Dim DblStartAngle As Double
Dim DblEndAngle As Double

'to get blocks
Dim StrBlockName As String
Dim BlockRef As AcadBlockReference
Dim bLocks As AcadBlocks
Dim SymbolBlock As AcadBlock
Dim BlockInsertPoint(0 To 2) As Double
Dim AcadEntity() As Object
Dim SelectAll As AcadSelectionSet
Dim intN As Integer
Dim varCopyObj As Variant

'Connect to Database
conn.Open "provider=microsoft.jet.oledb.4.0; data source =C:\block_drawing\blk-dwg.mdb"

'Open Database
LrsFileNames.Open "Select distinct DWG_NAME from DATA order by DWG_NAME", conn, 3, 3

'Do till End of File
Do While LrsFileNames.EOF <> True

'for checking
LstrFileName = LrsFileNames.Fields("DWG_NAME").Value

LrsDetails.Open "SELECT * from DATA Where DWG_NAME= '" & LstrFileName & "'", conn, 3, 3
Do While LrsDetails.EOF <> True

EntityColor = CInt(LrsDetails.Fields("COLOUR"))
EntityType = LrsDetails.Fields("TYPE")

‘check if its line

If EntityType Like "*4 (Line*" Then
' Get line coordinates

LineStartPoint(0) = CDbl(LrsDetails.Fields("FirstPtX"))
LineStartPoint(1) = CDbl(LrsDetails.Fields("FirstPtY"))
LineEndPoint(0) = CDbl(LrsDetails.Fields("LINE_EndPtX"))
LineEndPoint(1) = CDbl(LrsDetails.Fields("LINE_EndPtY"))

'draw line using Line command
Set EntityLine = ThisDrawing.ModelSpace.AddLine(LineStartPoint, LineEndPoint)
EntityLine.color = EntityColor
EntityLine.Update

ElseIf EntityType Like "*Ellipse*" Then
'get ellipse details - center point
EllipseCenterPt(0) = CDbl(LrsDetails.Fields("FirstPtX"))
EllipseCenterPt(1) = CDbl(LrsDetails.Fields("FirstPtY"))

'get x and y axis of ellipse
EllipseAxisConstA = CDbl(LrsDetails.Fields("constantA"))
EllipseAxisConstB = CDbl(LrsDetails.Fields("constantBâ€))
'check which is the major axis
If EllipseAxisConstB > EllipseAxisConstA Then
'Y is the major axis
EllipseMajorAxis(0) = 0
EllipseMajorAxis(1) = EllipseAxisConstB
EllipseRadiusRatio = EllipseAxisConstA / EllipseAxisConstB
Else
'X is the major axis
EllipseMajorAxis(0) = EllipseAxisConstA
EllipseMajorAxis(1) = 0
EllipseRadiusRatio = EllipseAxisConstB / EllipseAxisConstA
End If


Set EntityEllipse = ThisDrawing.ModelSpace.AddEllipse(EllipseCenterPt, EllipseMajorAxis, EllipseRadiusRatio)
EntityEllipse.color = colr

'Check if its an ellipse or elliptical arc
If LrsDetails.Fields("EndAng") <> 360 Then
' it is an elliptical arc
DblStartAngle = CDbl(LrsDetails.Fields("StartAng"))
DblEndAngle = CDbl(LrsDetails.Fields("EndAng"))

If (DblStartAngle + DblEndAngle) > 360 Then
DblEndAngle = (DblStartAngle + DblEndAngle) - 360
Else
DblEndAngle = (DblStartAngle + DblEndAngle)
End If

EntityEllipse.StartAngle = DblStartAngle * (3.14 / 180)
EntityEllipse.EndAngle = DblEndAngle * (3.14 / 180)
EntityEllipse.Update

End If

ElseIf EntityType Like "*Drawing*" Then
'get symbol insertion point and symbol name
StrBlockName = LrsDetails.Fields("DWG_BLOCK_NAME")
BlockInsertPoint(0) = LrsDetails.Fields("DWG_CENTRE_X")
BlockInsertPoint(1) = LrsDetails.Fields("DWG_CENTRE_Y")
BlockInsertPoint(2) = 0
End If

LrsDetails.MoveNext
Loop

ZoomExtents
Set SelectAll = ThisDrawing.SelectionSets.Add("selectobjects")
SelectAll.Select (acSelectionSetAll)
SelectAll.Highlight (True)

ReDim AcadEntity(0 To SelectAll.Count - 1)
For intN = 0 To SelectAll.Count - 1
Set AcadEntity(intN) = SelectAll.Item(intN)
Next intN

Set SymbolBlock = ThisDrawing.bLocks.Add(BlockInsertPoint, StrBlockName)
varCopyObj = ThisDrawing.CopyObjects(AcadEntity, SymbolBlock)

Set blkRef = ThisDrawing.ModelSpace.InsertBlock(BlockInsertPoint, StrBlockName, 1, 1, 1, 0)
Set blkRef = Nothing
Set SymbolBlock = Nothing

ThisDrawing.Regen (acActiveViewport)

ThisDrawing.SendCommand ("_erase all ")

If Not SelectAll Is Nothing Then
SelectAll.Delete
End If

LrsFileNames.MoveNext
LrsDetails.Close

Loop

LrsFileNames.Close

End Sub

 

Lara,

What is this code supposed to do and what does it actually do? IOW, what's
the problem?

 

my code is perfect... i added the foll. line to add the attribute...

set dwgAtt1 = AcBlk.AddAttribute(0.2, acAttributeModeConstant, "prompt", attInsPnt, "NAME", strName)

where strName is the value which reads the data from the table.

i want this strName to read dynamic value..

example, if i place a block, that block should take value1 from database, or value2 or value3 dynamically... and not ask user for input.

 

Congratulations.

 

Hi Frank, thanks for acknowledging my self-glorification effort. I need a help. I have given "send command" for mirroring all objects and erasing the block... (I am not sure if my block deletes the original entities after creating the block). Do you have better suggestions for this?