I figured it out anyway Frank, I place the block in a selectionset and then
scan the set for a blockreference. Blockreference.insertionpoint returns the
insertion point of the specified block. I didn't try it originally because I
assumed it was wrong. I had it backwards. The origin property returns the the
insertion point of the original. i.e.- a wblock created at 0,0,0.
-Josh
p.s.- throw this code in a standard module, place a couple of circles or insert
a couple of tapped holes ect. on the screen and run the macro.
Private Function LayerExists(LayerName As String) As Boolean 'LayerName as
String is Caps Sensitive
Dim Layr As AcadLayer
For Each Layr In ThisDrawing.Layers
If Layr.Name = LayerName Then LayerExists = True
Next
End Function
Public Sub Ordinate()
Dim SS1 As AcadSelectionSet
Dim Ent As AcadEntity
Dim Layr As AcadLayer
Dim BlkRef As AcadBlockReference
Dim Circ As AcadCircle
Dim ActivLayr As AcadLayer
Dim DimLayr As AcadLayer
Dim Xdim As AcadDimOrdinate
Dim Ydim As AcadDimOrdinate
Dim DefXpt(0 To 2) As Double
Dim DefYpt(0 To 2) As Double
Dim oPoint As Variant
Dim UCSzero(0 To 2) As Double
UCSzero(0) = 0: UCSzero(1) = 0: UCSzero(2) = 0
Set ActivLayr = ThisDrawing.ActiveLayer 'change to dim layer and remember
original layer
If LayerExists("DIM") = True Then
For Each Layr In ThisDrawing.Layers
If Layr.Name = "DIM" Then
Set DimLayr = Layr
End If
Next Layr
ThisDrawing.ActiveLayer = DimLayr
Else
Set DimLayr = ThisDrawing.Layers.Add("DIM")
DimLayr.Color = 11
ThisDrawing.ActiveLayer = DimLayr
End If
Set SS1 = ThisDrawing.SelectionSets.Add("DimSet") 'select stuff to dim
SS1.SelectOnScreen
Dim PrevSnapSetting As Integer ' remember old snaps
Const Intersection As Integer = 32
PrevSnapSetting = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", Intersection 'snap to inersection
oPoint = ThisDrawing.Utility.GetPoint(, "Select Zero Point :") 'retrieve 0
point
ThisDrawing.SetVariable "OSMODE", PrevSnapSetting 'return snaps
For Each Ent In ThisDrawing.ModelSpace 'move everything
Ent.Move oPoint, UCSzero
Next
For Each Ent In SS1
If Ent.Layer = "0" Then
If TypeOf Ent Is AcadCircle Then
Set Circ = Ent
DefXpt(0) = -0.5: DefXpt(1) = Circ.center(1)
DefYpt(0) = Circ.center(0): DefYpt(1) = -0.5
Set Xdim = ThisDrawing.ModelSpace.AddDimOrdinate(Circ.center,
DefXpt, 0)
Set Ydim = ThisDrawing.ModelSpace.AddDimOrdinate(Circ.center,
DefYpt, 1)
ElseIf TypeOf Ent Is AcadBlockReference Then
Set BlkRef = Ent
DefXpt(0) = -0.5: DefXpt(1) = BlkRef.InsertionPoint(1)
DefYpt(0) = BlkRef.InsertionPoint(0): DefYpt(1) = -0.5
Set Xdim =
ThisDrawing.ModelSpace.AddDimOrdinate(BlkRef.InsertionPoint, DefXpt, 0)
Set Ydim =
ThisDrawing.ModelSpace.AddDimOrdinate(BlkRef.InsertionPoint, DefYpt, 1)
End If
End If
Next
For Each Ent In ThisDrawing.ModelSpace 'move everything back
Ent.Move UCSzero, oPoint
Next
SS1.Delete 'cleanup
ThisDrawing.ActiveLayer = ActivLayr
End Sub
