lower left origin
lower left origin
(OP)
I'm looking for a simple code that will locate the origin of a window selected object at the lower left so that I can quickly diminsion that selection using the qdim ordinate method. I am wasting too much time creating this origin manually and would prefer to include it in the code for the button I've created for qdim (ordinate). Any suggestions?





RE: lower left origin
BU
RE: lower left origin
RE: lower left origin
RE: lower left origin
My objective is to minimize the steps of dimensioning by assigning this code to a button and then just window select each solviewed part on a drawing and thereby increasing the speed of our draftsmen.
I have already assigned code to accomplish everything except finding the lower left origin automatically. and it's this step I wish to make transparent as well.
RE: lower left origin
I think you will find this site useful, specifically corner.zip!
http://www.cadresource.com/library/lispbc.html
It is a lisp routine that gets the intersection of two lines that do not meet. It is very useful for dimensioning to outside corners of sheet metal bends or anything else with rounded corners.
RE: lower left origin
I have written a VBA code for your problem as follow:
Option Explicit
Sub SetOrigin()
Dim SOss As AcadSelectionSet
Dim SOobj As AcadEntity
Dim SOXMin As Double
Dim SOYMin As Double
Dim Minpt As Variant, Maxpt As Variant
Dim SOorig(0 To 2) As Double
Dim xAxis(0 To 2) As Double
Dim yAxis(0 To 2) As Double
Dim newUCS As AcadUCS
Randomize Timer
Set SOss = ThisDrawing.SelectionSets.Add(Rnd(Timer))
SOss.SelectOnScreen
ThisDrawing.SendCommand "UCS W "
SOss.Item(0).GetBoundingBox Minpt, Maxpt
SOXMin = Minpt(0)
SOYMin = Minpt(1)
For Each SOobj In SOss
SOobj.GetBoundingBox Minpt, Maxpt
If SOXMin > Minpt(0) Then
SOXMin = Minpt(0)
End If
If SOYMin > Minpt(1) Then
SOYMin = Minpt(1)
End If
Next SOobj
SOorig(0) = SOXMin
SOorig(1) = SOYMin
SOorig(2) = Minpt(2)
xAxis(0) = SOXMin + 1
xAxis(1) = SOYMin
xAxis(2) = Minpt(2)
yAxis(0) = SOXMin
yAxis(1) = SOYMin + 1
yAxis(2) = Minpt(2)
Set newUCS = ThisDrawing. _
UserCoordinateSystems.Add _
(SOorig, xAxis, yAxis, "0")
ThisDrawing.ActiveUCS = newUCS
End Sub
You can copy and paste the code into a VBA module an just run the SetOrigin subroutine. The routine requests you to select some objects and it sets the UCS on the lower left corner of selected objects.
The subroutine can be run using a toolbutton.
:)
Farzad