06-30-2021
03:11 PM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
06-30-2021
03:11 PM
'Setting For Update Block Version 2
Public OpeningFileArr() As String
Public UB_UpdateFromDrawing As String
Public UB_UpdateToDrawing As String
Function HCF4159_Call_FilterOnlyRotatedDimInDimSelectSet(DimSS As AcadSelectionSet)
'Check Input
If DimSS.Count = 0 Then Exit Function
'Filter
Dim EachDim As AcadDimension
Dim IsNotRotatedDimArr() As AcadDimension
Dim k As Integer
For Each EachDim In DimSS
If EachDim.ObjectName <> "AcDbRotatedDimension" Then
ReDim Preserve IsNotRotatedDimArr(0 To k)
Set IsNotRotatedDimArr(k) = EachDim
k = k + 1
End If
Next
If k > 0 Then DimSS.RemoveItems (IsNotRotatedDimArr)
End Function
Function HCF4160_LimitPointOfBlockRef(BlockRef As AcadBlockReference) As Variant
'Result(MinPoint,MaxPoint)
HCF4160_LimitPointOfBlockRef = False
'Setting
Dim ObjLayerName As String
Select Case ProjectName
Case "DFK"
ObjLayerName = DFK_NormalLayerName
Case "KKS"
ObjLayerName = KKS_NormalLayerName
Case Else
ObjLayerName = "0"
End Select
'Creat BackupBlockRef
Dim BKBlockRef As AcadBlockReference: Set BKBlockRef = BlockRef.Copy
Dim AfterExplodeArr As Variant
AfterExplodeArr = BKBlockRef.Explode
BKBlockRef.Delete
'Define MinPoint, MaxPoint of AfterExplodeArr
Dim GetMinMaxPoint As Variant
GetMinMaxPoint = HCF4161_MinPointMaxPointOfObjArr(AfterExplodeArr, ObjLayerName, True)
If VarType(GetMinMaxPoint) = vbBoolean Then
Exit Function
Else
HCF4160_LimitPointOfBlockRef = GetMinMaxPoint
End If
End Function
Function HCF4161_MinPointMaxPointOfObjArr(ObjArr As Variant, ObjLayerName As String, DeleteMode As Boolean) As Variant
'Result(MinPoint,MaxPoint) or Result=False
HCF4161_MinPointMaxPointOfObjArr = False
'Check Input
If Func70IsEmptyArray(ObjArr) = True Then Exit Function
'Define MinX,MaxX,MinY,MaxY
Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim MinX As Double
Dim MaxX As Double
Dim MinY As Double
Dim MaxY As Double
'Set gia tri ban dau cho MinX,MaxX,MinY,MaxY
Dim EachEntity As AcadEntity
For i = LBound(ObjArr) To UBound(ObjArr)
Set EachEntity = ObjArr(i)
If EachEntity.Layer = ObjLayerName Or EachEntity.Layer = "0" Then
EachEntity.GetBoundingBox MinPoint, MaxPoint
MinX = MinPoint(0)
MinY = MinPoint(1)
MaxX = MaxPoint(0)
MaxY = MaxPoint(1)
GoTo GoToNextStep
End If
Next
GoToNextStep:
'Define MinX,MaxX,MinY,MaxY
For i = LBound(ObjArr) To UBound(ObjArr)
Set EachEntity = ObjArr(i)
If EachEntity.Layer = ObjLayerName Or EachEntity.Layer = "0" Then
EachEntity.GetBoundingBox MinPoint, MaxPoint
If MinX > MinPoint(0) Then MinX = MinPoint(0)
If MinY > MinPoint(1) Then MinY = MinPoint(1)
If MaxX < MaxPoint(0) Then MaxX = MaxPoint(0)
If MaxY < MaxPoint(1) Then MaxY = MaxPoint(1)
End If
Next
'Define SSMinPoint,SSMaxPoint,SSCenterPoint
Dim Result(0 To 1) As Variant
Dim SSMinPoint(0 To 2) As Double
Dim SSMaxPoint(0 To 2) As Double
SSMinPoint(0) = MinX
SSMinPoint(1) = MinY
SSMaxPoint(0) = MaxX
SSMaxPoint(1) = MaxY
Result(0) = SSMinPoint
Result(1) = SSMaxPoint
HCF4161_MinPointMaxPointOfObjArr = Result
'DeleteMode
If DeleteMode = True Then
For i = LBound(ObjArr) To UBound(ObjArr)
Set EachEntity = ObjArr(i)
EachEntity.Delete
Next
End If
End Function
Function HCF4162_Get2PointWithOSMODE(MsgPoint1 As String, MsgPoint2 As String, OsmodePoint1 As Integer, OsmodePoint2 As Integer, LinePoint12Mode As Boolean) As Variant
'Result(Point1,Point2) or Result=False
HCF4162_Get2PointWithOSMODE = False
Dim Result(0 To 1) As Variant
Dim Point1 As Variant
Dim Point2 As Variant
'Backup OSMODE
Dim BackupOsnap As Variant: BackupOsnap = HCF4113_SettingOsnap("Backup", "")
'Get Point1
Call HCF4113_SettingOsnap("Restore", OsmodePoint1)
Point1 = HCF4045_GetPoint(Thisdrawing, MsgPoint1)
If Func70IsEmptyArray(Point1) = True Then GoTo GoToExitFunc
'Select Point2 to DefineDirection
Call HCF4113_SettingOsnap("Restore", OsmodePoint2)
If LinePoint12Mode = True Then
'Set ucs is world
Call HCF4163_Call_SetUCSIsWorld
Point2 = HCF4106_GetSecondPoint(Thisdrawing, Point1, MsgPoint2)
Else
Point2 = HCF4045_GetPoint(Thisdrawing, MsgPoint2)
End If
If Func70IsEmptyArray(Point2) = True Then GoTo GoToExitFunc
'Result
Result(0) = Point1
Result(1) = Point2
HCF4162_Get2PointWithOSMODE = Result
GoToExitFunc:
Call HCF4113_SettingOsnap("Restore", BackupOsnap)
End Function
Function HCF4163_Call_SetUCSIsWorld()
Thisdrawing.SendCommand "UCS" & vbCr & "W" & vbCr
End Function
Function HCF4164_Call_MinPointMaxPointFrom2Point(MinPoint As Variant, MaxPoint As Variant)
Dim MinX As Double
Dim MaxX As Double
Dim MinY As Double
Dim MaxY As Double
Dim TmpDouble As Double
MinX = MinPoint(0)
MinY = MinPoint(1)
MaxX = MaxPoint(0)
MaxY = MaxPoint(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
'Result
MinPoint(0) = MinX
MinPoint(1) = MinY
MaxPoint(0) = MaxX
MaxPoint(1) = MaxY
End Function
Function HCF4165_DimPositionWithMinMaxPoint(ObjDim As AcadDimension, MinPoint As Variant, MaxPoint As Variant) As String
'Function xac nhan vi tri cua Ordinate Dim so voi MinPoint va MaxPoint
Dim DimDirection As String
'Define MinMaxXY
Dim MinX As Double
Dim MaxX As Double
Dim MinY As Double
Dim MaxY As Double
MinX = MinPoint(0)
MaxX = MaxPoint(0)
MinY = MinPoint(1)
MaxY = MaxPoint(1)
'TextPosition
Dim TextPoint As Variant
Dim TextPointX As Double
Dim TextPointY As Double
TextPoint = ObjDim.TextPosition
TextPointX = TextPoint(0)
TextPointY = TextPoint(1)
'DeltaMinMax
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
'IN
If DeltaMinX >= 0 And DeltaMaxX <= 0 And DeltaMinY >= 0 And DeltaMaxY <= 0 Then
HCF4165_DimPositionWithMinMaxPoint = "IN"
Exit Function
End If
'LEFT
If DeltaMinX < 0 And DeltaMinY > 0 And DeltaMaxY < 0 Then
HCF4165_DimPositionWithMinMaxPoint = "LEFT"
Exit Function
End If
'RIGHT
If DeltaMaxX > 0 And DeltaMinY > 0 And DeltaMaxY < 0 Then
HCF4165_DimPositionWithMinMaxPoint = "RIGHT"
Exit Function
End If
'UP
If DeltaMaxY > 0 And DeltaMinX > 0 And DeltaMaxX < 0 Then
HCF4165_DimPositionWithMinMaxPoint = "UP"
Exit Function
End If
'DOWN
If DeltaMinY < 0 And DeltaMinX > 0 And DeltaMaxX < 0 Then
HCF4165_DimPositionWithMinMaxPoint = "DOWN"
Exit Function
End If
HCF4165_DimPositionWithMinMaxPoint = "N/A"
End Function
Function HCF4166X_ArrangeDimArr(ObjDimArr() As AcadDimension, LeftRightUpDown As String, MinPoint As Variant, MaxPoint As Variant, DeltaDimSpace As Double, DimSpace0 As Integer, DimSpace1 As Integer)
'Define Angle From Point1 to Point2 and MainPoint
Dim Pi As Double: Pi = 4 * Atn(1)
Dim Point12Angle As Double
Dim MainPoint As Variant
Select Case LeftRightUpDown
Case "LEFT"
Point12Angle = Pi
MainPoint = MinPoint
Case "RIGHT"
Point12Angle = 0
MainPoint = MaxPoint
Case "UP"
Point12Angle = Pi / 2
MainPoint = MaxPoint
Case "DOWN"
Point12Angle = 3 * Pi / 2
MainPoint = MinPoint
Case Else
Exit Function
End Select
'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 i = LBound(ObjDimArr) To UBound(ObjDimArr)
Set EachDim = ObjDimArr(i)
IsInList = False
EachDimTextPosition = EachDim.TextPosition
EachDistance = HCF4156_DistanceFromPoint2ToPoint1WithAngle(MainPoint, 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 i = LBound(ObjDimArr) To UBound(ObjDimArr)
Set EachDim = ObjDimArr(i)
EachDimTextPosition = EachDim.TextPosition
EachDistance = HCF4156_DistanceFromPoint2ToPoint1WithAngle(MainPoint, 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(MainPoint, Point12Angle, EachMoveSpace)
EachDim.TextPosition = NewTextPositon
EachDim.Update
End If
Next
End Function
Function HCF4167_Call_QuickCreatBlock_ModelSpace(MyDrawing As AcadDocument, ModelSpaceBlock As AcadBlock)
'Creat Array of obj
Dim EntityCount As Integer: EntityCount = MyDrawing.ModelSpace.Count
If EntityCount = 0 Then Exit Function
Dim ObjArr() As Object
Dim k As Integer
Dim EachEntity As AcadEntity
For Each EachEntity In MyDrawing.ModelSpace
ReDim Preserve ObjArr(0 To k)
Set ObjArr(k) = EachEntity
k = k + 1
Next
'Automatic Creat Blockname
Dim Blockname As String
Blockname = HCF4046_AutomaticCreatBlockname()
'Creat Block
Dim InsertPoint(0 To 2) As Double
Set ModelSpaceBlock = MyDrawing.Blocks.Add(InsertPoint, Blockname)
MyDrawing.CopyObjects ObjArr, ModelSpaceBlock
'Delete Old Entity
For Each EachEntity In MyDrawing.ModelSpace
EachEntity.Delete
Next
End Function
Sub HCS3083_QuickCreatBlockRef()
'(VBA AutoCad) Quick Creat Block,[QCB]
'Select Obj by SelectSet
Dim EntitySelect As AcadSelectionSet
Dim EachEntity As AcadEntity
Set EntitySelect = Thisdrawing.SelectionSets.Add("EntitySelect" & Now)
Thisdrawing.Utility.Prompt (vbCr & "Select objects to make block")
EntitySelect.SelectOnScreen
If EntitySelect.Count = 0 Then
EntitySelect.Delete
Exit Sub
End If
'Select InsertPoint
Dim InsertPoint As Variant
Dim Point00(0 To 2) As Double
InsertPoint = HCF4045_GetPoint(Thisdrawing, "Pick Insertion Point: ")
If Func70IsEmptyArray(InsertPoint) = True Then
EntitySelect.Delete
Exit Sub
End If
'Creat Array of obj
ReDim ObjArr(0 To EntitySelect.Count - 1) As Object
For Each EachEntity In EntitySelect
EachEntity.Move InsertPoint, Point00
Set ObjArr(i) = EachEntity
i = i + 1
Next
'Automatic Creat Blockname
Dim Blockname As String
Blockname = HCF4046_AutomaticCreatBlockname()
'Creat Block
Dim ObjBlock As AcadBlock
Set ObjBlock = Thisdrawing.Blocks.Add(Point00, Blockname)
Thisdrawing.CopyObjects ObjArr, ObjBlock
'Insert New Block
Dim ObjBlockRef As AcadBlockReference
Set ObjBlockRef = Thisdrawing.ModelSpace.InsertBlock(InsertPoint, Blockname, 1, 1, 1, 0)
'Delete Old Entity
For Each EachEntity In EntitySelect
EachEntity.Delete
Next
EntitySelect.Delete
End Sub
Sub HCS3124_QuickCreatSpline()
'(TB VBABoss) Quick Creat Spline,[QCSP]
'AddSpline(PointsArray, StartTangent, EndTangent) As AcadSpline
'Setting Spline Layer
Dim SplineLayername As String
Select Case ProjectName
Case "DFK"
SplineLayername = DFK_PhantomLayerName
Case "KKS"
SplineLayername = KKS_SlimLayerName
Case Else
SplineLayername = "0"
End Select
'Othor On
Thisdrawing.SetVariable "ORTHOMODE", 1
'Backup OSMODE
Dim BackupOsnap As Variant: BackupOsnap = HCF4113_SettingOsnap("Backup", "")
'Setting be rong Spline
Dim DimScale As Variant: DimScale = Thisdrawing.GetVariable("DIMSCALE")
Dim SplineWide As Double: SplineWide = 5 * DimScale
'Get Point1 of Spline, Z=0
Dim Point1 As Variant
Call HCF4113_SettingOsnap("Restore", 513) 'EndPoint or Nearest
Point1 = HCF4045_GetPoint(Thisdrawing, "Select Start Point of Spline:")
If Func70IsEmptyArray(Point1) = True Then
GoTo GoToExitSub
Else
Point1(2) = 0
End If
'Get Point2 of Spline
Dim Point2 As Variant
Call HCF4113_SettingOsnap("Restore", 129) 'EndPoint or Perpendicular
Point2 = HCF4106_GetSecondPoint(Thisdrawing, Point1, "Select End Point of Spline:")
If Func70IsEmptyArray(Point2) = True Then
GoTo GoToExitSub
Else
Point2(2) = 0
End If
'Define Angle From Point 1 to Point 2
Dim Point12Angle As Double: Point12Angle = Func23AngleOfLineThrough2Point(Point1, Point2)
Dim Pi As Double: Pi = 4 * Atn(1)
'Define Point3 is center of Point1 and Point2
Dim Point3 As Variant
Point3 = HCF4102_Middle2Point(Point1, Point2)
'Define Point4 is center of Point1 & Point3 With SplineWide
Dim Point4 As Variant
Point4 = HCF4102_Middle2Point(Point1, Point3)
Point4 = Thisdrawing.Utility.PolarPoint(Point4, Point12Angle + Pi / 2, SplineWide)
'Define Point5 is center of Point2 and Point3 with SplineWide
Dim Point5 As Variant
Point5 = HCF4102_Middle2Point(Point2, Point3)
Point5 = Thisdrawing.Utility.PolarPoint(Point5, Point12Angle + Pi / 2, -SplineWide)
'Creat PointsArray of Spline
Dim PointsArray(0 To 11) As Double
PointsArray(0) = Point1(0): PointsArray(1) = Point1(1): PointsArray(2) = 0
PointsArray(3) = Point4(0): PointsArray(4) = Point4(1): PointsArray(5) = 0
PointsArray(6) = Point5(0): PointsArray(7) = Point5(1): PointsArray(8) = 0
PointsArray(9) = Point2(0): PointsArray(10) = Point2(1): PointsArray(11) = 0
'Set StartTangent, EndTangent
Dim startTan(0 To 2) As Double
Dim endTan(0 To 2) As Double
' startTan(0) = 0.5: startTan(1) = 0.5: startTan(2) = 0
' endTan(0) = 0.5: endTan(1) = 0.5: endTan(2) = 0
'Add Spline
Dim ObjSpline As AcadSpline
Set ObjSpline = Thisdrawing.ModelSpace.AddSpline(PointsArray, startTan, endTan)
ObjSpline.Layer = SplineLayername
Thisdrawing.Regen acActiveViewport
GoToExitSub:
Call HCF4113_SettingOsnap("Restore", BackupOsnap)
End Sub
Sub HCS3125_DimArrange4Direction()
'(TB VBABoss) Dim Arrange 4 Direction Type,[DD4]
'System Setting
'Get DimScale
Dim DimScale As Variant: DimScale = Thisdrawing.GetVariable("DIMSCALE")
'DeltaDimSpace
Dim DeltaDimSpace As Double: DeltaDimSpace = 2 * DimScale
'Define DimSpace1,DimSpace2
Dim DimSpace0 As Integer: DimSpace0 = SettingDimSpace0
Dim DimSpace1 As Integer: DimSpace1 = SettingDimSpace1
DimSpace0 = DimScale * DimSpace0
DimSpace1 = DimScale * DimSpace1
'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 RotatedDim
Call HCF4159_Call_FilterOnlyRotatedDimInDimSelectSet(DimSelectSet)
If DimSelectSet.Count = 0 Then GoTo GoToExitSub
'Define MinPoint,MaxPoint From Selected ObjBlockRef
Dim GetObj() As Variant
Dim Obj As AcadEntity
Dim ObjBlockRef As AcadBlockReference
Dim GetMinMaxPoint As Variant
Dim MinPoint As Variant
Dim MaxPoint As Variant
GetObj = HCF4059_GetObj(Thisdrawing, "Select Obj to define MinPoint and MaxPoint For Arrange Dimension:")
If GetObj(0) = False Then
GoTo GoToSelect2Point
Else
Set Obj = GetObj(1)
If Obj.ObjectName = "AcDbBlockReference" Then
Set ObjBlockRef = Obj
GetMinMaxPoint = HCF4160_LimitPointOfBlockRef(ObjBlockRef)
If VarType(GetMinMaxPoint) = vbBoolean Then
GoTo GoToSelect2Point
Else
MinPoint = GetMinMaxPoint(0)
MaxPoint = GetMinMaxPoint(1)
GoTo GoToAfterSelect2Point
End If
Else
GoTo GoToSelect2Point
End If
End If
'''==============================='''
GoToSelect2Point:
Dim Get2Point As Variant
Dim MsgPoint1 As String: MsgPoint1 = "Select MinPoint for Arrange Dimension:"
Dim MsgPoint2 As String: MsgPoint2 = "Select MaxPoint for Arrange Dimension:"
Dim OsmodePoint1 As Integer: OsmodePoint1 = 97
Dim OsmodePoint2 As Integer: OsmodePoint2 = 97
Get2Point = HCF4162_Get2PointWithOSMODE(MsgPoint1, MsgPoint2, OsmodePoint1, OsmodePoint2, True)
If VarType(Get2Point) = vbBoolean Then
GoTo GoToExitSub
Else
MinPoint = Get2Point(0)
MaxPoint = Get2Point(1)
End If
GoToAfterSelect2Point:
'Confirm MinPoint, MaxPoint
Call HCF4164_Call_MinPointMaxPointFrom2Point(MinPoint, MaxPoint)
'Reset HomeText All Dim In SelectSet
Call HCF4146_Call_ResetHomeTextOfDimSelectSet(DimSelectSet)
'Define LeftArr,RightArr,UpArr,DownArr
Dim LeftArr() As AcadDimension
Dim RightArr() As AcadDimension
Dim UpArr() As AcadDimension
Dim DownArr() As AcadDimension
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim f As Integer
Dim EachDimDirection As String
Dim EachDim As AcadDimension
Dim GetProperty As Variant
For Each EachDim In DimSelectSet
EachDimDirection = HCF4165_DimPositionWithMinMaxPoint(EachDim, MinPoint, MaxPoint)
If EachDimDirection = "N/A" Then
GetProperty = HCF4143_GetProperty_RotatedDim_AlignedDim(EachDim, "")
EachDimDirection = GetProperty(7)
End If
Select Case EachDimDirection
Case "LEFT"
ReDim Preserve LeftArr(0 To i)
Set LeftArr(i) = EachDim
i = i + 1
Case "RIGHT"
ReDim Preserve RightArr(0 To j)
Set RightArr(j) = EachDim
j = j + 1
Case "UP"
ReDim Preserve UpArr(0 To k)
Set UpArr(k) = EachDim
k = k + 1
Case "DOWN"
ReDim Preserve DownArr(0 To f)
Set DownArr(f) = EachDim
f = f + 1
End Select
Next
'Arrange Dim
If i > 0 Then Call HCF4166X_ArrangeDimArr(LeftArr, "LEFT", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
If j > 0 Then Call HCF4166X_ArrangeDimArr(RightArr, "RIGHT", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
If k > 0 Then Call HCF4166X_ArrangeDimArr(UpArr, "UP", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
If f > 0 Then Call HCF4166X_ArrangeDimArr(DownArr, "DOWN", MinPoint, MaxPoint, DeltaDimSpace, DimSpace0, DimSpace1)
'Reset TextDimPosition
Call HCF4146_Call_ResetHomeTextOfDimSelectSet(DimSelectSet)
GoToExitSub:
DimSelectSet.Delete
Call HCF4153_Call_ResetCommandLine("DD4")
End Sub
Sub HCS3126_UpdateSelectedBlockFromOtherDrawing_Version2()
'(VBA AutoCad) Update Selected Block From Other Drawing,[UB2]
'Creat Opening File List
If AcadApplication.Documents.Count = 1 Then Exit Sub
Dim EachDocument As AcadDocument
For Each EachDocument In AcadApplication.Documents
ReDim Preserve OpeningFileArr(0 To k)
OpeningFileArr(k) = EachDocument.Name
k = k + 1
Next
'Select UpdateFrom, UpdateTo By Userform
UpdateBlockV2.show
If UB_UpdateFromDrawing = "" Or UB_UpdateToDrawing = "" Then
Exit Sub
Else
If UB_UpdateFromDrawing = UB_UpdateToDrawing Then
MsgBox "Err: CopyFromDrawing = CopyToDrawing"
Exit Sub
End If
End If
Dim UpdateFrom As AcadDocument
Dim UpdateTo As AcadDocument
For Each EachDocument In AcadApplication.Documents
Select Case EachDocument.Name
Case UB_UpdateFromDrawing
Set UpdateFrom = EachDocument
Case UB_UpdateToDrawing
Set UpdateTo = EachDocument
End Select
Next
'Creat BlockModelSpace of UpdateToDrawing
Dim UBTModelSpaceBlock As AcadBlock
Call HCF4167_Call_QuickCreatBlock_ModelSpace(UpdateTo, UBTModelSpaceBlock)
If UBTModelSpaceBlock Is Nothing Then Exit Sub
Dim UBTBlockname As String
UBTBlockname = UBTModelSpaceBlock.Name
'Purge UpdateFrom
Call HCF4040_PurgeMydrawing(UpdateFrom)
'Copy UBTModelSpaceBlock to UpdateFrom
Dim ObjArr(0) As Object
Set ObjArr(0) = UBTModelSpaceBlock
UpdateTo.CopyObjects ObjArr, UpdateFrom.ModelSpace
'Purge UpdateTo
Call HCF4040_PurgeMydrawing(UpdateTo)
'Copy ModelBlock From UpdateFrom To UpdateTo
Dim EachBlock As AcadBlock
For Each EachBlock In UpdateFrom.Blocks
If EachBlock.Name = UBTBlockname Then
Set ObjArr(0) = EachBlock
End If
Next
UpdateFrom.CopyObjects ObjArr, UpdateTo.ModelSpace
'Insert UBTModelSpaceBlock
Dim ObjBlockRef As AcadBlockReference
Dim InsertPoint(0 To 2) As Double
Set ObjBlockRef = UpdateTo.ModelSpace.InsertBlock(InsertPoint, UBTBlockname, 1, 1, 1, 0)
ObjBlockRef.Explode
ObjBlockRef.Delete
'Purge
Call HCF4040_PurgeMydrawing(UpdateTo)
Call HCF4040_PurgeMydrawing(UpdateFrom)
End Sub
Sub HCS3127_AddEntityIntoBlockRef()
'(TB VBABoss) Add Entity Into BlockRef,[AE2B]
'Select Entity
Dim EntitySS As AcadSelectionSet
Set EntitySS = Thisdrawing.SelectionSets.Add("EntitySS" & Now)
Thisdrawing.Utility.Prompt vbCrLf & "Select Entity for Add to Block Reference:"
EntitySS.SelectOnScreen
If EntitySS.Count = 0 Then
EntitySS.Delete
Exit Sub
End If
'Select BlockRef
Dim BlockRefSS As AcadSelectionSet
Set BlockRefSS = Thisdrawing.SelectionSets.Add("BlockRefSS" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
Thisdrawing.Utility.Prompt vbCrLf & "Select Block Reference:"
BlockRefSS.SelectOnScreen FT, FD
If BlockRefSS.Count <> 1 Then GoTo GoToExitSub
'Define ObjBlock, ObjBlockRef
Dim ObjBlockRef As AcadBlockReference
Dim ObjBlock As AcadBlock
Dim BlockInsertPoint As Variant
Dim BlockRefScale As Double
Set ObjBlockRef = BlockRefSS.Item(0)
BlockRefScale = ObjBlockRef.XScaleFactor
'Check Condition of ObjBlockRef
If Func64IsNormalBlock(ObjBlockRef) = False Then
MsgBox "Err:Selected Block Reference Isn't Normal Block Reference."
GoTo GoToExitSub
End If
If BlockRefScale <> 1 Then
MsgBox "Err:Selected Block Reference Scale <>1."
GoTo GoToExitSub
End If
Set ObjBlock = Thisdrawing.Blocks(ObjBlockRef.Name)
BlockInsertPoint = ObjBlockRef.InsertionPoint
'Remove ObjBlockRef In EntitySS
Dim RemoveArr() As AcadEntity
Dim EachEntity As AcadEntity
Dim m As Integer
For Each EachEntity In EntitySS
If EachEntity.Handle = ObjBlockRef.Handle Then
ReDim Preserve RemoveArr(0 To m)
Set RemoveArr(m) = EachEntity
m = m + 1
End If
Next
If m > 0 Then
EntitySS.RemoveItems RemoveArr
End If
If EntitySS.Count = 0 Then
MsgBox "Err: Can not add block 2 block."
GoTo GoToExitSub
End If
'Get CopyFromPoint, CopyToPoint
Dim Get2Point As Variant
Dim MsgPoint1 As String: MsgPoint1 = "Select Copy From Point:"
Dim MsgPoint2 As String: MsgPoint2 = "Select Copy To Point:"
Dim OsmodePoint1 As Integer: OsmodePoint1 = 16383
Dim OsmodePoint2 As Integer: OsmodePoint2 = 16383
Get2Point = HCF4162_Get2PointWithOSMODE(MsgPoint1, MsgPoint2, OsmodePoint1, OsmodePoint2, True)
Dim CopyFromPoint As Variant
Dim CopyToPoint As Variant
If VarType(Get2Point) = vbBoolean Then
GoTo GoToExitSub
Else
CopyFromPoint = Get2Point(0)
CopyToPoint = Get2Point(1)
End If
'Creat CopyObjArr
Dim CopyObjArr() As Object
Dim EachEntityCopy As AcadEntity
Dim Point00(0 To 2) As Double
For Each EachEntity In EntitySS
Set EachEntityCopy = EachEntity.Copy
EachEntityCopy.Move BlockInsertPoint, Point00
EachEntityCopy.Move CopyFromPoint, CopyToPoint
ReDim Preserve CopyObjArr(0 To k)
Set CopyObjArr(k) = EachEntityCopy
k = k + 1
Next
'Copy CopyObjArr to ObjBlock
Thisdrawing.CopyObjects CopyObjArr, ObjBlock
ObjBlockRef.Update
'Delect CopyObjArr
For i = LBound(CopyObjArr) To UBound(CopyObjArr)
Set EachEntity = CopyObjArr(i)
EachEntity.Delete
Next
GoToExitSub:
EntitySS.Delete
BlockRefSS.Delete
End Sub
Sub HCS3128_ReplaceBlockByBlock()
'(TB VBABoss) Replace Block By Block,[RBBB]
'Select ReplaceBlockFrom
Dim BlockRefSS As AcadSelectionSet
Set BlockRefSS = Thisdrawing.SelectionSets.Add("BlockRefSS" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
Thisdrawing.Utility.Prompt vbCrLf & "Select ReplaceBlockFrom:"
BlockRefSS.SelectOnScreen FT, FD
If BlockRefSS.Count <> 1 Then GoTo GoToExitSub
Dim ReplaceBlockFromRef As AcadBlockReference
Set ReplaceBlockFromRef = BlockRefSS.Item(0)
If Func64IsNormalBlock(ReplaceBlockFromRef) = False Then
MsgBox "Err:Selected Block Reference Isn't Normal Block Reference."
GoTo GoToExitSub
End If
Dim ReplaceBlockFrom_Scale As Double: ReplaceBlockFrom_Scale = ReplaceBlockFromRef.XScaleFactor
If ReplaceBlockFrom_Scale <> 1 Then
MsgBox "Err:Selected Block Reference Scale <>1."
GoTo GoToExitSub
End If
Dim ReplaceBlockFrom As AcadBlock: Set ReplaceBlockFrom = Thisdrawing.Blocks(ReplaceBlockFromRef.Name)
Dim ReplaceBlockFrom_InsertPoint As Variant: ReplaceBlockFrom_InsertPoint = ReplaceBlockFromRef.InsertionPoint
'Select ReplaceBlockTo
BlockRefSS.Clear
Thisdrawing.Utility.Prompt vbCrLf & "Select ReplaceBlockTo:"
BlockRefSS.SelectOnScreen FT, FD
If BlockRefSS.Count <> 1 Then GoTo GoToExitSub
Dim ReplaceBlockToRef As AcadBlockReference: Set ReplaceBlockToRef = BlockRefSS.Item(0)
If Func64IsNormalBlock(ReplaceBlockToRef) = False Then
MsgBox "Err:Selected Block Reference Isn't Normal Block Reference."
GoTo GoToExitSub
End If
Dim ReplaceBlockTo_Scale As Double: ReplaceBlockTo_Scale = ReplaceBlockToRef.XScaleFactor
If ReplaceBlockTo_Scale <> 1 Then
MsgBox "Err:Selected Block Reference Scale <>1."
GoTo GoToExitSub
End If
Dim ReplaceBlockTo As AcadBlock: Set ReplaceBlockTo = Thisdrawing.Blocks(ReplaceBlockToRef.Name)
Dim ReplaceBlockTo_InsertPoint As Variant: ReplaceBlockTo_InsertPoint = ReplaceBlockToRef.InsertionPoint
'Check ReplaceBlockFromRef=ReplaceBlockToRef
If ReplaceBlockFromRef.Name = ReplaceBlockTo.Name Then
MsgBox "Err: ReplaceBlockFromRef.Name = ReplaceBlockTo.Name"
GoTo GoToExitSub
End If
'Get ReplaceFromPoint, ReplaceToPoint
Dim Get2Point As Variant
Dim MsgPoint1 As String: MsgPoint1 = "Select Replace From Point:"
Dim MsgPoint2 As String: MsgPoint2 = "Select Replace To Point:"
Dim OsmodePoint1 As Integer: OsmodePoint1 = 16383
Dim OsmodePoint2 As Integer: OsmodePoint2 = 16383
Get2Point = HCF4162_Get2PointWithOSMODE(MsgPoint1, MsgPoint2, OsmodePoint1, OsmodePoint2, True)
Dim ReplaceFromPoint As Variant
Dim ReplaceToPoint As Variant
If VarType(Get2Point) = vbBoolean Then
GoTo GoToExitSub
Else
ReplaceFromPoint = Get2Point(0)
ReplaceToPoint = Get2Point(1)
End If
'Delete All Entity in ReplaceToBlock
Dim EachEntity As AcadEntity
For Each EachEntity In ReplaceBlockTo
EachEntity.Delete
Next
'Explode ReplaceBlockFromRef
Dim ExplodeArr As Variant
ExplodeArr = ReplaceBlockFromRef.Explode
'Creat CopyObjArr
Dim CopyObjArr() As Object
Dim Point00(0 To 2) As Double
For i = LBound(ExplodeArr) To UBound(ExplodeArr)
Set EachEntity = ExplodeArr(i)
EachEntity.Move ReplaceBlockTo_InsertPoint, Point00
EachEntity.Move ReplaceFromPoint, ReplaceToPoint
ReDim Preserve CopyObjArr(0 To k)
Set CopyObjArr(k) = EachEntity
k = k + 1
Next
'Copy CopyObjArr to ReplaceBlockFrom
Thisdrawing.CopyObjects CopyObjArr, ReplaceBlockTo
ReplaceBlockToRef.Update
'Delect CopyObjArr,ExplodeArr
For i = LBound(CopyObjArr) To UBound(CopyObjArr)
Set EachEntity = CopyObjArr(i)
EachEntity.Delete
Next
GoToExitSub:
BlockRefSS.Delete
End Sub