- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
;(VBA AutoCad)Ordinate Dimension Check Origin,[ODCO]
(defun C:ODCO()
(command "-vbarun" "TBR23OrdinateDimensionCheckOrigin")
)
;(VBA AutoCad)Ordinate Dimension Copy,[ODC]
(defun C:ODC()
(command "-vbarun" "TBR22OrdinateDimensionCopy")
)
;(VBA AutoCad)Ordinate Dimension Move,[ODM]
(defun C:ODM()
(command "-vbarun" "TBR21OrdinateDimensionMove")
)
;(VBA AutoCad)Ordinate Dimension UCS,[ODUCS]
(defun C:ODUCS()
(command "-vbarun" "TBR20OridinateDimensionUCS")
)
;(VBA AutoCad)Ordinate Dimension Straighten Manual,[ODSM]
(defun C:ODSM()
(command "-vbarun" "TBR19OrdinateDimensionStraightenManual")
)
;(VBA AutoCad)Ordinate Dimension Straighten,[ODS]
(defun C:ODS()
(command "-vbarun" "TBR18OrdinateDimensionStraighten")
)
;Ordinate Dimension Arrange,[ODA]
(defun C:ODA()
(command "-vbarun" "TBR17OrdinateDimensionArrange")
)
;Set Dimension Linear Scale,[SDLS]
(defun C:SDLS()
(command "-vbarun" "TBR16SetDimensionLinearScale")
)
;Rotate Finishing Sysbol,[ROFS]
(defun C:ROFS()
(command "-vbarun" "TBR15RotateFinishingSysbol")
)
;Change Entity in block to byLayer, [C2BL]
(defun C:C2BL()
(command "-vbarun" "TBR14Change2ByLayer")
)
;Change Entity in block to byBlock, [C2BB]
(defun C:C2BB()
(command "-vbarun" "TBR13Change2ByBlock")
)
;Creat Multi Centerline, shortcut key [MCL]
(defun C:MCL()
(command "-vbarun" "TBR12CreatMultiCenterline")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function Func77CircleABisConcentic(CircleA As AcadCircle, CircleB As AcadCircle) As Integer
Dim CenterA As Variant
Dim CenterB As Variant
Dim XA As Double
Dim YA As Double
Dim XB As Double
Dim YB As Double
CenterA = CircleA.Center
CenterB = CircleB.Center
XA = Round(CenterA(0), 2)
YA = Round(CenterA(1), 2)
XB = Round(CenterB(0), 2)
YB = Round(CenterB(1), 2)
If XA = XB And YA = YB Then
Func77CircleABisConcentic = 1
Else
Func77CircleABisConcentic = 0
End If
End Function
Function Func78CircleCenterlineKKS(Object As AcadCircle)
Dim CircleCenter As Variant
Dim point1 As Variant
Dim point2 As Variant
Dim point3 As Variant
Dim point4 As Variant
Dim radius As Double
Dim Pi As Double
Pi = 4 * Atn(1)
CircleCenter = Object.Center
radius = Object.radius
radius = radius + 3
point1 = Thisdrawing.Utility.PolarPoint(CircleCenter, Pi, radius)
point2 = Thisdrawing.Utility.PolarPoint(CircleCenter, 0, radius)
point3 = Thisdrawing.Utility.PolarPoint(CircleCenter, Pi / 2, radius)
point4 = Thisdrawing.Utility.PolarPoint(CircleCenter, -Pi / 2, radius)
Dim Centerline1 As AcadLine
Dim Centerline2 As AcadLine
Set Centerline1 = Thisdrawing.ModelSpace.AddLine(point1, point2)
Set Centerline2 = Thisdrawing.ModelSpace.AddLine(point3, point4)
Centerline1.layer = CenterLayerName
Centerline2.layer = CenterLayerName
End Function
Function Func79PointAisEndPointOfLineB(PointA As Variant, LineB As AcadLine) As Boolean
Dim StartPoint As Variant
Dim EndPoint As Variant
StartPoint = LineB.StartPoint
EndPoint = LineB.EndPoint
Dim PointAx, PointAy As Double
Dim StartPointx, StartPointy As Double
Dim EndPointx, EndPointy As Double
PointAx = Round(PointA(0), 3)
PointAy = Round(PointA(1), 3)
StartPointx = Round(StartPoint(0), 3)
StartPointy = Round(StartPoint(1), 3)
EndPointx = Round(EndPoint(0), 3)
EndPointy = Round(EndPoint(1), 3)
If PointAx = StartPointx And PointAy = StartPointy Then Func79PointAisEndPointOfLineB = True
If PointAx = EndPointx And PointAy = EndPointy Then Func79PointAisEndPointOfLineB = True
End Function
Function FuncCadHome01MaxMinXYFrom2Point(PointA As Variant, PointB As Variant) As Variant
'Function Define MinX,MaxX,MinY,MaxY from MinPoint,MaxPoint
Dim XYArr(0 To 3) As Variant
Dim MinX As Double
Dim MaxX As Double
Dim MinY As Double
Dim MaxY As Double
Dim TmpDouble As Double
MinX = PointA(0)
MinY = PointA(1)
MaxX = PointB(0)
MaxY = PointB(1)
If MaxX < MinX Then
TmpDouble = MaxX
MaxX = MinX
MinX = TmpDouble
End If
If MaxY < MinY Then
TmpDouble = MaxY
MaxY = MinY
MinY = TmpDouble
End If
XYArr(0) = MinX
XYArr(1) = MaxX
XYArr(2) = MinY
XYArr(3) = MaxY
FuncCadHome01MaxMinXYFrom2Point = XYArr
End Function
Function FuncCadHome03OrdinateDimDirection(OridinateDimObj As AcadDimOrdinate, MinMaxArr As Variant) As String
'Function xac nhan vi tri cua Ordinate Dim so voi MinPoint va MaxPoint
Dim DimDirection As String
Dim MinX As Double
Dim MaxX As Double
Dim MinY As Double
Dim MaxY As Double
MinX = MinMaxArr(0)
MaxX = MinMaxArr(1)
MinY = MinMaxArr(2)
MaxY = MinMaxArr(3)
Dim TextPoint As Variant
Dim TextPointX As Double
Dim TextPointY As Double
TextPoint = OridinateDimObj.TextPosition
TextPointX = TextPoint(0)
TextPointY = TextPoint(1)
Dim DeltaMinX As Double
Dim DeltaMaxX As Double
Dim DeltaMinY As Double
Dim DeltaMaxY As Double
DeltaMinX = TextPointX - MinX
DeltaMaxX = TextPointX - MaxX
DeltaMinY = TextPointY - MinY
DeltaMaxY = TextPointY - MaxY
'Define Direction Up
If MinX > TextPointX And MinY <= TextPointY And TextPointY <= MaxY Then
DimDirection = "LEFT"
End If
If MaxX < TextPointX And MinY <= TextPointY And TextPointY <= MaxY Then
DimDirection = "RIGHT"
End If
If MinX <= TextPointX And TextPointX <= MaxX And MinY <= TextPointY And TextPointY <= MaxY Then
DimDirection = "IN"
End If
If DeltaMaxY >= 0 Then
Select Case TextPointX
Case Is < MinX
If Abs(DeltaMaxY) >= Abs(DeltaMinX) Then
DimDirection = "UP"
Else
DimDirection = "LEFT"
End If
Case Is > MaxX
If Abs(DeltaMaxY) >= Abs(DeltaMaxX) Then
DimDirection = "UP"
Else
DimDirection = "RIGHT"
End If
Case Else
DimDirection = "UP"
End Select
End If
If DeltaMinY <= 0 Then
Select Case TextPointX
Case Is < MinX
If Abs(DeltaMinY) >= Abs(DeltaMinX) Then
DimDirection = "DOWN"
Else
DimDirection = "LEFT"
End If
Case Is > MaxX
If Abs(DeltaMinY) >= Abs(DeltaMaxX) Then
DimDirection = "DOWN"
Else
DimDirection = "RIGHT"
End If
Case Else
DimDirection = "DOWN"
End Select
End If
FuncCadHome03OrdinateDimDirection = DimDirection
End Function
Function FuncCadHome04DefineDeltaDistanceFromDirection(DimDirection As String) As Variant
Dim Delta(0 To 1) As Integer
Dim DeltaX As Integer
Dim DeltaY As Integer
Select Case DimDirection
Case "IN"
DeltaX = 0
DeltaY = 0
Case "UP"
DeltaX = 0
DeltaY = 1
Case "DOWN"
DeltaX = 0
DeltaY = -1
Case "LEFT"
DeltaX = -1
DeltaY = 0
Case "RIGHT"
DeltaX = 1
DeltaY = 0
End Select
Delta(0) = DeltaX
Delta(1) = DeltaY
FuncCadHome04DefineDeltaDistanceFromDirection = Delta
End Function
Sub FuncCadHome05SetUCSFromPoint(origin As Variant)
Dim Pi As Double: Pi = 4 * Atn(1)
Dim ucsObj As AcadUCS
Dim xAxisPnt As Variant
Dim yAxisPnt As Variant
xAxisPnt = Thisdrawing.Utility.PolarPoint(origin, 0, 10)
yAxisPnt = Thisdrawing.Utility.PolarPoint(origin, Pi / 2 + LineAngle, 10)
' Add the UCS to the UserCoordinatesSystems collection
Set ucsObj = Thisdrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "New_UCS")
' Display the UCS icon
Thisdrawing.ActiveViewport.UCSIconAtOrigin = True
Thisdrawing.ActiveViewport.UCSIconOn = True
' Make the new UCS the active UCS
Thisdrawing.ActiveUCS = ucsObj
End Sub
Function FuncCadHome06MoveOrdinateDimension(objSelect As AcadDimOrdinate, PointA As Variant, MinPoint As Variant, MaxPoint As Variant, OldDelete As Boolean)
'Define MinX,MaxX,MinY,MaxY from MinPoint,MaxPoint
Dim MinXMaxXMinYMaxY As Variant
MinXMaxXMinYMaxY = FuncCadHome01MaxMinXYFrom2Point(MinPoint, MaxPoint)
'Define Dim Direction From 2Point
Dim DimDirection As String
DimDirection = FuncCadHome03OrdinateDimDirection(objSelect, MinXMaxXMinYMaxY)
'Define NewTexPositon
Dim OldTextPosition As Variant
Dim OldTextPositionX As Double
Dim OldTextPositionY As Double
Dim NewTextPosition(0 To 2) As Double
OldTextPosition = objSelect.TextPosition
OldTextPositionX = OldTextPosition(0)
OldTextPositionY = OldTextPosition(1)
Select Case DimDirection
Case "LEFT", "RIGHT"
NewTextPosition(0) = OldTextPositionX
NewTextPosition(1) = PointA(1)
Case "UP", "DOWN"
NewTextPosition(0) = PointA(0)
NewTextPosition(1) = OldTextPositionY
Case Else
MsgBox "In Limited"
Exit Function
End Select
'Creat New Ordinata Dimension
'Set DimOrdinateObject = Object.AddDimOrdinate(DefinitionPoint, _ LeaderEndPoint, UseXAxis)
Dim NewOD As AcadDimOrdinate
Dim DefinitionPoint As Variant
Dim LeaderEndPoint As Variant
Dim UseXAxis As Boolean
DefinitionPoint = Thisdrawing.Utility.TranslateCoordinates(PointA, acWorld, acUCS, 0)
LeaderEndPoint = Thisdrawing.Utility.TranslateCoordinates(OldTextPosition, acWorld, acUCS, 0)
Select Case DimDirection
Case "LEFT", "RIGHT"
UseXAxis = False
Case "UP", "DOWN"
UseXAxis = True
Case Else
MsgBox "In Limited"
Exit Function
End Select
Set NewOD = Thisdrawing.ModelSpace.AddDimOrdinate(DefinitionPoint, LeaderEndPoint, UseXAxis)
'Move Dim Text
Dim NewODTextPosition As Variant
Dim Point000(0 To 2) As Double
NewODTextPosition = Thisdrawing.Utility.TranslateCoordinates(NewTextPosition, acWorld, acUCS, 0)
NewOD.TextPosition = NewODTextPosition
NewOD.VerticalTextPosition = acVertCentered
objSelect.Update
NewOD.Move Point000, MinPoint
'Set layer for New OD
NewOD.layer = DimLayerName
Call Func43SetBylayer(NewOD)
'Delete Old OD
If OldDelete = True Then objSelect.Delete
End Function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub TBR12CreatMultiCenterline()
'Creat Multi Centerline, shortcut key [MCL]
Thisdrawing.Utility.Prompt (vbCrLf & "Creat Multi Centerline")
'Select Circle
Thisdrawing.Utility.Prompt (vbCrLf & "Select Circles to creat centerline")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
'FT(0) = -4: FD(0) = "<OR"
'FT(1) = 0: FD(1) = "CIRCLE"
'FT(2) = 0: FD(2) = "ARC"
'FT(3) = -4: FD(3) = "OR>"
FT(0) = 0: FD(0) = "CIRCLE"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Circle"
objSelectOnScreen.Delete
Exit Sub
End If
'Creat Circle Arr
Dim EachobjSelectOnScreen As AcadCircle
Dim CircleArr() As AcadCircle
Dim ObjCircle As AcadCircle
Dim TmpCircle As AcadCircle
Dim k As Integer
Dim IsConcentic As Integer
Dim TmpConcentic As Integer
For Each EachobjSelectOnScreen In objSelectOnScreen
IsConcentic = 0
Set ObjCircle = EachobjSelectOnScreen
If Func70IsEmptyArray(CircleArr) = False Then
For i = LBound(CircleArr) To UBound(CircleArr)
Set TmpCircle = CircleArr(i)
TmpConcentic = Func77CircleABisConcentic(ObjCircle, TmpCircle)
If TmpConcentic = 1 And ObjCircle.radius > TmpCircle.radius Then
Set CircleArr(i) = ObjCircle
End If
IsConcentic = IsConcentic + TmpConcentic
Next
End If
If IsConcentic = 0 Then
ReDim Preserve CircleArr(O To k)
Set CircleArr(k) = ObjCircle
k = k + 1
End If
Next
For i = LBound(CircleArr) To UBound(CircleArr)
Set ObjCircle = CircleArr(i)
Call Func78CircleCenterlineKKS(ObjCircle)
Next
objSelectOnScreen.Delete
End Sub
Sub TBR13Change2ByBlock()
'Change Entity in block to byBlock, [C2BB]
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Block"
objSelectOnScreen.Delete
Exit Sub
End If
'Change entity color to byblock
Dim EachBlockReference As AcadBlockReference
Dim EachBlock As AcadBlock
Dim EachEntity As AcadEntity
For Each EachobjSelectOnScreen In objSelectOnScreen
Set EachBlockReference = EachobjSelectOnScreen
Set EachBlock = Thisdrawing.Blocks(EachBlockReference.Name)
For Each EachEntity In EachBlock
EachEntity.Color = acByBlock
Next
EachBlockReference.Color = acRed
Next
objSelectOnScreen.Delete
Thisdrawing.Regen (acActiveViewport)
End Sub
Sub TBR14Change2ByLayer()
'Change Entity in block to byLayer, [C2BL]
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Block"
objSelectOnScreen.Delete
Exit Sub
End If
'Change entity color to byblock
Dim EachBlockReference As AcadBlockReference
Dim EachBlock As AcadBlock
Dim EachEntity As AcadEntity
For Each EachobjSelectOnScreen In objSelectOnScreen
Set EachBlockReference = EachobjSelectOnScreen
Set EachBlock = Thisdrawing.Blocks(EachBlockReference.Name)
For Each EachEntity In EachBlock
EachEntity.Color = acByLayer
Next
EachBlockReference.Color = acByLayer
EachBlockReference.layer = NormalLayerName
Next
objSelectOnScreen.Delete
Thisdrawing.Regen (acActiveViewport)
End Sub
Sub TBR15RotateFinishingSysbol()
'Rotate Finishing Sysbol,[ROFS]
Thisdrawing.Utility.Prompt (vbCrLf & "Rotate Finishing Sysbol")
'Set UCS is world
Thisdrawing.SendCommand "UCS" & vbCr & "W" & vbCr
Dim Pi As Double
Pi = 4 * Atn(1)
'Select Finishing Sysbol(Text,MText,Line)(LayerText)
Dim FinishingLayer As String: FinishingLayer = TextLayerName
Thisdrawing.Utility.Prompt (vbCrLf & "Select Finishing Sysbol")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(7) As Integer
Dim FD(7) As Variant
FT(0) = -4: FD(0) = "<AND"
FT(1) = -4: FD(1) = "<OR"
FT(2) = 0: FD(2) = "TEXT"
FT(3) = 0: FD(3) = "MTEXT"
FT(4) = 0: FD(4) = "LINE"
FT(5) = -4: FD(5) = "OR>"
FT(6) = 8: FD(6) = FinishingLayer
FT(7) = -4: FD(7) = "AND>"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity"
objSelectOnScreen.Delete
Exit Sub
End If
'Get StartPoint and EndPoint
Dim StartPoint As Variant
Dim EndPoint As Variant
Dim Angle As Double
On Error GoTo ExitSub
StartPoint = Thisdrawing.Utility.GetPoint(, "Start Point select")
EndPoint = Thisdrawing.Utility.GetPoint(StartPoint, "End Point select")
Angle = Func23AngleOfLineThrough2Point(StartPoint, EndPoint)
'Define BeforeAngle of Finishing Sysbol
Dim EachEntity As AcadEntity
Dim FinishingAngleLine As AcadLine
Dim BeforeAnge As Double
Dim TmpLine As AcadLine
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbLine" Then
Set TmpLine = EachEntity
If Func79PointAisEndPointOfLineB(StartPoint, TmpLine) = False Then
Set FinishingAngleLine = TmpLine
End If
End If
Next
BeforeAngle = FinishingAngleLine.Angle
'Define RotateAngle and Rotate
Dim RotateAngle As Double
RotateAngle = Angle - BeforeAngle
For Each EachEntity In objSelectOnScreen
EachEntity.Rotate StartPoint, RotateAngle
Next
ExitSub:
objSelectOnScreen.Delete
End Sub
Sub TBR16SetDimensionLinearScale()
'Set Dimension Linear Scale,[SDLS]
Thisdrawing.Utility.Prompt (vbCrLf & "Set Dimension Linear Scale")
'Select Dimension
Thisdrawing.Utility.Prompt (vbCrLf & "Select Dimension to change Linear Scale")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity"
objSelectOnScreen.Delete
Exit Sub
End If
'Get Linear Scale
Dim LinearScale As Double
On Error Resume Next
LinearScale = Thisdrawing.Utility.GetReal("New Linear Scale = ")
If Err Then
Err.Clear
MsgBox "No Dimension Linear Scale"
objSelectOnScreen.Delete
Exit Sub
End If
'Change Dim linear scale
Dim EachEntity As AcadDimension
For Each EachEntity In objSelectOnScreen
EachEntity.LinearScaleFactor = LinearScale
Next
objSelectOnScreen.Delete
MsgBox "Finished"
End Sub
Sub TBR17OrdinateDimensionArrange()
'Ordinate Dimension Arrange,[ODA]
Thisdrawing.Utility.Prompt (vbCrLf & "Ordinate Dimension Arrange")
'Set UCS is world
Thisdrawing.SendCommand "UCS" & vbCr & "W" & vbCr
'Get Dimscale,Standart Distance
Dim Dimscale As Integer
Dimscale = Thisdrawing.GetVariable("DIMSCALE")
Dim Distance As Integer
Distance = 20 * Dimscale
'Select Dimension
Thisdrawing.Utility.Prompt (vbCrLf & "Select Dimension to arrange:")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity. Exit"
objSelectOnScreen.Delete
Exit Sub
End If
'Get MinPoint and MaxPoint
Dim MinPoint As Variant
Dim MaxPoint As Variant
On Error GoTo Next01
MinPoint = Thisdrawing.Utility.GetPoint(, "Select MinPoint:")
MaxPoint = Thisdrawing.Utility.GetPoint(, "Select MaxPoint:")
Next01:
If Err.Number <> 0 Then
Err.Clear
MsgBox "Don't Select MinPoint or MaxPoint. Exit"
objSelectOnScreen.Delete
Exit Sub
End If
'Define MinX,MaxX,MinY,MaxY from MinPoint,MaxPoint
Dim MinXMaxXMinYMaxY As Variant
MinXMaxXMinYMaxY = FuncCadHome01MaxMinXYFrom2Point(MinPoint, MaxPoint)
'Filter Only Ordinate Dimension
Dim OrdinateDimArr() As Variant
Dim kArr As Integer
Dim EachEntity As AcadDimension
Dim EachOrdinateDim As AcadDimOrdinate
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" Then
ReDim Preserve OrdinateDimArr(0 To kArr)
Set OrdinateDimArr(kArr) = EachEntity
kArr = kArr + 1
End If
Next
Dim DimDirection As String
Dim Delta As Variant
Dim DeltaX As Integer
Dim DeltaY As Integer
Dim NewTextPosition(0 To 2) As Double
For i = LBound(OrdinateDimArr) To UBound(OrdinateDimArr)
Set EachOrdinateDim = OrdinateDimArr(i)
DimDirection = FuncCadHome03OrdinateDimDirection(EachOrdinateDim, MinXMaxXMinYMaxY)
Delta = FuncCadHome04DefineDeltaDistanceFromDirection(DimDirection)
DeltaX = Delta(0)
DeltaY = Delta(1)
Select Case DeltaX
Case -1
NewTextPosition(0) = MinXMaxXMinYMaxY(0) + DeltaX * Distance
Case 0
NewTextPosition(0) = EachOrdinateDim.TextPosition(0)
Case 1
NewTextPosition(0) = MinXMaxXMinYMaxY(1) + DeltaX * Distance
End Select
Select Case DeltaY
Case -1
NewTextPosition(1) = MinXMaxXMinYMaxY(2) + DeltaY * Distance
Case 0
NewTextPosition(1) = EachOrdinateDim.TextPosition(1)
Case 1
NewTextPosition(1) = MinXMaxXMinYMaxY(3) + DeltaY * Distance
End Select
EachOrdinateDim.TextPosition = NewTextPosition
EachOrdinateDim.Update
Next
objSelectOnScreen.Delete
End Sub
Sub TBR18OrdinateDimensionStraighten()
'(VBA AutoCad)Ordinate Dimension Straighten,[ODS]
Thisdrawing.Utility.Prompt (vbCrLf & "Ordinate Dimension Straighten")
'Select Dimension
Thisdrawing.Utility.Prompt (vbCrLf & "Select Ordinate Dimension to Straighten:")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity. Exit"
objSelectOnScreen.Delete
Exit Sub
End If
'Get MinPoint and MaxPoint
Dim MinPoint As Variant
Dim MaxPoint As Variant
'On Error GoTo Next01
MinPoint = Thisdrawing.Utility.GetPoint(, "Select MinPoint:")
MaxPoint = Thisdrawing.Utility.GetPoint(, "Select MaxPoint:")
'Next01:
'If Err.Number <> 0 Then
' Err.Clear
' MsgBox "Don't Select MinPoint or MaxPoint. Exit"
' objSelectOnScreen.Delete
' Exit Sub
'End If
'Set UCS to MinPoint
Call FuncCadHome05SetUCSFromPoint(MinPoint)
'Define MinX,MaxX,MinY,MaxY from MinPoint,MaxPoint
Dim MinXMaxXMinYMaxY As Variant
MinXMaxXMinYMaxY = FuncCadHome01MaxMinXYFrom2Point(MinPoint, MaxPoint)
'
'Filter Only Ordinate Dimension
Dim OrdinateDimArr() As Variant
Dim kArr As Integer
Dim EachEntity As AcadDimension
Dim EachOrdinateDim As AcadDimOrdinate
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" Then
ReDim Preserve OrdinateDimArr(0 To kArr)
Set OrdinateDimArr(kArr) = EachEntity
kArr = kArr + 1
End If
Next
Dim DimDirection As String
Dim ChangeCount As Integer
Dim DimMeasurement As Double
Dim OldTextPosition As Variant
Dim OldTextPositionX As Double
Dim OldTextPositionY As Double
Dim NewTextPosition(0 To 2) As Double
Dim WorldNewTextPositon As Variant
For i = LBound(OrdinateDimArr) To UBound(OrdinateDimArr)
Set EachOrdinateDim = OrdinateDimArr(i)
DimDirection = FuncCadHome03OrdinateDimDirection(EachOrdinateDim, MinXMaxXMinYMaxY)
OldTextPosition = EachOrdinateDim.TextPosition
OldTextPosition = Thisdrawing.Utility.TranslateCoordinates(OldTextPosition, acWorld, acUCS, 0)
OldTextPositionX = Round(OldTextPosition(0), 2)
OldTextPositionY = Round(OldTextPosition(1), 2)
DimMeasurement = Round(EachOrdinateDim.Measurement, 2)
Select Case DimDirection
Case "UP", "DOWN"
If DimMeasurement <> OldTextPositionX Then
NewTextPosition(0) = EachOrdinateDim.Measurement
NewTextPosition(1) = OldTextPosition(1)
WorldNewTextPositon = NewTextPosition
WorldNewTextPositon = Thisdrawing.Utility.TranslateCoordinates(WorldNewTextPositon, acUCS, acWorld, 0)
EachOrdinateDim.TextPosition = WorldNewTextPositon
EachOrdinateDim.Update
ChangeCount = ChangeCount + 1
End If
Case "LEFT", "RIGHT"
If DimMeasurement <> OldTextPositionY Then
NewTextPosition(1) = EachOrdinateDim.Measurement
NewTextPosition(0) = OldTextPosition(0)
WorldNewTextPositon = NewTextPosition
WorldNewTextPositon = Thisdrawing.Utility.TranslateCoordinates(WorldNewTextPositon, acUCS, acWorld, 0)
EachOrdinateDim.TextPosition = WorldNewTextPositon
EachOrdinateDim.Update
ChangeCount = ChangeCount + 1
End If
Case Else
End Select
Next
objSelectOnScreen.Delete
MsgBox "Change Text Position of " & ChangeCount & " Ordinate Dimension"
End Sub
Sub TBR19OrdinateDimensionStraightenManual()
'(VBA AutoCad)Ordinate Dimension Straighten Manual,[ODSM]
Thisdrawing.Utility.Prompt (vbCrLf & "Ordinate Dimension Straighten Manual")
'Set UCS is world
Thisdrawing.SendCommand "UCS" & vbCr & "W" & vbCr
'Set ORTHO ON
Thisdrawing.SetVariable "ORTHOMODE", 1
Dim Pi As Double
Pi = 4 * Atn(1)
'Select Dimension
Dim varPick As Variant
Dim Msg As String: Msg = "Select Ordinate Dimension to Straighten Manual:"
Dim objSelect As AcadDimOrdinate
Dim CountLoop As Integer
On Error Resume Next
Do While objSelect Is Nothing
If CountLoop = 3 Then Exit Sub
Thisdrawing.Utility.GetEntity objSelect, varPick, Msg
CountLoop = CountLoop + 1
Loop
'Get PointA and PointB
Thisdrawing.Utility.Prompt (vbCrLf & "Select 2Point to Define dim direction")
Dim PointA As Variant
Dim PointB As Variant
On Error GoTo Next01
PointA = Thisdrawing.Utility.GetPoint(, "Select PointA:")
PointB = Thisdrawing.Utility.GetPoint(PointA, "Select PointB:")
Next01:
If Err.Number <> 0 Then
MsgBox "Don't Select PointA or PointB. Exit"
Exit Sub
End If
'Define Dim Direction From 2Point
Dim XorY As String
If Round(PointA(1), 2) = Round(PointB(1), 2) Then
XorY = "NamNgang"
Else
XorY = "ThangDung"
End If
'Define NewTexPositon
Dim OldTextPosition As Variant
Dim OldTextPositionX As Double
Dim OldTextPositionY As Double
Dim NewTextPosition(0 To 2) As Double
OldTextPosition = objSelect.TextPosition
OldTextPositionX = OldTextPosition(0)
OldTextPositionY = OldTextPosition(1)
Select Case XorY
Case "NamNgang"
NewTextPosition(0) = OldTextPositionX
NewTextPosition(1) = PointA(1)
Case "ThangDung"
NewTextPosition(0) = PointA(0)
NewTextPosition(1) = OldTextPositionY
End Select
'Move Dim Text
objSelect.TextPosition = NewTextPosition
objSelect.Update
End Sub
Sub TBR20OridinateDimensionUCS()
'(VBA AutoCad)Ordinate Dimension UCS,[ODUCS]
Thisdrawing.Utility.Prompt (vbCrLf & "Ordinate Dimension Set UCS")
'Get UCS Point
Dim UCSPoint As Variant
Dim MaxPoint As Variant
On Error GoTo ExitSub
UCSPoint = Thisdrawing.Utility.GetPoint(, "Select UCSPoint:")
'Set UCS to UCSPoint
Call FuncCadHome05SetUCSFromPoint(UCSPoint)
ExitSub:
End Sub
Sub TBR21OrdinateDimensionMove()
'(VBA AutoCad)Ordinate Dimension Move,[ODM]
Thisdrawing.Utility.Prompt (vbCrLf & "Ordinate Dimension to Move")
'Get MinPoint and MaxPoint
Thisdrawing.Utility.Prompt (vbCrLf & "Select MinPoint and MaxPoint" & vbCrLf)
Dim MinPoint As Variant
Dim MaxPoint As Variant
On Error GoTo Next01
MinPoint = Thisdrawing.Utility.GetPoint(, "Select MinPoint:")
MaxPoint = Thisdrawing.Utility.GetPoint(, "Select MaxPoint:")
Next01:
If Err.Number <> 0 Then
MsgBox "Don't Select MinPoint or MaxPoint. Exit"
Exit Sub
End If
'Creat user UCS
Call FuncCadHome05SetUCSFromPoint(MinPoint)
'Select Dimension
'Get PointA
Dim varPick As Variant
Dim Msg As String: Msg = vbCrLf & "Select Ordinate Dimension to Move:"
Dim objSelect As AcadDimOrdinate
Dim PointA As Variant
On Error Resume Next
Do
Thisdrawing.Utility.GetEntity objSelect, varPick, Msg
PointA = Thisdrawing.Utility.GetPoint(, "Select Ordinate Dimension Point:")
If Err.Number = 0 Then
Call FuncCadHome06MoveOrdinateDimension(objSelect, PointA, MinPoint, MaxPoint, True)
End If
Loop While Err.Number = 0
End Sub
Sub TBR22OrdinateDimensionCopy()
'(VBA AutoCad)Ordinate Dimension Copy,[ODC]
Thisdrawing.Utility.Prompt (vbCrLf & "Copy Ordinate Dimension")
'Get MinPoint and MaxPoint
Thisdrawing.Utility.Prompt (vbCrLf & "Select MinPoint and MaxPoint" & vbCrLf)
Dim MinPoint As Variant
Dim MaxPoint As Variant
On Error GoTo Next01
MinPoint = Thisdrawing.Utility.GetPoint(, "Select MinPoint:")
MaxPoint = Thisdrawing.Utility.GetPoint(, "Select MaxPoint:")
Next01:
If Err.Number <> 0 Then
MsgBox "Don't Select MinPoint or MaxPoint. Exit"
Exit Sub
End If
'Creat user UCS
Call FuncCadHome05SetUCSFromPoint(MinPoint)
'Select Dimension
'Get PointA
Dim varPick As Variant
Dim Msg As String: Msg = vbCrLf & "Select Ordinate Dimension To Copy:"
Dim objSelect As AcadDimOrdinate
On Error Resume Next
Thisdrawing.Utility.GetEntity objSelect, varPick, Msg
If Err.Number <> 0 Then
MsgBox "No Ordinate Dimension"
Exit Sub
End If
Dim PointA As Variant
Do
PointA = Thisdrawing.Utility.GetPoint(, "Select Ordinate Dimension Point:")
If Err.Number = 0 Then
Call FuncCadHome06MoveOrdinateDimension(objSelect, PointA, MinPoint, MaxPoint, False)
End If
Loop While Err.Number = 0
End Sub
Sub TBR23OrdinateDimensionCheckOrigin()
'(VBA AutoCad)Ordinate Dimension Check Origin,[ODCO]
Dim Point00 As Variant
Dim Point00Arr() As Variant
Dim k As Integer
On Error Resume Next
Do
Point00 = Thisdrawing.Utility.GetPoint(, "Select Ordinate Point:")
If Err.Number = 0 Then
ReDim Preserve Point00Arr(0 To k)
Point00Arr(k) = Point00
k = k + 1
End If
Loop While Err.Number = 0
If Func70IsEmptyArray(Point00Arr) = True Then Exit Sub
Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim Pi As Double: Pi = 4 * Atn(1)
For i = LBound(Point00Arr) To UBound(Point00Arr)
Point00 = Point00Arr(i)
MinPoint = Thisdrawing.Utility.PolarPoint(Point00, 5 * Pi / 4, 0.001)
MaxPoint = Thisdrawing.Utility.PolarPoint(Point00, Pi / 4, 0.001)
'Select Dimension
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
objSelectOnScreen.Select acSelectionSetCrossing, MinPoint, MaxPoint, FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity. Exit"
' objSelectOnScreen.Delete
' Exit Sub
End If
Dim EachEntity As AcadDimension
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" Then
EachEntity.Visible = False
End If
Next
Next
objSelectOnScreen.Clear
'Check have Ordinate Dimension?
Dim WrongCount As Integer
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
objSelectOnScreen.Select acSelectionSetAll, , , FT, FD
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" And EachEntity.Visible = True Then
EachEntity.Color = acMagenta
WrongCount = WrongCount + 1
End If
Next
For Each EachEntity In objSelectOnScreen
EachEntity.Visible = True
Next
MsgBox "Wrong Ordinate Dimension: " & WrongCount
End Sub