Option Explicit
'*************************************************************************************************
Dim i As Integer '全局計數(shù)變量
'*************************************************************************************************
'創(chuàng)建選擇集******************************************************創(chuàng)建選擇集*************************
'
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet
'返回一個空白選擇集
Dim SS As AcadSelectionSet
On Error Resume Next
Set SS = ThisDrawing.SelectionSets(ssName)
If Err Then Set SS = ThisDrawing.SelectionSets.Add(ssName)
SS.Clear
Set CreateSelectionSet = SS
End Function
'***********************************************************************************************************************************
'選擇集過濾器*****************************************************選擇集過濾器******************************************************
'
Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
'用數(shù)組方式填充一對變量以用作為選擇集過濾器使用
Dim FType() As Integer, FData()
Dim Index As Long, i As Long
Index = LBound(gCodes) - 1
For i = LBound(gCodes) To UBound(gCodes) Step 2
Index = Index + 1
ReDim Preserve FType(0 To Index) '改變數(shù)組上線，用可選參數(shù)preserve保持原數(shù)組不變。
ReDim Preserve FData(0 To Index)
FType(Index) = CInt(gCodes(i))
FData(Index) = gCodes(i + 1)
Next
typeArray = FType: dataArray = FData
End Sub
'***********************************************************************************************************************************
'獲得文件路徑***********************************************獲得文件路徑***************************************************************
Public Function GetPath() As String
On Error Resume Next '有一種錯誤可能是，新建的dvb工程沒有保存
'獲得Cad安裝路徑
'MsgBox Application.FullName & Application.Path
'獲得當前的工程路徑
Dim StrPath, i As Integer, J As Integer, temp As String
'MsgBox ThisDrawing.Application.VBE.VBProjects.Count
For i = 1 To ThisDrawing.Application.VBE.VBProjects.Count
'StrPath = ThisDrawing.Application.VBE.ActiveVBProject.FileName
StrPath = ThisDrawing.Application.VBE.VBProjects(i).FileName
'解析工具欄按鈕圖標路徑
For J = Len(StrPath) To 1 Step -1
temp = Mid(StrPath, J, 1)
If temp = "/" Or temp = "\" Then Exit For
Next J
'MsgBox UCase(Right(StrPath, Len(StrPath) - j))
If UCase(Right(StrPath, Len(StrPath) - J)) = "TIANCAOCADTOOLS.DVB" Then
GetPath = Left(StrPath, J)
Exit For
End If
Next i
'StrPath = ThisDrawing.Application.VBE.ActiveVBProject.FileName
'解析工具欄按鈕圖標路徑
'For j = Len(StrPath) To 1 Step -1
'temp = Mid(StrPath, j, 1)
'If temp = "/" Or temp = "\" Then Exit For
'Next j
'GetPath = Left(StrPath, i)
End Function
'計算兩條直線的交點
'若直線方程為|a1x + b1y + c1 = 0
'''''''''''''|a2x + b2y + c2 = 0
Public Function GetPtIntersect(ByVal A1 As Double, ByVal B1 As Double, ByVal C1 As Double, _
ByVal A2 As Double, B2 As Double, C2 As Double) As Variant
'輸入第一條直線和第二條直線方程的系數(shù)，輸出交點的坐標
Dim dlt As Double, dx As Double, dy As Double
Dim x As Double, y As Double '用于輸出
Dim pt(0 To 2) As Double
'計算矩陣的值
dlt = A1 * B2 - A2 * B1
dx = C1 * B2 - C2 * B1
dy = A1 * C2 - A2 * C1
'錯誤處理：如果兩者平行
If (Abs(dlt) < 0.00000001) Then
If (Abs(dx) < 0.00000001 And Abs(dy) < 0.00000001) Then
x = 1E+20
y = 1E+20
Else
x = -1E+20
y = -1E+20
End If
Else
x = -dx / dlt
y = -dy / dlt
End If
pt(0) = x: pt(1) = y: pt(2) = 0
GetPtIntersect = pt
End Function
'計算兩條直線的交點
'已知每條直線的一點和斜率
Public Function GetPtIntersectKP(ByVal k1 As Double, ByVal Pt1 As Variant, _
ByVal k2 As Double, ByVal Pt2 As Variant) As Variant
Dim A1 As Double, B1 As Double, C1 As Double
Dim A2 As Double, B2 As Double, C2 As Double
'計算直線方程系數(shù)
A1 = k1: B1 = -1: C1 = Pt1(1) - k1 * Pt1(0)
A2 = k2: B2 = -1: C2 = Pt2(1) - k2 * Pt2(0)
'調用GetPtIntersect函數(shù)
GetPtIntersectKP = GetPtIntersect(A1, B1, C1, A2, B2, C2)
End Function
'計算兩點之間距離
Public Function P2PDistance(sp As Variant, ep As Variant) As Double
Dim x As Double
Dim y As Double
Dim Z As Double
Dim Distance As Double
x = sp(0) - ep(0)
y = sp(1) - ep(1)
Z = sp(2) - ep(2)
P2PDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (Z ^ 2))
End Function
'獲得相對已知點偏移一定距離的點
Public Function GetPoint(pt As Variant, x As Double, y As Double) As Variant
Dim ptTarget(0 To 2) As Double
ptTarget(0) = pt(0) + x
ptTarget(1) = pt(1) + y
ptTarget(2) = 0
GetPoint = ptTarget
End Function
'已知一點，另一點相對于該點的極角(弧度)和極軸長度，求另一點的位置
Public Function GetPointAR(ByVal ptBase As Variant, ByVal Angle As Double, ByVal Length As Double) As Variant
Dim pt(0 To 2) As Double
pt(0) = ptBase(0) + Length * Cos(Angle)
pt(1) = ptBase(1) + Length * Sin(Angle)
pt(2) = ptBase(2)
GetPointAR = pt
End Function
'圓心、起點和終點
Public Function AddArcCSEP(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal ptEn As Variant) As AcadArc
Dim objArc As AcadArc
Dim radius As Double
Dim stAng, enAng As Double
'計算半徑
radius = P2PDistance(ptCen, ptSt)
'計算起點角度和終點角度
stAng = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSt)
enAng = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptEn)
Set objArc = ThisDrawing.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
objArc.Update
Set AddArcCSEP = objArc
End Function
'***********************************************************************************************************************************
'圓心、直徑方法繪制圓***********************************************圓心、直徑方法繪制圓*********************************************************
'圓心、直徑方法
Public Function AddCircleCD(ByVal ptCen As Variant, ByVal diameter As Variant) As AcadCircle
Dim objCir As AcadCircle
Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, diameter / 2)
Set AddCircleCD = objCir
End Function
'***********************************************************************************************************************************
'兩點法繪制圓***********************************************兩點法繪制圓*********************************************************
'兩點法
Public Function AddCircle2P(ByVal Pt1 As Variant, ByVal Pt2 As Variant) As AcadCircle
Dim ptCen(0 To 2) As Double
Dim objCir As AcadCircle
Dim diameter As Double
'獲得圓心位置
ptCen(0) = (Pt1(0) + Pt2(0)) / 2
ptCen(1) = (Pt1(1) + Pt2(1)) / 2
ptCen(2) = 0
'獲得直徑
diameter = Sqr((Pt2(0) - Pt1(0)) ^ 2 + (Pt2(1) - Pt1(1)) ^ 2)
Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, diameter / 2)
'返回值
Set AddCircle2P = objCir
End Function
'***********************************************************************************************************************************
'三點法繪制圓***********************************************三點法繪制圓*********************************************************
'三點法
'算法基礎
'/* +-----------------------------------------------------------------+ */
'/* | The equation of a arc based on 3 points is : | */
'/* | | X**2+Y**2-x1**2-y1**2 X-X1 Y-y1 | | */
'/* | | | | */
'/* | | x1**2+y1**2-x2**2-y2**2 x1-x2 y1-y2 | = 0 | */
'/* | | | | */
'/* | | x2**2+y2**2-x3**2-y3**2 x2-x3 y2-y3 | | */
'/* | | */
'/* +-----------------------------------------------------------------+ */
Public Function AddCircle3P(ByVal Pt1 As Variant, ByVal Pt2 As Variant, ByVal Pt3 As Variant) As AcadCircle
Dim xysm, xyse, xy As Double
Dim ptCen(0 To 2) As Double
Dim radius As Double
Dim objCir As AcadCircle
xy = Pt1(0) ^ 2 + Pt1(1) ^ 2
xyse = xy - Pt3(0) ^ 2 - Pt3(1) ^ 2
xysm = xy - Pt2(0) ^ 2 - Pt2(1) ^ 2
xy = (Pt1(0) - Pt2(0)) * (Pt1(1) - Pt3(1)) - (Pt1(0) - Pt3(0)) * (Pt1(1) - Pt2(1))
'判斷參數(shù)有效性
If Abs(xy) < 0.000001 Then
MsgBox "所輸入的參數(shù)無法創(chuàng)建圓形！"
Exit Function
End If
'獲得圓心和半徑
ptCen(0) = (xysm * (Pt1(1) - Pt3(1)) - xyse * (Pt1(1) - Pt2(1))) / (2 * xy)
ptCen(1) = (xyse * (Pt1(0) - Pt2(0)) - xysm * (Pt1(0) - Pt3(0))) / (2 * xy)
MsgBox Pt1(2)
ptCen(2) = Pt1(2)
radius = Sqr((Pt1(0) - ptCen(0)) * (Pt1(0) - ptCen(0)) + (Pt1(1) - ptCen(1)) * (Pt1(1) - ptCen(1)))
If radius < 0.000001 Then
MsgBox "半徑過小！"
Exit Function
End If
Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, radius)
'由于返回值是對象，必須加上set
Set AddCircle3P = objCir
End Function
Public Function ThreePointCircle(Point1, Point2, Point3) As AcadCircle
Dim iPt, util As AcadUtility, ms As AcadModelSpace
Dim Line1 As AcadLine, Line2 As AcadLine, line3 As AcadLine
Dim midPt, newPt, x1 As AcadXline, x2 As AcadXline, rad As Double
Set util = ThisDrawing.Utility
Set ms = ThisDrawing.ModelSpace
'繪制兩條弦
Set Line1 = ms.AddLine(Point1, Point2)
Set Line2 = ms.AddLine(Point2, Point3)
'第一條弦的中點
midPt = util.PolarPoint(Line1.StartPoint, Line1.Angle, Line1.Length / 2)
'過這條弦中點的垂線上的距離為1的點
newPt = util.PolarPoint(midPt, Line1.Angle + 1.570795, 1)
'繪制過這條弦中點的構造線
Set x1 = ms.AddXline(midPt, newPt)
'第二條弦的重點
midPt = util.PolarPoint(Line2.StartPoint, Line2.Angle, Line2.Length / 2)
'過第二條中點的弦的垂線的距離為1的點
newPt = util.PolarPoint(midPt, Line2.Angle + 1.570795, 1)
'繪制過第二條弦中點的構造線
Set x2 = ms.AddXline(midPt, newPt)
'求兩條構造線的交點
iPt = x1.IntersectWith(x2, acExtendNone)
'繪制出一條半徑
Set line3 = ms.AddLine(iPt, Line1.StartPoint)
'半徑長度
rad = line3.Length
'刪除兩條弦和那條半徑以及兩條構造線
Line1.Delete: Line2.Delete: line3.Delete
x1.Delete: x2.Delete
'繪制圓
Set ThreePointCircle = ms.AddCircle(iPt, rad)
End Function
'***********************************************************************************************************************************
'繪制圓的中心線***********************************************繪制圓的中心線***********************************************************
'
'
Public Function Circle_ZXX(ByVal C As AcadCircle)
'圓心 和半徑
Dim Pt1 As Variant, R As Double
Pt1 = C.center
R = C.diameter / 2
'中心線的四個端點
Dim Pt2 As Variant, Pt3 As Variant, Pt4 As Variant, Pt5 As Variant
'計算四個端點坐標
Pt2 = Pt1
Pt3 = Pt1
Pt4 = Pt1
Pt5 = Pt1
'為了使交叉點是線段相交，即使長度應該為18的奇數(shù)倍。
Dim L As Long
L = Int(1.2 * 2 * R)
Pt2(0) = Pt1(0) - L / 2
Pt3(0) = Pt1(0) + L / 2
Pt4(1) = Pt1(1) - L / 2
Pt5(1) = Pt1(1) + L / 2
'繪制中心線
Dim LineObj1 As AcadLine, LineObj2 As AcadLine
Set LineObj1 = ThisDrawing.ModelSpace.AddLine(Pt2, Pt3)
Set LineObj2 = ThisDrawing.ModelSpace.AddLine(Pt4, Pt5)
'修改線形比例(讓每條中心線由36段點畫線組成,"ACAD_ISO10W100"每段長度為18mm。)
'為了使交叉點是線段相交，即使長度應該為偶數(shù)倍。
LineObj1.LinetypeScale = L / 36 / 18
LineObj2.LinetypeScale = L / 36 / 18
LineObj1.Layer = "中心線"
LineObj2.Layer = "中心線"
LineObj1.Update
LineObj2.Update
End Function
'***********************************************************************************************************************************
'繪制Arc的中心線***********************************************繪制Arc的中心線***********************************************************
'
'
Public Function Arc_ZXX(ByVal C As AcadArc)
'圓心 和半徑,起點角度，終點角度
Dim Pt1 As Variant, R As Double, A1 As Double, A2 As Double
Pt1 = C.center
R = C.radius
A1 = C.StartAngle
A2 = C.EndAngle
'中心線的五個端點
Dim Pt2 As Variant, Pt3 As Variant, Pt4 As Variant, Pt5 As Variant, Pt6 As Variant
'計算四個端點坐標
Pt2 = Pt1
Pt3 = Pt1
Pt4 = Pt1
Pt5 = Pt1
Pt6 = Pt1
'為了使交叉點是線段相交，即使長度應該為18的奇數(shù)倍。
Dim L As Long
L = Int(1.2 * 2 * R)
Pt2(0) = Pt1(0) - L / 2
Pt3(0) = Pt1(0) + L / 2
Pt4(1) = Pt1(1) - L / 2
Pt5(1) = Pt1(1) + L / 2
Pt6(0) = Pt1(0) + Cos((A1 + (A2 - A1) / 2)) * L / 2
Pt6(1) = Pt1(1) + Sin((A1 + (A2 - A1) / 2)) * L / 2
'繪制中心線
Dim LineObj1 As AcadLine, LineObj2 As AcadLine, LineObj3 As AcadLine
Set LineObj1 = ThisDrawing.ModelSpace.AddLine(Pt2, Pt3)
Set LineObj2 = ThisDrawing.ModelSpace.AddLine(Pt4, Pt5)
Set LineObj3 = ThisDrawing.ModelSpace.AddLine(Pt1, Pt6)
'修改線形比例(讓每條中心線由36段點畫線組成,"ACAD_ISO10W100"每段長度為18mm。)
'為了使交叉點是線段相交，即使長度應該為偶數(shù)倍。
LineObj1.LinetypeScale = L / 36 / 18
LineObj2.LinetypeScale = L / 36 / 18
LineObj3.LinetypeScale = L / 36 / 18
LineObj1.Layer = "中心線"
LineObj2.Layer = "中心線"
LineObj3.Layer = "中心線"
Update
End Function
'***********************************************************************************************************************************
'繪制橢圓、橢圓弧的中心線***********************************************繪制橢圓、橢圓弧的中心線********************************************************
' 調用FillArray
'
Public Function Ellipse_ZXX(ByVal e As AcadEllipse)
Dim MajorAxis(0 To 2) As Double '長軸方向，實際上是一個點，他與點(0,0,0)的連線與橢圓的長軸平行。如果橢圓的中心為圓點的話，他即是橢圓長軸上的一點。
Dim CenterPoint(0 To 2) As Double '橢圓的中心點
Dim MajorRadiusAngle As Double '長軸與X軸所成的角度
Dim MinorRadius As Double '短軸半徑
Dim MajorRadius As Double '長軸半徑
'繪制出下面三個點，既可以看出是相對與原點的坐標
' ThisDrawing.ModelSpace.AddPoint E.Center
' ThisDrawing.ModelSpace.AddPoint E.MajorAxis
' ThisDrawing.ModelSpace.AddPoint E.MinorAxis
'MsgBox E.MajorRadius '長軸半徑
'MsgBox E.MinorRadius '短軸半徑
FillArray e.MajorAxis, MajorAxis
FillArray e.center, CenterPoint
MinorRadius = e.MinorRadius
MajorRadius = e.MajorRadius
'使用 AngleFromXAxis 方法查看直線與 X 軸所成的角度
'上面已經(jīng)說過橢圓的軸方向是相對與原點的坐標
MajorRadiusAngle = ThisDrawing.Utility.AngleFromXAxis(MajorAxis, Point3D(0, 0, 0))
'求短軸中心線兩個端點的坐標
' 使用 PolarPoint 方法找出與給定點成指定角度和指定距離的點
' 中心線長度是短軸長度的1.2倍
' 短軸的兩個端點在長軸的過中點的垂線上，相差90度
Dim Pt1(2) As Double
Dim Pt2(2) As Double
With ThisDrawing.Utility
FillArray .PolarPoint(CenterPoint, MajorRadiusAngle - (Atn(1) * 2), MinorRadius * 1.2), Pt1
FillArray .PolarPoint(CenterPoint, MajorRadiusAngle + (Atn(1) * 2), MinorRadius * 1.2), Pt2
End With
'繪制短軸的中心線
Dim LineObj As AcadLine
Set LineObj = ThisDrawing.ModelSpace.AddLine(Pt1, Pt2)
LineObj.Layer = "中心線"
LineObj.LinetypeScale = MinorRadius * 1.2 / 36 / 18
'長軸中心線兩個端點的坐標
With ThisDrawing.Utility
FillArray .PolarPoint(CenterPoint, MajorRadiusAngle, MajorRadius * 1.2), Pt1
FillArray .PolarPoint(CenterPoint, MajorRadiusAngle + (Atn(1) * 4), MajorRadius * 1.2), Pt2
End With
'繪制長軸中心線
Set LineObj = ThisDrawing.ModelSpace.AddLine(Pt1, Pt2)
LineObj.Layer = "中心線"
LineObj.LinetypeScale = MinorRadius * 1.2 / 36 / 18
End Function
'***********************************************************************************************************************************
'繪制面域中心線********************************************************繪制面域中心線****************************************************
' 調用FillArray
' 調用Point3D
' 如果一個面域有多個主軸，本程序只能繪制出一個，而且未必是對稱軸上面的那個。
Public Function Region_ZXX(R As AcadRegion)
' R.Centroid ' 面域的中心點（實際上是一個2維坐標點，不包含Z方向）
' R.Perimeter ' 面域的周長
' R.PrincipalDirections
Dim center(2) As Double
center(0) = R.Centroid(0): center(1) = R.Centroid(1): center(2) = 0
ThisDrawing.ModelSpace.AddPoint center
Dim Min As Variant
Dim Max As Variant
R.GetBoundingBox Min, Max
'ThisDrawing.ModelSpace.AddPoint Min
'ThisDrawing.ModelSpace.AddPoint Max
'DrawBoundingBox R
Dim L As Double '外邊界對角線線長
L = P2PDistance(Min, Max)
'將面域移動到原點
R.Move center, Point3D(0, 0, 0)
'主方向變量
Dim P As Variant
P = R.PrincipalDirections
'計算十字線的四個頂點坐標
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, P4(2) As Double
FillArray center, P1: FillArray center, P2: FillArray center, P3: FillArray center, P4
P1(0) = center(0) + L / 2: P2(0) = center(0) - L / 2
P3(1) = center(1) + L / 2: P4(1) = center(1) - L / 2
'繪制中心線
Dim ZX1 As AcadLine, ZX2 As AcadLine
Set ZX1 = ThisDrawing.ModelSpace.AddLine(P1, P2)
Set ZX2 = ThisDrawing.ModelSpace.AddLine(P3, P4)
If P(0) > 0 And P(1) > 0 Then
ZX1.Rotate center, Arcsin(P(0))
ZX2.Rotate center, Arcsin(P(0))
ElseIf P(1) < 0 Then '到過來旋轉
ZX1.Rotate center, Arccos(P(0))
ZX2.Rotate center, Arccos(P(0))
End If
ZX2.Color = acRed
ZX2.Layer = "中心線"
ZX1.Color = acRed
ZX1.Layer = "中心線"
'將面域移到原處
R.Move Point3D(0, 0, 0), center
End Function
'***********************************************************************************************************************************
'交換兩個數(shù)組變量*******************************************將Source數(shù)組變量傳遞給Dest數(shù)組變量********************
'
Public Function FillArray(Source As Variant, Dest As Variant)
'統(tǒng)一兩個數(shù)組的維數(shù)，包括上標和下標，并且傳遞數(shù)組元素。
Dim nIdx As Long
'檢查兩個數(shù)組是否有相同的維數(shù)
If (UBound(Source) - LBound(Source)) = (UBound(Dest) - LBound(Dest)) Then
nIdx = LBound(Source)
While nIdx <= UBound(Source)
Dest(nIdx) = Source(nIdx)
nIdx = nIdx + 1
Wend
End If
End Function
Public Function BoxedText(textString As String, insertionPoint, height As Double, offset As Double)
Dim Txt As AcadText, tmp, PL As AcadLWPolyline
Dim retVal(0 To 1) As AcadEntity
Set Txt = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)
Set PL = DrawBoundingBox(Txt)
tmp = PL.offset(offset)
PL.Delete
Set retVal(0) = Txt: Set retVal(1) = tmp(0)
BoxedText = retVal
End Function
'***********************************************************************************************************************************
'給任用一個實體繪制邊框***************************************給任用一個實體繪制邊框*************************************************
'
Public Function DrawBoundingBox(ent As AcadEntity) As AcadLWPolyline
Dim Min, Max
ent.GetBoundingBox Min, Max
Set DrawBoundingBox = Rectangle(Min, Max)
End Function
'***********************************************************************************************************************************
'將三個變量轉換成一個點坐標變量***************************************將三個變量轉換成一個點坐標變量*************************************************
'
Public Function Point3D(ByVal x As Double, ByVal y As Double, Optional Z As Double = 0) As Variant
Dim retVal(0 To 2) As Double
retVal(0) = x: retVal(1) = y: retVal(2) = Z
Point3D = retVal
End Function
'***********************************************************************************************************************************
'通過兩個對角點繪制矩形*****************************************通過兩個對角點繪制矩形********************************************************
'
Public Function Rectangle(Point1, Point2) As AcadLWPolyline
Dim vertices(0 To 7) As Double, PL As AcadLWPolyline
vertices(0) = CDbl(Point1(0)): vertices(1) = CDbl(Point1(1))
vertices(2) = CDbl(Point2(0)): vertices(3) = CDbl(Point1(1))
vertices(4) = CDbl(Point2(0)): vertices(5) = CDbl(Point2(1))
vertices(6) = CDbl(Point1(0)): vertices(7) = CDbl(Point2(1))
Set PL = ThisDrawing.ModelSpace.AddLightWeightPolyline(vertices)
PL.Closed = True
Set Rectangle = PL
End Function
'***********************************************************************************************************************************
'反余弦函數(shù)*****************************************反余弦函數(shù)***********************************************************************
'
Function Arccos(ByVal x As Double) As Variant
Dim PI As Double
PI = 4# * Atn(1#)
If Abs(x) > 1# Then
Arccos = False
Else
If Abs(x) = 1# Then
Arccos = (1# - x) * PI / 2#
Else
Arccos = PI / 2 - Atn(x / Sqr(-x * x + 1))
End If
End If
End Function
'***********************************************************************************************************************************
'反正弦函數(shù)*****************************************反正弦函數(shù)***********************************************************************
'
Function Arcsin(ByVal x As Double) As Variant
Dim PI As Double
PI = 4# * Atn(1#)
If Abs(x) > 1# Then
Arcsin = False
Else
If Abs(x) = 1# Then
Arcsin = Sgn(x) * PI / 2#
Else
Arcsin = Atn(x / Sqr(-x * x + 1))
End If
End If
End Function
'***********************************************************************************************************************************
'坐標標注*******************************************坐標標注***********************************************************
'
Public Function DimPoint(ByVal Z As Boolean)
Dim temp As Double, temp1 As Double
On Error Resume Next
'讀取標注文字的默認值
temp = ThisDrawing.GetVariable("DIMTXT")
Dim DimTextHeight As Double
DimTextHeight = ThisDrawing.Utility.GetDistance(, "標注文本高度(" & temp & "):")
'不論是按下esc鍵還是按下enter鍵都取默認值
If Err Then
DimTextHeight = temp
Err.Clear
End If
'MsgBox DimTextHeight
Dim P1 As Variant, P2 As Variant
ThisDrawing.Utility.InitializeUserInput 1, ""
P1 = ThisDrawing.Utility.GetPoint(, "請選擇要標注的點:")
Dim Txt As String
If Z = True Then
Txt = "X=" & Format(P1(0), "0.0000") & " Y=" & Format(P1(1), "0.0000") & " Z=" & Format(P1(2), "0.0000")
Else
Txt = "X=" & Format(P1(0), "0.0000") & " Y=" & Format(P1(1), "0.0000")
End If
ThisDrawing.Utility.InitializeUserInput 1, ""
P2 = ThisDrawing.Utility.GetPoint(, "請選擇標注文件的插入點:")
ThisDrawing.ModelSpace.AddText Txt, P2, DimTextHeight
End Function
'***********************************************************************************************************************************
'判斷三點是否共線*******************************************判斷三點是否共線***************************************************
' 調用P2PDistance
Public Function ThreeP_IsOnline(ByVal P1 As Variant, ByVal P2 As Variant, P3 As Variant) As Boolean
'方法一兩邊之大于第三邊，或者兩邊之差大于第小于第三邊
'方法二其中一點到另外兩點組成的直線的距離為零。
'使用方法一
Dim L1 As Double, L2 As Double, L3 As Double
L1 = P2PDistance(P1, P2)
L2 = P2PDistance(P1, P3)
L3 = P2PDistance(P2, P3)
If L1 + L2 > L3 And L1 + L3 > L2 And L2 + L3 > L1 Then
'不共線
ThreeP_IsOnline = False
Else
'共線
ThreeP_IsOnline = True
End If
End Function
'***********************************************************************************************************************************
'自動生成國標圖框*******************************************************自動生成國標圖框*********************************************************
'
Public Function AUTO_TuKuang(ByVal Size As String, ByVal xScale As Integer)
Dim TuKuang_Layer As AcadLayer
Dim TuKuang As AcadBlock
Dim Kuang1 As AcadLWPolyline
Dim Kuang2 As AcadLWPolyline
Dim Line As AcadLine
Dim PO As Variant
Dim P(7) As Double
Dim temp As AcadBlock, temp1 As String, temp2 As Integer, Index As Integer
PO = ThisDrawing.Utility.GetPoint(, "插入點")
'判斷文檔之中是否存在圖框系列圖層
' 如果沒有，則新建該系列圖層
Dim LayerExist As Boolean
For Each TuKuang_Layer In ThisDrawing.Layers
If TuKuang_Layer.Name = "圖框" Then LayerExist = True
Next
If LayerExist = False Then
Set TuKuang_Layer = ThisDrawing.Layers.Add("圖框")
TuKuang_Layer.Color = 128
End If
'將圖框層置為當前層
If ThisDrawing.ActiveLayer.Name <> "圖框" Then ThisDrawing.ActiveLayer = TuKuang_Layer
'建立圖框
Select Case Size
Case "A4_H" 'A4 橫向
'查找是否存在A4_H圖框，如果存在則原來的圖框序號上增加1
If ThisDrawing.Blocks.Count > 0 Then
For Each temp In ThisDrawing.Blocks
'MsgBox Temp.Name
'返回塊名稱
temp1 = temp.Name
'如果是A4_H圖框
If Left(temp1, 4) = "A4_H" Then
'返回A4_H的序號
temp2 = Val(Right(temp1, 3))
'MsgBox Temp2
'返回A4_H圖框的最大的序號，放在Index變量中
If Index < temp2 Then Index = temp2
End If
Next
End If
Index = Index + 1
Set TuKuang = ThisDrawing.Blocks.Add(Point3D(0, 0, 0), "A4_H_圖框" & Format(Index, "000"))
'繪制外邊框
P(0) = 0: P(1) = 0: P(2) = 297: P(3) = 0: P(4) = 297: P(5) = 210: P(6) = 0: P(7) = 210
Set Kuang1 = TuKuang.AddLightWeightPolyline(P)
With Kuang1
.Closed = True
.Color = acRed
.Lineweight = acLnWt030
.Layer = "圖框"
End With
'繪制內邊框
'外邊框和內邊框相距5毫米，左側會簽欄位2.5公分。
P(0) = 30: P(1) = 5: P(2) = 292: P(3) = 5: P(4) = 292: P(5) = 205: P(6) = 30: P(7) = 205
Set Kuang2 = TuKuang.AddLightWeightPolyline(P)
With Kuang2
.Closed = True
.Color = acBlue
.Lineweight = acLnWt025
.Layer = "圖框"
End With
With TuKuang
'繪制會簽欄
.AddLine Point3D(5, 205, 0), Point3D(5, 130, 0)
.AddLine Point3D(10, 205, 0), Point3D(10, 130, 0)
.AddLine Point3D(15, 205, 0), Point3D(15, 130, 0)
.AddLine Point3D(20, 205, 0), Point3D(20, 130, 0)
.AddLine Point3D(25, 205, 0), Point3D(25, 130, 0)
.AddLine Point3D(5, 205, 0), Point3D(30, 205, 0)
.AddLine Point3D(5, 180, 0), Point3D(30, 180, 0)
.AddLine Point3D(5, 155, 0), Point3D(30, 155, 0)
.AddLine Point3D(5, 130, 0), Point3D(30, 130, 0)
'繪制標題欄
'標題欄寬6公分，高3.5公分
Set Line = .AddLine(Point3D(292, 40, 0), Point3D(207, 40, 0))
Line.Lineweight = acLnWt025
Line.Color = acBlue
Set Line = .AddLine(Point3D(207, 40, 0), Point3D(207, 5, 0))
Line.Lineweight = acLnWt025
Line.Color = acBlue
'標題欄內網(wǎng)格線按照從上到下，從左到右繪制
.AddLine Point3D(217, 5, 0), Point3D(217, 25, 0)
.AddLine Point3D(232, 5, 0), Point3D(232, 40, 0)
.AddLine Point3D(240, 5, 0), Point3D(240, 10, 0)
.AddLine Point3D(260, 5, 0), Point3D(260, 10, 0)
.AddLine Point3D(268, 5, 0), Point3D(268, 10, 0)
.AddLine Point3D(276, 5, 0), Point3D(276, 10, 0)
.AddLine Point3D(284, 5, 0), Point3D(284, 10, 0)
.AddLine Point3D(232, 32, 0), Point3D(292, 32, 0)
.AddLine Point3D(207, 10, 0), Point3D(292, 10, 0)
.AddLine Point3D(207, 15, 0), Point3D(232, 15, 0)
.AddLine Point3D(207, 20, 0), Point3D(232, 20, 0)
.AddLine Point3D(207, 25, 0), Point3D(292, 25, 0)
'標題欄中添加文字
Dim H As Double
Dim Att As AcadAttribute
H = 文字填充高度("制圖", Point3D(207, 5, 0), Point3D(217, 10, 0), 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "制圖", Point3D(207, 5, 0), "制圖", "制圖")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(212, 7.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "設計", Point3D(207, 10, 0), "設計", "設計")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(212, 12.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "校對", Point3D(207, 15, 0), "校對", "校對")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(212, 17.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "審核", Point3D(207, 20, 0), "審核", "審核")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(212, 22.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "制圖人姓名", Point3D(217, 5, 0), "制圖人", "苗春雷")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(224.5, 7.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "設計人姓名", Point3D(217, 10, 0), "設計人", "苗春雷")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(224.5, 12.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "校對人姓名", Point3D(217, 15, 0), "校對人", "苗春雷")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(224.5, 17.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "審核人姓名", Point3D(217, 20, 0), "審核人", "苗春雷")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(224.5, 22.5, 0)
H = 文字填充高度("南通四建集團有限公司", Point3D(232, 32, 0), Point3D(292, 40, 0), 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "公司名稱", Point3D(0, 0, 0), "公司名稱", "南通四建集團有限公司")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(262, 36, 0)
H = 文字填充高度("南通四建煙塔公司齊齊哈爾項目部", Point3D(232, 25, 0), Point3D(292, 32, 0), 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "工程名稱", Point3D(0, 0, 0), "工程名稱", "南通四建煙塔公司齊齊哈爾項目部")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(262, 28.5, 0)
H = 文字填充高度("施工總平面圖", Point3D(232, 25, 0), Point3D(292, 10, 0), 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "圖紙名稱", Point3D(0, 0, 0), "圖紙名稱", "施工總平面圖")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(262, 17.5, 0)
H = 文字填充高度("日期", Point3D(232, 5, 0), Point3D(240, 10, 0), 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "日期", Point3D(0, 0, 0), "日期", "日期")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(236, 7.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "圖別", Point3D(0, 0, 0), "圖別", "圖別")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(264, 7.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "建施", Point3D(0, 0, 0), "建施", "建施")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(272, 7.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "圖號", Point3D(0, 0, 0), "圖號", "圖號")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(280, 7.5, 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "圖號", Point3D(0, 0, 0), "圖號", "0001")
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(288, 7.5, 0)
Dim DateString As String
DateString = Year(Now) & "年" & Month(Now) & "月" & Day(Now) & "日"
H = 文字填充高度(DateString, Point3D(240, 5, 0), Point3D(260, 10, 0), 0)
Set Att = .AddAttribute(H, acAttributeModeNormal, "日期", Point3D(0, 0, 0), "日期", DateString)
Att.Alignment = acAlignmentMiddleCenter
Att.Move Att.TextAlignmentPoint, Point3D(250, 7.5, 0)
'公司圖標
'會簽欄
'繪制中心線
Set Line = .AddLine(Point3D(161, 0, 0), Point3D(161, 5, 0))
Line.Lineweight = acLnWt030
Set Line = .AddLine(Point3D(292, 105, 0), Point3D(297, 105, 0))
Line.Lineweight = acLnWt030
Set Line = .AddLine(Point3D(161, 205, 0), Point3D(161, 210, 0))
Line.Lineweight = acLnWt030
Set Line = .AddLine(Point3D(25, 105, 0), Point3D(30, 105, 0))
Line.Lineweight = acLnWt030
End With
ThisDrawing.ModelSpace.InsertBlock PO, TuKuang.Name, xScale, xScale, xScale, 0
Case "A4_V" 'A4 豎向
Case "A3_H"
Case "A3_V"
Case "A2_H"
Case "A2_V"
Case "A1_H"
Case "A1_V"
Case "A0_H"
Case "A0_V"
End Select
End Function
'***********************************************************************************************************************************
'根據(jù)給定矩形區(qū)域填充文字(即使文字充滿矩形框)***********************************************************************************
' P1和P2 為矩形框的兩個對角點,A文字的角度(只接受0、90、270三個角度)
Public Function 文字填充模塊(ByVal Txt As String, ByVal P1 As Variant, P2 As Variant, A As Double)
Dim 文字 As AcadText
Dim 文字高度 As Double
Dim 文字長度 As Double
Dim 矩形框長度 As Double
Dim 矩形框高度 As Double
Dim 中點1(2) As Double
Dim 角點1 As Variant, 角點2 As Variant
If Abs(P1(0) - P2(0)) = 0 Or Abs(P1(1) - P2(1)) = 0 Then Exit Function
If A = 0 Then
矩形框長度 = Abs(P1(0) - P2(0))
矩形框高度 = Abs(P1(1) - P2(1))
Else
矩形框長度 = Abs(P1(1) - P2(1))
矩形框高度 = Abs(P1(0) - P2(0))
End If
中點1(0) = (P1(0) + P2(0)) / 2
中點1(1) = (P1(1) + P2(1)) / 2
中點1(2) = (P1(2) + P2(2)) / 2
Set 文字 = ThisDrawing.ModelSpace.AddText(Txt, Point3D(0, 0, 0), 2.5)
文字.GetBoundingBox 角點1, 角點2
文字長度 = Abs(角點1(0) - 角點2(0))
文字高度 = Abs(角點1(1) - 角點2(1))
If 矩形框長度 / 文字長度 <= 矩形框高度 / 文字高度 Then
文字.ScaleEntity 角點1, 矩形框長度 / 文字長度
Else
文字.ScaleEntity 角點1, 矩形框高度 / 文字高度
End If
文字.Alignment = acAlignmentMiddleCenter
文字.Move 文字.TextAlignmentPoint, 中點1
文字.Rotate 中點1, A * Atn(1) * 4 / 180
End Function
'***********************************************************************************************************************************
'返回文字填充高度*********************************************************返回文字填充高度***********************************************
' 其實我們可以修改程序自動判斷文字方向，使得360都可以。以后有時間在寫吧。
Public Function 文字填充高度(ByVal Txt As String, ByVal P1 As Variant, P2 As Variant, A As Double) As Double
Dim 文字 As AcadText
Dim 文字高度 As Double
Dim 文字長度 As Double
Dim 矩形框長度 As Double
Dim 矩形框高度 As Double
Dim 中點1(2) As Double
Dim 角點1 As Variant, 角點2 As Variant
If Abs(P1(0) - P2(0)) = 0 Or Abs(P1(1) - P2(1)) = 0 Then Exit Function
If A = 0 Then
矩形框長度 = Abs(P1(0) - P2(0))
矩形框高度 = Abs(P1(1) - P2(1))
Else
矩形框長度 = Abs(P1(1) - P2(1))
矩形框高度 = Abs(P1(0) - P2(0))
End If
中點1(0) = (P1(0) + P2(0)) / 2
中點1(1) = (P1(1) + P2(1)) / 2
中點1(2) = (P1(2) + P2(2)) / 2
Set 文字 = ThisDrawing.ModelSpace.AddText(Txt, Point3D(0, 0, 0), 2.5)
文字.GetBoundingBox 角點1, 角點2
文字長度 = Abs(角點1(0) - 角點2(0))
文字高度 = Abs(角點1(1) - 角點2(1))
If 矩形框長度 / 文字長度 <= 矩形框高度 / 文字高度 Then
文字.ScaleEntity 角點1, 矩形框長度 / 文字長度 * 0.8
Else
文字.ScaleEntity 角點1, 矩形框高度 / 文字高度 * 0.8
End If
文字填充高度 = 文字.height
文字.Delete
End Function
'***********************************************************************************************************************************
'返回實體的中心點*********************************************************返回實體的中心點***********************************************
'
Public Function GetCenter(ByVal e As AcadEntity) As Variant
Dim P1 As Variant
Dim P2 As Variant
Dim P(2) As Double
e.GetBoundingBox P1, P2
P(0) = (P1(0) + P2(0)) / 2
P(1) = (P1(1) + P2(1)) / 2
P(2) = (P1(2) + P2(2)) / 2
GetCenter = P
End Function
'***********************************************************************************************************************************
'返回任意“曲線”的長度*******************************************************************************************************************
'參數(shù):一個“曲線”對象[Line(直線)、Circle(圓)、Arc(圓弧)、Spline(樣條曲線)、Polyline(多義線)、LWPolyline(細多義線)、3Dpolyline(三維多義線)、Ellipse(橢圓)]
Public Function GetCurveLength(curve As AcadEntity) As Double
End Function
'***********************************************************************************************************************************
'將文檔時間導出************************************************將文檔時間導出************************************************************
'
Public Function GetDate(ByVal VAR As String) As Date
Dim temp As Double
If VAR = "TDCREATE" Then
temp = ThisDrawing.GetVariable("TDCREATE")
ElseIf VAR = "TDUPDATE" Then
temp = ThisDrawing.GetVariable("TDUPDATE")
Else
temp = ThisDrawing.GetVariable("DATE")
End If
Dim temp1 As String
temp1 = temp - 2415019
GetDate = CDate(temp1)
End Function
'***********************************************************************************************************************************
'計算一條線段的中點*******************************************計算一條線段的中點****************************************************
'
Function CenterPoint(P1 As Variant, P2 As Variant) As Variant
Dim P(0 To 2) As Double
P(0) = (P1(0) + P2(0)) / 2
P(1) = (P1(1) + P2(1)) / 2
P(2) = (P1(2) + P2(2)) / 2
CenterPoint = P
End Function
'***********************************************************************************************************************************
'空間平面方程***********************************************************空間平面方程**************************************************
'
Function KJPMFC(P1 As Variant, P2 As Variant, P3 As Variant, ByRef A As Double, ByRef B As Double, ByRef C As Double, ByRef D As Double) As Integer
'判斷三點是否在一條直線上
If ThreeP_IsOnline(P1, P2, P3) = True Then
ThisDrawing.Utility.Prompt "出現(xiàn)三點共線情況" & vbCrLf
Exit Function
End If
Dim M(0 To 5) As Double
'計算平面方程系數(shù)
M(0) = P2(0) - P1(0)
M(1) = P2(1) - P1(1)
M(2) = P2(2) - P1(2)
M(3) = P3(0) - P1(0)
M(4) = P3(1) - P1(1)
M(5) = P3(2) - P1(2)
'計算平面方程系數(shù)( Ax+By+Cz+D=0)
A = M(1) * M(5) - M(2) * M(4)
B = -(M(0) * M(5) - M(2) * M(3))
C = M(0) * M(4) - M(1) * M(3)
D = -A * P1(0) - B * P1(1) - C * P1(2)
End Function
