06-20-2021
06:00 AM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
06-20-2021
06:00 AM
Function HCF4156_DistanceFromPoint2ToPoint1WithAngle(Point1 As Variant, Point2 As Variant, DblAngle As Double, RoundNumber As Integer) As Double
Dim Pi As Double: Pi = 4 * Atn(1)
'Xac dinh goc vuong goc voi DblAngle
Dim AngleXPoint1 As Double: AngleXPoint1 = DblAngle + Pi / 2
'Angle And Distance From Point1 to Point2
Dim AnglePoint12 As Double
Dim DistancePoint12 As Double
AnglePoint12 = Func23AngleOfLineThrough2Point(Point1, Point2)
DistancePoint12 = Func20LengthLineThrough2Point(Point1, Point2)
'Define Distance From Point2 to Point1 With Angle
Dim SinAngle As Double
Dim DistancePoint2ToPoint1WithAngle As Double
SinAngle = AnglePoint12 - AngleXPoint1
DistancePoint2ToPoint1WithAngle = Abs(DistancePoint12 * Sin(SinAngle))
If RoundNumber <> 100 Then
DistancePoint2ToPoint1WithAngle = Round(DistancePoint2ToPoint1WithAngle, RoundNumber)
End If
HCF4156_DistanceFromPoint2ToPoint1WithAngle = DistancePoint2ToPoint1WithAngle
End Function
Function HCF4157_IsInArr1ChieuWithDelta_Number(ListArr As Variant, NeedCheckValue As Double, Delta As Double) As Boolean
Dim CompareValue As Variant
For i = LBound(ListArr) To UBound(ListArr)
CompareValue = ListArr(i)
CompareValue = CDbl(CompareValue)
If Abs(CompareValue - NeedCheckValue) <= Delta Then
HCF4157_IsInArr1ChieuWithDelta_Number = True
Exit Function
End If
Next
End Function
Function HCF4158_DefinePositionInArr1ChieuWithDelta_Number(ListArr As Variant, NeedCheckValue As Double, Delta As Double) As Variant
'Defaut Value
HCF4158_DefinePositionInArr1ChieuWithDelta_Number = False
'Process
Dim CompareValue As Variant
For i = LBound(ListArr) To UBound(ListArr)
CompareValue = ListArr(i)
CompareValue = CDbl(CompareValue)
If Abs(CompareValue - NeedCheckValue) <= Delta Then
HCF4158_DefinePositionInArr1ChieuWithDelta_Number = i
Exit Function
End If
Next
End Function
Sub HCS3122_HoanDoiViTri2LopKichThuoc()
'(TB VBABoss) Hoan Doi Vi Tri 2Lop Kich Thuoc,[D12]
'Chon Lop Kich Thuoc 1
Thisdrawing.Utility.Prompt (vbCrLf & "Select Dimensions(Class1):" & vbCr)
Dim Class1 As AcadSelectionSet
Set Class1 = Thisdrawing.SelectionSets.Add("Class1" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
Class1.SelectOnScreen FT, FD
Call HCF4151_Call_FilterOnlyLinearDimInDimSelectSet(Class1)
If Class1.Count = 0 Then
Class1.Delete
Exit Sub
End If
'Chon Lop Kich Thuoc 2
Thisdrawing.Utility.Prompt (vbCrLf & "Select Dimensions(Class2):" & vbCr)
Dim Class2 As AcadSelectionSet
Set Class2 = Thisdrawing.SelectionSets.Add("Class2" & Now)
Class2.SelectOnScreen FT, FD
Call HCF4151_Call_FilterOnlyLinearDimInDimSelectSet(Class2)
If Class2.Count = 0 Then
GoTo GoToExitSub
End If
'Reset HomeText All Dim In SelectSet
Call HCF4146_Call_ResetHomeTextOfDimSelectSet(Class1)
Call HCF4146_Call_ResetHomeTextOfDimSelectSet(Class2)
'Xac dinh kich thuoc lon nhat
Dim LargestDim1 As AcadDimension
Dim LargestDim2 As AcadDimension
Set LargestDim1 = HCF4141_DefineLargestDimInDimSelectSet(Class1)
Set LargestDim2 = HCF4141_DefineLargestDimInDimSelectSet(Class2)
'Define OldDimPosition of Class1 and Class2
Dim GetDimLinePosition As Variant
Dim OldDimLinePosition1 As Variant
Dim OldDimLinePosition2 As Variant
GetDimLinePosition = HCF4154_GetProperty_LinearDim_ByExplode(LargestDim1)
If VarType(GetDimLinePosition) = vbBoolean Then
GoTo GoToExitSub
Else
OldDimLinePosition1 = GetDimLinePosition(0)
End If
GetDimLinePosition = HCF4154_GetProperty_LinearDim_ByExplode(LargestDim2)
If VarType(GetDimLinePosition) = vbBoolean Then
GoTo GoToExitSub
Else
OldDimLinePosition2 = GetDimLinePosition(0)
End If
'MoveDimText
Dim EachDim As AcadDimension
For Each EachDim In Class1
EachDim.TextPosition = OldDimLinePosition2
EachDim.Update
Next
For Each EachDim In Class2
EachDim.TextPosition = OldDimLinePosition1
EachDim.Update
Next
'Reset HomeText All Dim In SelectSet
Call HCF4146_Call_ResetHomeTextOfDimSelectSet(Class1)
Call HCF4146_Call_ResetHomeTextOfDimSelectSet(Class2)
GoToExitSub:
Class1.Delete
Class2.Delete
'Reset CommandLine
Call HCF4153_Call_ResetCommandLine("D12")
End Sub
Sub HCS3123_DimArrange1Direction()
'(TB VBABoss) Dim Arrange One Direction Type,[DA1]
'System Setting
'Get DimScale
Dim DimScale As Variant: DimScale = Thisdrawing.GetVariable("DIMSCALE")
'DeltaDimSpace
Dim DeltaDimSpace As Double: DeltaDimSpace = 2 * DimScale
'Othor On
Thisdrawing.SetVariable "ORTHOMODE", 1
'Backup OSMODE
Dim BackupOsnap As Variant: BackupOsnap = HCF4113_SettingOsnap("Backup", "")
'Select DimSelectSet
Dim DimSelectSet As AcadSelectionSet
Set DimSelectSet = Thisdrawing.SelectionSets.Add("DimSelectSet" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
Thisdrawing.Utility.Prompt (vbCrLf & "Select Dimensions to Arrangement:" & vbCr)
DimSelectSet.SelectOnScreen FT, FD
'Filter Only LinearDim
Call HCF4151_Call_FilterOnlyLinearDimInDimSelectSet(DimSelectSet)
If DimSelectSet.Count = 0 Then GoTo GoToExitSub
'Reset HomeText All Dim In SelectSet
Call HCF4146_Call_ResetHomeTextOfDimSelectSet(DimSelectSet)
'Select BasicObj
Dim GetObj() As Variant
Dim Obj As AcadEntity
GetObj = HCF4059_GetObj(Thisdrawing, "Select Obj to define DimSpace:")
If GetObj(0) = False Then
GoTo GoToExitSub
Else
Set Obj = GetObj(1)
End If
'Get Point1
Dim Point1 As Variant
Call HCF4113_SettingOsnap("Nearest", "")
Point1 = HCF4045_GetPoint(Thisdrawing, "Select Point1 to Arrange Dimension:")
If Func70IsEmptyArray(Point1) = True Then GoTo GoToExitSub
'Define DimSpace1,DimSpace2
Dim DimSpace0 As Integer
Dim DimSpace1 As Integer: DimSpace1 = SettingDimSpace1
If HCF4021_IsDimension(Obj) = True Then
DimSpace0 = SettingDimSpace1
Else
DimSpace0 = SettingDimSpace0
End If
DimSpace0 = DimScale * DimSpace0
DimSpace1 = DimScale * DimSpace1
'Select Point2 to DefineDirection
Dim Point2 As Variant
Call HCF4113_SettingOsnap("Perpendicular", "")
Point2 = HCF4106_GetSecondPoint(Thisdrawing, Point1, "Select Point2 to Define Direction Arrange Dimension:")
If Func70IsEmptyArray(Point2) = True Then GoTo GoToExitSub
'Get DimSpace
Dim GetInteger As Variant
GetInteger = HCF4061_GetInteger(Thisdrawing, "DimSpace of First Class(*DimScale):")
If VarType(GetInteger) <> vbBoolean Then
DimSpace0 = DimScale * GetInteger
End If
'Define Angle From Point1 to Point2
Dim Point12Angle As Double
Point12Angle = Func23AngleOfLineThrough2Point(Point1, Point2)
'Define Distance From DimTextPoint to Point1 With Angle
Dim DistanceDimTextPoint() As Double
Dim EachDim As AcadDimension
Dim EachDimTextPosition As Variant
Dim EachDistance As Double
Dim IsInList As Boolean
For Each EachDim In DimSelectSet
IsInList = False
EachDimTextPosition = EachDim.TextPosition
EachDistance = HCF4156_DistanceFromPoint2ToPoint1WithAngle(Point1, EachDimTextPosition, Point12Angle, 0)
If k = 0 Then
ReDim Preserve DistanceDimTextPoint(0 To k)
DistanceDimTextPoint(k) = EachDistance
k = k + 1
Else
IsInList = HCF4157_IsInArr1ChieuWithDelta_Number(DistanceDimTextPoint, EachDistance, DeltaDimSpace)
If IsInList = False Then
ReDim Preserve DistanceDimTextPoint(0 To k)
DistanceDimTextPoint(k) = EachDistance
k = k + 1
End If
End If
Next
'Sort DistanceDimTextPoint() A to Z
DistanceDimTextPoint = HCF4057_SortArrAtoZ_NumberType(DistanceDimTextPoint)
'Arrange Dim
Dim GetEachClassNo As Variant
Dim EachClassNo As Integer
Dim EachMoveSpace As Double
Dim NewTextPositon As Variant
For Each EachDim In DimSelectSet
EachDimTextPosition = EachDim.TextPosition
EachDistance = HCF4156_DistanceFromPoint2ToPoint1WithAngle(Point1, EachDimTextPosition, Point12Angle, 0)
GetEachClassNo = HCF4158_DefinePositionInArr1ChieuWithDelta_Number(DistanceDimTextPoint, EachDistance, DeltaDimSpace)
If VarType(GetEachClassNo) <> vbBoolean Then
EachClassNo = GetEachClassNo
EachMoveSpace = DimSpace0 + EachClassNo * DimSpace1
NewTextPositon = Thisdrawing.Utility.PolarPoint(Point1, Point12Angle, EachMoveSpace)
EachDim.TextPosition = NewTextPositon
EachDim.Update
End If
Next
'Reset TextDimPosition
Call HCF4146_Call_ResetHomeTextOfDimSelectSet(DimSelectSet)
GoToExitSub:
DimSelectSet.Delete
Call HCF4113_SettingOsnap("Restore", BackupOsnap)
Call HCF4153_Call_ResetCommandLine("DA1")
End Sub
Function Func19ObjectCenterPoint(Obj As AcadEntity) As Variant
'Function Xac dinh center cua Obj
Dim MinPointObj As Variant
Dim MaxPointObj As Variant
Dim lineObj As AcadLine
Dim LineObjLen As Double
Dim LineObjAngle As Double
Obj.GetBoundingBox MinPointObj, MaxPointObj
Set lineObj = Thisdrawing.ModelSpace.AddLine(MinPointObj, MaxPointObj)
lineObj.Visible = False
LineObjLen = lineObj.Length
LineObjAngle = lineObj.Angle
Func19ObjectCenterPoint = Thisdrawing.Utility.PolarPoint(MinPointObj, LineObjAngle, LineObjLen / 2)
lineObj.Delete
End Function
Function HCF4154_GetProperty_LinearDim_ByExplode(ObjDim As AcadDimension) As Variant
'Dim Result(0_DimLinePosition)
Dim Result(0) As Variant
'Check Is Linear Dimension
Dim IsLinearDim As Boolean
IsLinearDim = HCF4150_IsLinearDimension(ObjDim)
If IsLinearDim = False Then
HCF4154_GetProperty_LinearDim_ByExplode = False
Exit Function
End If
'Explode Dim
Dim AfterExplodeSelectSet As AcadSelectionSet
Set AfterExplodeSelectSet = Thisdrawing.SelectionSets.Add("AfterExplodeSelectSet" & Now)
Call HCF4155_Call_CreatSelectSetAfterExplodeObj(ObjDim, AfterExplodeSelectSet)
If AfterExplodeSelectSet.Count = 0 Then
HCF4154_GetProperty_LinearDim_ByExplode = False
GoTo GoToExitSub
End If
'Define DimTextAngle
Dim EachEntity As AcadEntity
Dim DimText As AcadMText
Dim DimTextAngle As Double
Dim DimTextCount As Integer
For Each EachEntity In AfterExplodeSelectSet
If EachEntity.ObjectName = "AcDbMText" Then
Set DimText = EachEntity
DimTextCount = DimTextCount + 1
End If
Next
If DimTextCount = 1 Then
DimTextAngle = DimText.Rotation
Else
MsgBox "Can't Define DimTextAngle After Explode LinearDim."
HCF4154_GetProperty_LinearDim_ByExplode = False
GoTo GoToExitSub
End If
'Define DimLinePosition
Dim EachLine As AcadLine
Dim EachLineAngle As Double
Dim DimLine As AcadLine
Dim DimLineCount As Integer
Dim DimLinePosition As Variant
Dim TextAndLineIsParallel As Boolean
For Each EachEntity In AfterExplodeSelectSet
If EachEntity.ObjectName = "AcDbLine" Then
Set EachLine = EachEntity
EachLineAngle = EachLine.Angle
TextAndLineIsParallel = HCF4129_TwoAngleIsParallel(DimTextAngle, EachLineAngle, 2)
If TextAndLineIsParallel = True Then
Set DimLine = EachLine
DimLineCount = DimLineCount + 1
End If
End If
Next
If DimLineCount = 1 Then
DimLinePosition = Func19ObjectCenterPoint(DimLine)
Result(0) = DimLinePosition
Else
MsgBox "Can't Define DimTextAngle After Explode LinearDim."
HCF4154_GetProperty_LinearDim_ByExplode = False
GoTo GoToExitSub
End If
'Result
HCF4154_GetProperty_LinearDim_ByExplode = Result
GoToExitSub:
AfterExplodeSelectSet.Erase
AfterExplodeSelectSet.Delete
End Function
Function HCF4155_Call_CreatSelectSetAfterExplodeObj(Obj As AcadEntity, AfterExplodeSelectSet As AcadSelectionSet)
'Creat CopyObj
Dim CopyObj As AcadEntity
Set CopyObj = Obj.Copy
CopyObj.Visible = False
'Explode Obj
Call HCF4007_ExplodeBlockReference(Thisdrawing, CopyObj)
Thisdrawing.SendCommand "SELECT" & vbCr & "P" & vbCr & vbCr
'Select Entity After Explode
AfterExplodeSelectSet.Select acSelectionSetPrevious
End Function
;(TB VBABoss) Dim Arrange One Direction Type,[DA1]
(defun C:DA1()
(command "-vbarun" "HCS3123_DimArrange1Direction")
)