Message 1 of 3
Annotative Block VBA
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
This is a 2 part question
I've run accross a little problem when inserting a block reference with VBA. The original block is a dwg file stored in our library of blocks.
Problem #1
The following code is supposed to insert our Rev triangle after the code has finished running. It does not work consistently, if the program is run just after the drawing file has been opened, it will not insert the blocks, BUT if it is the second time running the code, it does work.
Private Sub InsertTriangles()
On Error Resume Next
Dim iPoint As Variant
Dim oBlock As AcadBlockReference
Dim sAtt As Variant
Dim varData As Variant
Dim dSpace As Double
Dim sSymbol As String
Dim CurSet As AcadSelectionSet
Dim SelCode(0) As Integer
Dim SelValue(0 To 0) As Variant
ThisDrawing.SelectionSets("NewSelSet").DELETE 'delete if exists
If Err 0 Then Err.Clear
Set CurSet = ThisDrawing.SelectionSets.Add("NewSelSet")
SelCode(0) = 0
SelValue(0) = "INSERT" 'only select block references
CurSet.Select acSelectionSetAll, , , SelCode, SelValue
For Each Ent In CurSet
If LCase(Ent.NAME) = "rev#" Then
sAtt = Ent.GetAttributes
If sAtt(0).TextString txtCurRev.Text Then
Ent.Erase
End If
End If
Next Ent
CurSet.DELETE
varData = ThisDrawing.GetVariable("measurement")
If varData = 1 Then
sScale = sScale * 25.4
End If
sSymbol = "G:\AUTOCAD CUSTOMIZATION\SYMBOLS\REV#.DWG"
frmRev.Hide
Do While GetAsyncKeyState(VK_ESCAPE) = 0
iPoint = ThisDrawing.Utility.GetPoint(, vbCr & "PICK INSERTION POINT (PRESS ENTER OR ESC TO EXIT)")
If Err = 0 Then
Set oBlock = ThisDrawing.ModelSpace.InsertBlock(iPoint, sSymbol, sScale, sScale, sScale, 0)
sAtt = oBlock.GetAttributes
sAtt(0).TextString = txtCurRev.Text
Else
Err = 0
Exit Do
End If
Loop
End Sub
Problem #2
The block it is inserting is an annotative block but when inserted using VBA the annotivity is turned off, is there a fix for this?
I've run accross a little problem when inserting a block reference with VBA. The original block is a dwg file stored in our library of blocks.
Problem #1
The following code is supposed to insert our Rev triangle after the code has finished running. It does not work consistently, if the program is run just after the drawing file has been opened, it will not insert the blocks, BUT if it is the second time running the code, it does work.
Private Sub InsertTriangles()
On Error Resume Next
Dim iPoint As Variant
Dim oBlock As AcadBlockReference
Dim sAtt As Variant
Dim varData As Variant
Dim dSpace As Double
Dim sSymbol As String
Dim CurSet As AcadSelectionSet
Dim SelCode(0) As Integer
Dim SelValue(0 To 0) As Variant
ThisDrawing.SelectionSets("NewSelSet").DELETE 'delete if exists
If Err 0 Then Err.Clear
Set CurSet = ThisDrawing.SelectionSets.Add("NewSelSet")
SelCode(0) = 0
SelValue(0) = "INSERT" 'only select block references
CurSet.Select acSelectionSetAll, , , SelCode, SelValue
For Each Ent In CurSet
If LCase(Ent.NAME) = "rev#" Then
sAtt = Ent.GetAttributes
If sAtt(0).TextString txtCurRev.Text Then
Ent.Erase
End If
End If
Next Ent
CurSet.DELETE
varData = ThisDrawing.GetVariable("measurement")
If varData = 1 Then
sScale = sScale * 25.4
End If
sSymbol = "G:\AUTOCAD CUSTOMIZATION\SYMBOLS\REV#.DWG"
frmRev.Hide
Do While GetAsyncKeyState(VK_ESCAPE) = 0
iPoint = ThisDrawing.Utility.GetPoint(, vbCr & "PICK INSERTION POINT (PRESS ENTER OR ESC TO EXIT)")
If Err = 0 Then
Set oBlock = ThisDrawing.ModelSpace.InsertBlock(iPoint, sSymbol, sScale, sScale, sScale, 0)
sAtt = oBlock.GetAttributes
sAtt(0).TextString = txtCurRev.Text
Else
Err = 0
Exit Do
End If
Loop
End Sub
Problem #2
The block it is inserting is an annotative block but when inserted using VBA the annotivity is turned off, is there a fix for this?