- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
VBA Arrange Dimensions
Hello,
I need help about dimensions that i mentioned at below picture.
How can i arrange dimensions as second situation with VBA? (Inventor 2019)
Thanks
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello,
I think you can use this. This is auto arrange but only the linear dimensions.
Dim oDoc As DrawingDocument oDoc = ThisDoc.Document ' Set a reference to the active sheet Dim oSheet As Sheet oSheet = oDoc.ActiveSheet Dim oDrawingDim As DrawingDimension Dim oDrawingDims As DrawingDimensions Dim oDimsToBeArranged As ObjectCollection ' Iterate over all dimensions in the drawing and ' center them if they are linear or angular. ' Add them to the ObjectCollection to be arranged oDrawingDimensions = oSheet.DrawingDimensions oDimsToBeArranged = ThisApplication.TransientObjects.CreateObjectCollection For Each oDrawingDim In oDrawingDimensions If TypeOf oDrawingDim Is LinearGeneralDimension Then oDrawingDim.CenterText oDimsToBeArranged.Add(oDrawingDim) End If Next If oDimsToBeArranged.Count > 0 Then oDrawingDimensions.Arrange(oDimsToBeArranged) End If
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
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")
)
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
There is also this one I found I don't know where.. :
Dim oDimensions As DrawingDimensions = ActiveSheet.Sheet.DrawingDimensions Dim oCol As ObjectCollection = ThisApplication.TransientObjects.CreateObjectCollection For Each oDim As DrawingDimension In oDimensions oCol.Add(oDim) Next oDimensions.Arrange(oCol) For Each oDim As DrawingDimension In oCol On Error Resume Next oDim.CenterText Next
Regards,
FINET L.
If this post solved your question, please kindly mark it as "Solution"
If this post helped out in any way to solve your question, please drop a "Like"- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
You said you wanted the solution to be in VBA instead of iLogic right. Well here's the VBA macro I sometimes use for arranging dimensions and re-centering dimension text. I hope you can get some use out of it too.
Sub Center_ArrangeAllDims()
If ThisApplication.ActiveDocumentType <> DocumentTypeEnum.kDrawingDocumentObject Then
Call MsgBox("This rule only works for Drawing Documents.", vbOKOnly, "WRONG DOCUMENT TYPE")
Exit Sub
End If
Dim oDDoc As DrawingDocument
Set oDDoc = ThisApplication.ActiveDocument
Dim oSheet As Inventor.Sheet
Set oSheet = oDDoc.ActiveSheet
Dim oDDims As DrawingDimensions
Set oDDims = oSheet.DrawingDimensions
Dim oDDim As DrawingDimension
For Each oDDim In oDDims
If TypeOf oDDim Is LinearGeneralDimension Or _
TypeOf oDDim Is AngularGeneralDimension Then
Call oDDim.CenterText
End If
Next
Dim oBaselineDimSet As BaselineDimensionSet
For Each oBaselineDimSet In oDDims.BaselineDimensionSets
Call oBaselineDimSet.ArrangeText
Next
Dim oChainDimSet As ChainDimensionSet
For Each oChainDimSet In oDDims.ChainDimensionSets
Call oChainDimSet.Arrange(oChainDimSet.Members.Item(1))
Next
Dim oCollection As ObjectCollection
Set oCollection = ThisApplication.TransientObjects.CreateObjectCollection
'Dim oLinGenDim As LinearGeneralDimension
Dim oGenDim As GeneralDimension
For Each oGenDim In oDDims.GeneralDimensions
If TypeOf oGenDim Is LinearGeneralDimension Then
Call oCollection.Add(oGenDim)
End If
Next
If oCollection.Count > 1 Then
Call oDDims.Arrange(oCollection)
End If
End Sub
If this solved your problem, or answered your question, please click ACCEPT SOLUTION.
Or, if this helped you, please click (LIKE or KUDOS)
.
If you want and have time, I would appreciate your Vote(s) for My IDEAS
or you can Explore My CONTRIBUTIONS
Wesley Crihfield
(Not an Autodesk Employee)
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
'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
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
;(TB VBABoss) Replace Block By Block,[RBBB]
(defun C:RBBB()
(command "-vbarun" "HCS3128_ReplaceBlockByBlock")
)
;(TB VBABoss) Add Entity Into BlockRef,[AE2B]
(defun C:AE2B()
(command "-vbarun" "HCS3127_AddEntityIntoBlockRef")
)
;(VBA AutoCad) Update Selected Block From Other Drawing,[UB2]
(defun C:UB2()
(command "-vbarun" "HCS3126_UpdateSelectedBlockFromOtherDrawing_Version2")
)
;(TB VBABoss) Dim Arrange 4 Direction Type,[DD4]
(defun C:DD4()
(command "-vbarun" "HCS3125_DimArrange4Direction")
)
;(TB VBABoss) Quick Creat Spline,[QCSP]
(defun C:QCSP()
(command "-vbarun" "HCS3124_QuickCreatSpline")
)
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
'Setting Sheetname
Public Const DBSheetname As String = "ƒf[ƒ^ƒx[ƒX"
Public Const StaffManagerSheetname As String = "lˆõŠÇ—"
Public Const ProjectSheetname As String = "ˆÄŒŠÇ—"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function HCF4079_DefineRowEndNo(WS As Worksheet, EndRow As Integer, ColumnNo As Integer)
EndRow = WS.Cells(Rows.Count, ColumnNo).End(xlUp).Row
End Function
Function Func29ConvertColumnLetterToNumber(ColumnLetter As String) As Integer
' Function chuyen ma so cot tu letter sang number
'Convert To Column Number
Dim ColumnNumber As Long
ColumnNumber = Range(ColumnLetter & 1).Column
Func29ConvertColumnLetterToNumber = ColumnNumber
End Function
Function HCF4086_IsInArr2Chieu_NumberOrString(ListArr As Variant, ListColumnNo As Integer, NeedCheckValue As Variant) As Boolean
Dim CompareValue As Variant
For i = LBound(ListArr) To UBound(ListArr)
CompareValue = ListArr(i, ListColumnNo)
If CompareValue = NeedCheckValue Then
HCF4086_IsInArr2Chieu_NumberOrString = True
Exit Function
End If
Next
End Function
Function HCF4060_GetStringMiddle2Delimited(Str As String, Delimited1 As String, Delimited2 As String) As String
Dim Result As String
Dim Delimited1Position As Integer
Dim Delimited2Position As Integer
Delimited1Position = InStr(Str, Delimited1)
Delimited2Position = InStr(Str, Delimited2)
If Delimited1Position * Delimited2Position = 0 Then Exit Function
Result = Mid(Str, Delimited1Position + 1, Delimited2Position - Delimited1Position - 1)
HCF4060_GetStringMiddle2Delimited = Result
End Function
Function HCF4117_VlookupInArr2Dimension_NumberOrString(ListArr As Variant, CheckColumnNo As Integer, ResultColumnNo As Integer, CheckValue As Variant) As Variant
Dim CompareValue As Variant
Dim StrCheckValue As String: StrCheckValue = CStr(CheckValue)
Dim Result As Variant
If HCF4116_IsTwoDimensionalArray(ListArr) = False Then
HCF4117_VlookupInArr2Dimension_NumberOrString = False
Exit Function
End If
For i = LBound(ListArr) To UBound(ListArr)
CompareValue = ListArr(i, CheckColumnNo)
CompareValue = CStr(CompareValue)
If CompareValue = StrCheckValue Then
Result = ListArr(i, ResultColumnNo)
End If
Next
If VarType(Result) = vbEmpty Then Result = False
HCF4117_VlookupInArr2Dimension_NumberOrString = Result
End Function
Function HCF4047_Convert2Integer(InputValue As Variant) As Variant
Dim OutputValue As Variant
On Error Resume Next
OutputValue = CInt(InputValue)
If Err Then
OutputValue = False
Else
OutputValue = CInt(InputValue)
If OutputValue - InputValue <> 0 Then OutputValue = False
End If
HCF4047_Convert2Integer = OutputValue
End Function
Function HCF4048_Convert2Double(InputValue As Variant) As Variant
Dim OutputValue As Variant
On Error Resume Next
OutputValue = CDbl(InputValue)
If Err Then
OutputValue = False
Else
OutputValue = CDbl(InputValue)
End If
HCF4048_Convert2Double = OutputValue
End Function
Function HCF4116_IsTwoDimensionalArray(Arr As Variant) As Boolean
Dim i As Integer
On Error GoTo ExitFunction
i = UBound(Arr, 2)
HCF4116_IsTwoDimensionalArray = True
ExitFunction:
End Function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function TBFH100_GetFilePath(FileFilter As String, Title As String, MultiSelectMode As Boolean) As Variant
Dim fnameList As Variant
fnameList = Application.GetOpenFilename(FileFilter, , Title, , MultiSelectMode)
If (vbBoolean = VarType(fnameList)) Then
MsgBox "No files selected"
TBFH100_GetFilePath = False
Else
TBFH100_GetFilePath = fnameList
End If
End Function
Function TBFH102_CrearArrFromRange(WS As Worksheet, MainColumnLetter As String, ColumnFromLetter As String, ColumnToLetter As String, RowFrom As Integer) As Variant
' Tao mang 2 chieu tu Range
Dim Arr() As Variant
'Define Column no
Dim ColumnFromNo As Integer
Dim ColumnToNo As Integer
Dim MainColumnNo As Integer
ColumnFromNo = Func29ConvertColumnLetterToNumber(ColumnFromLetter)
ColumnToNo = Func29ConvertColumnLetterToNumber(ColumnToLetter)
MainColumnNo = Func29ConvertColumnLetterToNumber(MainColumnLetter)
'Define EndRow no, neu k co du lieu thi thoat
Dim EndRow As Integer
EndRow = WS.Cells(Rows.Count, MainColumnNo).End(xlUp).Row
If EndRow < RowFrom Then Exit Function
'Define Arr TotalColumn va TotalRow
Dim ArrTotalColumn As Integer
Dim ArrTotalRow As Integer
Dim ArrColumn As Integer
Dim ArrRow As Integer
Dim TmpValue As String
ArrTotalColumn = ColumnToNo - ColumnFromNo
ArrTotalRow = EndRow - RowFrom
ReDim Arr(0 To ArrTotalRow, 0 To ArrTotalColumn)
For i = RowFrom To EndRow
ArrRow = i - RowFrom
For k = ColumnFromNo To ColumnToNo
ArrColumn = k - ColumnFromNo
TmpValue = WS.Cells(i, k).Value
Arr(ArrRow, ArrColumn) = TmpValue
Next
Next
TBFH102_CrearArrFromRange = Arr
End Function
Function TBFH103_Call_CreatStaffManagerArr(StaffManagerArr As Variant)
Dim StaffWS As Worksheet: Set StaffWS = ThisWorkbook.Sheets(StaffManagerSheetname)
StaffManagerArr = TBFH102_CrearArrFromRange(StaffWS, "C", "A", "G", 2)
End Function
Function TBFH104_DefineMonthFromExcelFilePath(ExcelFilePath As String) As String
Dim MonthValue As String
Dim Delimited1 As String: Delimited1 = "."
Dim Delimited2 As String: Delimited2 = "ŒŽ"
MonthValue = HCF4060_GetStringMiddle2Delimited(ExcelFilePath, Delimited1, Delimited2)
TBFH104_DefineMonthFromExcelFilePath = MonthValue
End Function
Function TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(LookupValue As String, FromPC_FromID_FromName_Mode As String, PC_ID_SName_GName_GNo_TeamName_TeamNo_Mode As String) As String
'Creat StaffManagerArr
Dim StaffManagerArr As Variant
Call TBFH103_Call_CreatStaffManagerArr(StaffManagerArr)
'Define CheckColumnNo
Dim CheckColumnNo As Integer
Select Case FromPC_FromID_FromName_Mode
Case "FromPC"
CheckColumnNo = 0
Case "FromID"
CheckColumnNo = 1
Case "FromName"
CheckColumnNo = 2
End Select
'Define ResultColumnNo
Dim ResultColumnNo As Integer
Select Case PC_ID_SName_GName_GNo_TeamName_TeamNo_Mode
Case "PC"
ResultColumnNo = 0
Case "ID"
ResultColumnNo = 1
Case "SName"
ResultColumnNo = 2
Case "GName"
ResultColumnNo = 3
Case "GNo"
ResultColumnNo = 4
Case "TeamName"
ResultColumnNo = 5
Case "TeamNo"
ResultColumnNo = 6
Case Else
Exit Function
End Select
'Result
Dim Result As Variant
Result = HCF4117_VlookupInArr2Dimension_NumberOrString(StaffManagerArr, CheckColumnNo, ResultColumnNo, LookupValue)
If VarType(Result) <> vbBoolean Then
TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName = Result
End If
End Function
Function TBFH106_GetProjectInformationFromProjectName(ProjectName As String, ProjectCode_CustomerName_GNo_TNo_1to12_Mode) As String
'Creat ProjectManagerArr
Dim ProjectManagerArr As Variant
Call TBFH107_Call_CreatProjectManagerArr(ProjectManagerArr)
'Define CheckColumnNo
Dim CheckColumnNo As Integer: CheckColumnNo = 2
'Define ResultColumnNo
Dim ResultColumnNo As Integer
Dim Convert2Integer As Variant
Select Case ProjectCode_CustomerName_GNo_TNo_1to12_Mode
Case "ProjectCode"
ResultColumnNo = 0
Case "CustomerName"
ResultColumnNo = 1
Case "GNo"
ResultColumnNo = 3
Case "TNo"
ResultColumnNo = 4
Case Else
Convert2Integer = HCF4047_Convert2Integer(ProjectCode_CustomerName_GNo_TNo_1to12_Mode)
If VarType(Convert2Integer) = vbBoolean Then
Exit Function
Else
If Convert2Integer < 1 Or Convert2Integer > 12 Then
Exit Function
Else
ResultColumnNo = Convert2Integer + 4
End If
End If
End Select
'Result
Dim Result As Variant
Result = HCF4117_VlookupInArr2Dimension_NumberOrString(ProjectManagerArr, CheckColumnNo, ResultColumnNo, ProjectName)
If VarType(Result) <> vbBoolean Then
TBFH106_GetProjectInformationFromProjectName = Result
End If
End Function
Function TBFH107_Call_CreatProjectManagerArr(ProjectManagerArr As Variant)
Dim ProjectWS As Worksheet: Set ProjectWS = ThisWorkbook.Sheets(ProjectSheetname)
ProjectManagerArr = TBFH102_CrearArrFromRange(ProjectWS, "C", "A", "Q", 2)
End Function
Function TBFH108_CheckRangeIsEmpty(WS As Worksheet, RowNo As Integer, ColumnFrom As Integer, ColumnTo As Integer) As Boolean
Dim RangeValue As String
Dim EachValue As String
For i = ColumnFrom To ColumnTo
EachValue = WS.Cells(RowNo, i).Value
RangeValue = RangeValue & EachValue
Next
If RangeValue = "" Then
TBFH108_CheckRangeIsEmpty = True
Else
TBFH108_CheckRangeIsEmpty = False
End If
End Function
Function TBFH109_Call_LockUnLockRange(WS As Worksheet, RowFrom As Integer, RowTo As Integer, ColumnLetterFrom As String, ColumnLetterTo As String, LockMode As Boolean)
Dim LockRange As Range
Set LockRange = WS.Range(ColumnLetterFrom & RowFrom & ":" & ColumnLetterTo & RowTo)
'unlock all
WS.Unprotect
WS.Cells.Locked = False
LockRange.Locked = LockMode
WS.Protect
End Function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub TBS100_GetOldDataIntoDatabase()
Application.ScreenUpdating = False
Application.EnableEvents = False
'Setting
Dim ToWB As Workbook: Set ToWB = ThisWorkbook
Dim ToWS As Worksheet: Set ToWS = ToWB.Sheets(DBSheetname)
Dim StaffWS As Worksheet: Set StaffWS = ToWB.Sheets(StaffManagerSheetname)
'Creat StaffManagerArr
Dim StaffManagerArr As Variant
Call TBFH103_Call_CreatStaffManagerArr(StaffManagerArr)
'Get Files
Dim GetFiles As Variant
Dim FileFilter As String: FileFilter = "Excel Files (*.xls),*.xls"
Dim Title As String: Title = "Choose Excel files"
Dim MultiSelectMode As Boolean: MultiSelectMode = True
GetFiles = TBFH100_GetFilePath(FileFilter, Title, True)
If VarType(GetFiles) = vbBoolean Then GoTo GotoExitSub
Dim FromWSData() As Variant
Dim FromWSDataRowNo As Integer
For i = LBound(GetFiles) To UBound(GetFiles)
'Open File
Dim FromWSEachRowData(1 To 40) As String
Dim FromWBPath As String: FromWBPath = GetFiles(i)
Dim FromWB As Workbook: Set FromWB = Workbooks.Open(FromWBPath, , True)
Dim FromWS As Worksheet
Dim FromSheetname As String
Dim FromEndRow As Integer
Dim IsStaffName As Boolean
Dim MonthValue As String: MonthValue = TBFH104_DefineMonthFromExcelFilePath(FromWBPath): FromWSEachRowData(1) = MonthValue
Dim GroupValue As String
Dim TeamValue As String
Dim StaffID As String
Dim StaffName As String
Dim ProjectCode As String
Dim CustomerName As String
Dim ProjectName As String
Dim FromWSEndRow As Integer
For Each FromWS In FromWB.Sheets
FromSheetname = FromWS.Name
'Check FromSheetname is Staff Name
IsStaffName = HCF4086_IsInArr2Chieu_NumberOrString(StaffManagerArr, 2, FromSheetname)
If IsStaffName = False Then GoTo GoToExitLoop
StaffName = FromSheetname
GroupValue = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "GNo")
TeamValue = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "TeamNo")
StaffID = TBFH105_GetStaffInformationFromPCNo_StaffID_StaffName(StaffName, "FromName", "ID")
FromWSEachRowData(2) = GroupValue
FromWSEachRowData(3) = TeamValue
FromWSEachRowData(4) = StaffID
FromWSEachRowData(5) = StaffName
'Define FromWSEndRow
Call HCF4079_DefineRowEndNo(FromWS, FromWSEndRow, 34)
If FromWSEndRow <= 3 Then GoTo GoToExitLoop
FromWSEndRow = FromWSEndRow - 2
'Define EachSheetData
Dim CheckRowValue As String
For f = 4 To FromWSEndRow
CheckRowValue = FromWS.Cells(f, 34).Value
If CheckRowValue <> "" Then
ProjectName = FromWS.Cells(f, 2).Value
ProjectCode = TBFH106_GetProjectInformationFromProjectName(ProjectName, "ProjectCode")
CustomerName = TBFH106_GetProjectInformationFromProjectName(ProjectName, "CustomerName")
If CustomerName = "" Then CustomerName = FromWS.Cells(f, 1).Value
FromWSEachRowData(6) = ProjectCode
FromWSEachRowData(7) = CustomerName
FromWSEachRowData(8) = ProjectName
For k = 3 To 34
FromWSEachRowData(k + 6) = FromWS.Cells(f, k).Value
Next
ReDim Preserve FromWSData(0 To FromWSDataRowNo)
FromWSData(FromWSDataRowNo) = FromWSEachRowData
FromWSDataRowNo = FromWSDataRowNo + 1
End If
Next
'Write ChuuKiRan
Dim ChuuKiRanIsEmpty As Boolean
Dim ChuuKiRanRowNo As Integer: ChuuKiRanRowNo = FromWSEndRow + 4
ChuuKiRanIsEmpty = TBFH108_CheckRangeIsEmpty(FromWS, ChuuKiRanRowNo, 3, 34)
If ChuuKiRanIsEmpty = False Then
FromWSEachRowData(6) = ""
FromWSEachRowData(7) = ""
FromWSEachRowData(8) = FromWS.Cells(ChuuKiRanRowNo, 2).Value
For k = 3 To 34
FromWSEachRowData(k + 6) = FromWS.Cells(ChuuKiRanRowNo, k).Value
Next
ReDim Preserve FromWSData(0 To FromWSDataRowNo)
FromWSData(FromWSDataRowNo) = FromWSEachRowData
FromWSDataRowNo = FromWSDataRowNo + 1
End If
'Write KinTai
Dim KinTaiRowNo As Integer: KinTaiRowNo = FromWSEndRow + 5
FromWSEachRowData(6) = ""
FromWSEachRowData(7) = ""
FromWSEachRowData(8) = FromWS.Cells(KinTaiRowNo, 2).Value
For k = 3 To 34
FromWSEachRowData(k + 6) = FromWS.Cells(KinTaiRowNo, k).Value
Next
ReDim Preserve FromWSData(0 To FromWSDataRowNo)
FromWSData(FromWSDataRowNo) = FromWSEachRowData
FromWSDataRowNo = FromWSDataRowNo + 1
GoToExitLoop:
Next
FromWB.Close False
Next
'Write FromWSData to DataBase
If FromWSDataRowNo = 0 Then GoTo GotoExitSub
'Define WriteRowFrom
Dim WriteRowFrom As Integer
Call HCF4079_DefineRowEndNo(ToWS, WriteRowFrom, 1)
WriteRowFrom = WriteRowFrom + 1
Dim EachRowData As Variant
Dim EachValue As String
For i = LBound(FromWSData) To UBound(FromWSData)
EachRowData = FromWSData(i)
For k = LBound(EachRowData) To UBound(EachRowData)
EachValue = EachRowData(k)
If EachValue <> "" Then
ToWS.Cells(WriteRowFrom, k) = EachRowData(k)
End If
Next
WriteRowFrom = WriteRowFrom + 1
Next
GotoExitSub:
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Finish"
End Sub
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Private Sub ButtonCancel_Click()
UB_UpdateFromDrawing = ""
UB_UpdateToDrawing = ""
Unload Me
End Sub
Private Sub ButtonYes_Click()
UB_UpdateFromDrawing = CB_UpdateFromDrawing.Value
UB_UpdateToDrawing = CB_UpdateToDrawing.Value
Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then Cancel = True
End Sub
Private Sub UserForm_Initialize()
For i = LBound(OpeningFileArr) To UBound(OpeningFileArr)
CB_UpdateFromDrawing.AddItem OpeningFileArr(i)
Next
For i = LBound(OpeningFileArr) To UBound(OpeningFileArr)
CB_UpdateToDrawing.AddItem OpeningFileArr(i)
Next
UpdateBlockV2.Caption = "(TB) Update Block From Other Drawing V2.0"
CB_UpdateFromDrawing.Value = OpeningFileArr(0)
CB_UpdateToDrawing.Value = OpeningFileArr(0)
End Sub