用户登陆
站点日历
站点统计
最新评论
VBA 中常用的函数块 [ 日期：2007-04-01 ] [ 来自：VBA 中常用的函数块
Option Explicit
'*************************************************************************************************
Dim i As Integer '全局计数变量
'*************************************************************************************************
'创建选择集******************************************************创建选择集*************************
'
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())
'用数组方式填充一对变量以用作为选择集过滤器使用
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) '改变数组上线，用可选参数preserve保持原数组不变。
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
'输入第一条直线和第二条直线方程的系数，输出交点的坐标
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
'计算直线方程系数
A1 = k1: B1 = -1: C1 = Pt1(1) - k1 * Pt1(0)
A2 = k2: B2 = -1: C2 = Pt2(1) - k2 * Pt2(0)
'调用GetPtIntersect函数
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))
'判断参数有效性
If Abs(xy) < 0.000001 Then
MsgBox "所输入的参数无法创建圆形！"
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的奇数倍。
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。)
'为了使交叉点是线段相交，即使长度应该为偶数倍。
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的奇数倍。
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。)
'为了使交叉点是线段相交，即使长度应该为偶数倍。
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 轴所成的角度
'上面已经说过椭圆的轴方向是相对与原点的坐标
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
'***********************************************************************************************************************************
'交换两个数组变量*******************************************将Source数组变量传递给Dest数组变量********************
'
Public Function FillArray(Source As Variant, Dest As Variant)
'统一两个数组的维数，包括上标和下标，并且传递数组元素。
Dim nIdx As Long
'检查两个数组是否有相同的维数
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
'***********************************************************************************************************************************
'反余弦函数*****************************************反余弦函数***********************************************************************
'
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
'***********************************************************************************************************************************
'反正弦函数*****************************************反正弦函数***********************************************************************
'
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
'标题栏内网格线按照从上到下，从左到右绘制
.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
'***********************************************************************************************************************************
'根据给定矩形区域填充文字(即使文字充满矩形框)***********************************************************************************
' 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
'***********************************************************************************************************************************
'返回任意“曲线”的长度*******************************************************************************************************************
'参数:一个“曲线”对象[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 "出现三点共线情况" & vbCrLf
Exit Function
End If
Dim M(0 To 5) As Double
'计算平面方程系数
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)
'计算平面方程系数( 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
'*************************************************************************************************
Dim i As Integer '全局计数变量
'*************************************************************************************************
'创建选择集******************************************************创建选择集*************************
'
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())
'用数组方式填充一对变量以用作为选择集过滤器使用
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) '改变数组上线，用可选参数preserve保持原数组不变。
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
'输入第一条直线和第二条直线方程的系数，输出交点的坐标
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
'计算直线方程系数
A1 = k1: B1 = -1: C1 = Pt1(1) - k1 * Pt1(0)
A2 = k2: B2 = -1: C2 = Pt2(1) - k2 * Pt2(0)
'调用GetPtIntersect函数
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))
'判断参数有效性
If Abs(xy) < 0.000001 Then
MsgBox "所输入的参数无法创建圆形！"
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的奇数倍。
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。)
'为了使交叉点是线段相交，即使长度应该为偶数倍。
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的奇数倍。
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。)
'为了使交叉点是线段相交，即使长度应该为偶数倍。
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 轴所成的角度
'上面已经说过椭圆的轴方向是相对与原点的坐标
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
'***********************************************************************************************************************************
'交换两个数组变量*******************************************将Source数组变量传递给Dest数组变量********************
'
Public Function FillArray(Source As Variant, Dest As Variant)
'统一两个数组的维数，包括上标和下标，并且传递数组元素。
Dim nIdx As Long
'检查两个数组是否有相同的维数
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
'***********************************************************************************************************************************
'反余弦函数*****************************************反余弦函数***********************************************************************
'
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
'***********************************************************************************************************************************
'反正弦函数*****************************************反正弦函数***********************************************************************
'
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
'标题栏内网格线按照从上到下，从左到右绘制
.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
'***********************************************************************************************************************************
'根据给定矩形区域填充文字(即使文字充满矩形框)***********************************************************************************
' 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
'***********************************************************************************************************************************
'返回任意“曲线”的长度*******************************************************************************************************************
'参数:一个“曲线”对象[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 "出现三点共线情况" & vbCrLf
Exit Function
End If
Dim M(0 To 5) As Double
'计算平面方程系数
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)
'计算平面方程系数( 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
[本日志由 田草 于 2007-11-16 11:17 PM 编辑]
|
|
'线性方程组的解法
'
Sub XXFCZ(ByRef a() As Double, ByRef B() As Double)
'高斯消元法
'A(i,j)是系数
'B(i)是右端项
Dim N As Long
Dim k As Long
Dim L As Double
Dim j As Long
Dim sum As Double
N = UBound(B)
For k = 1 To N - 1
For i = k + 1 To N
L = a(i, k) / a(k, k)
For j = k + 1 To N
a(i, j) = a(i, j) - L * a(k, j)
Next j
B(i) = B(i) - L * B(k)
Next i
Next k '以上是消元过程
B(N) = B(N) / a(N, N)
For i = N - 1 To 1 Step -1
sum = 0
For j = i + 1 To N
sum = sum + a(i, j) * B(j)
Next j
B(i) = (B(i) - sum) / a(i, i)
Next i '以上是回代过程
End Sub
'线性方程组的解法
' 高斯消元法 方程组系数为零 也没有关系
Function GaoSi(a(), N, B())
Dim Ipiv(50), INdxr(50), Indxc(50)
Dim j
Dim k
Dim L
Dim LL
Dim Dum
Dim Pivinv
For j = 1 To N
Ipiv(j) = 0
Next j
Dim i
Dim Big
Dim Irow
Dim Icol
For i = 1 To N
Big = 0#
For j = 1 To N
If Ipiv(j) <> 1 Then
For k = 1 To N
If Ipiv(k) = 0 Then
If Abs(a(j, k)) >= Big Then
Big = Abs(a(j, k))
Irow = j
Icol = k
End If
ElseIf Ipiv(k) > 1 Then
MsgBox "异常矩阵"
End If
Next k
End If
Next j
Ipiv(Icol) = Ipiv(Icol) + 1
If Irow <> Icol Then
For L = 1 To N
Dum = a(Irow, L)
a(Irow, L) = a(Icol, L)
a(Icol, L) = Dum
Next L
Dum = B(Irow)
B(Irow) = B(Icol)
B(Icol) = Dum
End If
INdxr(i) = Irow
Indxc(i) = Icol
If a(Icol, Icol) = 0# Then MsgBox "异常矩阵"
Pivinv = 1# / a(Icol, Icol)
a(Icol, Icol) = 1#
For L = 1 To N
a(Icol, L) = a(Icol, L) * Pivinv
Next L
B(Icol) = B(Icol) * Pivinv
For LL = 1 To N
If LL <> Icol Then
Dum = a(LL, Icol)
a(LL, Icol) = 0#
For L = 1 To N
a(LL, L) = a(LL, L) - a(Icol, L) * Dum
Next L
B(LL) = B(LL) - B(Icol) * Dum
End If
Next LL
Next i
For L = N To 1 Step -1
If INdxr(L) <> Indxc(L) Then
For k = 1 To N
Dum = a(k, INdxr(L))
a(k, INdxr(L)) = a(k, Indxc(L))
a(k, Indxc(L)) = Dum
Next k
End If
Next L
End Function
'浏览选择文件夹
Public Function ReturnFolder(lngHwnd As Long) As String
Dim Browser As BrowseInfo
Dim lngFolder As Long
Dim strPath As String
Dim strTemp As String
With Browser
.hOwner = lngHwnd
.lpszTitle = "选择工作路径"
.pszDisplayName = String(MAX_PATH, 0)
End With
'用空格填充字符串
strPath = String(MAX_PATH, 0)
'调用API函数显示文件夹列表
lngFolder = SHBrowseForFolder(Browser)
'使用API函数获取返回的路径
If lngFolder Then
SHGetPathFromIDList lngFolder, strPath
strTemp = Left(strPath, InStr(strPath, vbNullChar) - 1)
If (Right(strTemp, 1) <> "\") Then
strTemp = strTemp & "\"
End If
ReturnFolder = strTemp
End If
End Function
Function LoadLisp(LispFileName As String) As String
Dim temp As String, Temp1 As String, temp2 As String, temp3 As String
temp = GetPath
Temp1 = "\"
temp2 = "\\\"
temp3 = Replace(temp, Temp1, temp2, 1, -1, vbTextCompare)
LoadLisp = "(load" & Chr(34) & temp3 & "lisp\\" & LispFileName & Chr(34) & ")" & vbCr
End Function
Public Function ClickConfirm() As Boolean
Dim objUtil As AcadUtility
Dim varPnt As Variant
Dim strPrmt As String
On Error GoTo Err_Control
'strPrmt = "Left click to confirm, right click to cancel"
strPrmt = "鼠标左键确认，右键取消"
Set objUtil = ThisDrawing.Utility
varPnt = objUtil.GetPoint(Prompt:=strPrmt)
'No error? Then they "left clicked" (or typed a point on
'The command line. Meh. Users are crazy.
ClickConfirm = True
Exit_Here:
Exit Function
Err_Control:
'Debug.Print Err.Description; Err.Number
Select Case Err.Number
Case -2145320928
'Right click with command prompt or "Enter" key
'User input is a keyword
Err.Clear
Resume Exit_Here
Case -2147352567
'User pressed escape or clicked a toolbar
'Method 'GetPoint' of object 'IAcadUtility' failed
Err.Clear
Resume Exit_Here
Case Else
Err.Clear
Resume Exit_Here
End Select
End Function
Sub TC(E As AcadEntity)
On Error Resume Next
'填充面域
Dim TC_Entity(0 To 0) As AcadEntity
Dim TC As AcadHatch
Dim TC_Name As String
Dim TC_Type As Long
Dim TC_Associativity As Boolean
TC_Name = "SOLID"
TC_Type = 0
TC_Associativity = True
Set TC = ThisDrawing.ModelSpace.AddHatch(TC_Type, TC_Name, TC_Associativity)
Set TC_Entity(0) = E
TC.AppendInnerLoop (TC_Entity)
TC.Evaluate
'ThisDrawing.SetVariable "HPDRAWORDER", 1
End Sub
Function AddLayer(LayerName As String)
'判断文档之中是否存在图框系列图层
' 如果没有，则新建该系列图层
Dim LayerExist As Boolean
Dim L As AcadLayer
For Each L In ThisDrawing.Layers
If L.Name = LayerName Then LayerExist = True
Next
If LayerExist = False Then
Set L = ThisDrawing.Layers.Add(LayerName)
L.color = 1
End If
End Function
'获取CAD坐标系统和屏幕像素的比值
Function ViewScreen() As Double
Dim ScreenSize As Variant
ScreenSize = ThisDrawing.GetVariable("screensize") '当前视口的屏幕宽度和高度
Dim H As Variant
H = ThisDrawing.GetVariable("viewsize") '当前视图图形的实际高度
ViewScreen = Abs(H / ScreenSize(1))
End Function
'***************************************************
'字符串（默认空格为分隔符）转变为数组或empty
'***************************************************
Function StoDim(ByVal S As String, Optional div As String) As Variant
Dim s_len As Integer '字符串长度
Dim s_p As Integer '查找开始位置
Dim gs() As String
Dim i As Integer
Dim j As Integer
If div = "" Then div = " "
i = 0
s_p = 1
S = LTrim(S + div)
s_len = Len(S)
j = 0
While s_p <= s_len '找到最后子串
If Mid(S, s_p, 1) = div Then '如果找到分隔符
'取子字符串
If s_p > 1 Then
ReDim Preserve gs(j)
gs(j) = Left(S, s_p - 1)
j = j + 1
End If
S = LTrim(Right(S, s_len - s_p))
s_len = Len(S) '替换后新串长度
s_p = 1 '下次开始查找的位置
i = i + 1
Else
s_p = s_p + 1 '如果没有找分隔符，从下一个开始
End If
Wend
'空数组
If j = 0 Then Exit Function
StoDim = gs '得到字符串数组
End Function
'
Sub XXFCZ(ByRef a() As Double, ByRef B() As Double)
'高斯消元法
'A(i,j)是系数
'B(i)是右端项
Dim N As Long
Dim k As Long
Dim L As Double
Dim j As Long
Dim sum As Double
N = UBound(B)
For k = 1 To N - 1
For i = k + 1 To N
L = a(i, k) / a(k, k)
For j = k + 1 To N
a(i, j) = a(i, j) - L * a(k, j)
Next j
B(i) = B(i) - L * B(k)
Next i
Next k '以上是消元过程
B(N) = B(N) / a(N, N)
For i = N - 1 To 1 Step -1
sum = 0
For j = i + 1 To N
sum = sum + a(i, j) * B(j)
Next j
B(i) = (B(i) - sum) / a(i, i)
Next i '以上是回代过程
End Sub
'线性方程组的解法
' 高斯消元法 方程组系数为零 也没有关系
Function GaoSi(a(), N, B())
Dim Ipiv(50), INdxr(50), Indxc(50)
Dim j
Dim k
Dim L
Dim LL
Dim Dum
Dim Pivinv
For j = 1 To N
Ipiv(j) = 0
Next j
Dim i
Dim Big
Dim Irow
Dim Icol
For i = 1 To N
Big = 0#
For j = 1 To N
If Ipiv(j) <> 1 Then
For k = 1 To N
If Ipiv(k) = 0 Then
If Abs(a(j, k)) >= Big Then
Big = Abs(a(j, k))
Irow = j
Icol = k
End If
ElseIf Ipiv(k) > 1 Then
MsgBox "异常矩阵"
End If
Next k
End If
Next j
Ipiv(Icol) = Ipiv(Icol) + 1
If Irow <> Icol Then
For L = 1 To N
Dum = a(Irow, L)
a(Irow, L) = a(Icol, L)
a(Icol, L) = Dum
Next L
Dum = B(Irow)
B(Irow) = B(Icol)
B(Icol) = Dum
End If
INdxr(i) = Irow
Indxc(i) = Icol
If a(Icol, Icol) = 0# Then MsgBox "异常矩阵"
Pivinv = 1# / a(Icol, Icol)
a(Icol, Icol) = 1#
For L = 1 To N
a(Icol, L) = a(Icol, L) * Pivinv
Next L
B(Icol) = B(Icol) * Pivinv
For LL = 1 To N
If LL <> Icol Then
Dum = a(LL, Icol)
a(LL, Icol) = 0#
For L = 1 To N
a(LL, L) = a(LL, L) - a(Icol, L) * Dum
Next L
B(LL) = B(LL) - B(Icol) * Dum
End If
Next LL
Next i
For L = N To 1 Step -1
If INdxr(L) <> Indxc(L) Then
For k = 1 To N
Dum = a(k, INdxr(L))
a(k, INdxr(L)) = a(k, Indxc(L))
a(k, Indxc(L)) = Dum
Next k
End If
Next L
End Function
'浏览选择文件夹
Public Function ReturnFolder(lngHwnd As Long) As String
Dim Browser As BrowseInfo
Dim lngFolder As Long
Dim strPath As String
Dim strTemp As String
With Browser
.hOwner = lngHwnd
.lpszTitle = "选择工作路径"
.pszDisplayName = String(MAX_PATH, 0)
End With
'用空格填充字符串
strPath = String(MAX_PATH, 0)
'调用API函数显示文件夹列表
lngFolder = SHBrowseForFolder(Browser)
'使用API函数获取返回的路径
If lngFolder Then
SHGetPathFromIDList lngFolder, strPath
strTemp = Left(strPath, InStr(strPath, vbNullChar) - 1)
If (Right(strTemp, 1) <> "\") Then
strTemp = strTemp & "\"
End If
ReturnFolder = strTemp
End If
End Function
Function LoadLisp(LispFileName As String) As String
Dim temp As String, Temp1 As String, temp2 As String, temp3 As String
temp = GetPath
Temp1 = "\"
temp2 = "\\\"
temp3 = Replace(temp, Temp1, temp2, 1, -1, vbTextCompare)
LoadLisp = "(load" & Chr(34) & temp3 & "lisp\\" & LispFileName & Chr(34) & ")" & vbCr
End Function
Public Function ClickConfirm() As Boolean
Dim objUtil As AcadUtility
Dim varPnt As Variant
Dim strPrmt As String
On Error GoTo Err_Control
'strPrmt = "Left click to confirm, right click to cancel"
strPrmt = "鼠标左键确认，右键取消"
Set objUtil = ThisDrawing.Utility
varPnt = objUtil.GetPoint(Prompt:=strPrmt)
'No error? Then they "left clicked" (or typed a point on
'The command line. Meh. Users are crazy.
ClickConfirm = True
Exit_Here:
Exit Function
Err_Control:
'Debug.Print Err.Description; Err.Number
Select Case Err.Number
Case -2145320928
'Right click with command prompt or "Enter" key
'User input is a keyword
Err.Clear
Resume Exit_Here
Case -2147352567
'User pressed escape or clicked a toolbar
'Method 'GetPoint' of object 'IAcadUtility' failed
Err.Clear
Resume Exit_Here
Case Else
Err.Clear
Resume Exit_Here
End Select
End Function
Sub TC(E As AcadEntity)
On Error Resume Next
'填充面域
Dim TC_Entity(0 To 0) As AcadEntity
Dim TC As AcadHatch
Dim TC_Name As String
Dim TC_Type As Long
Dim TC_Associativity As Boolean
TC_Name = "SOLID"
TC_Type = 0
TC_Associativity = True
Set TC = ThisDrawing.ModelSpace.AddHatch(TC_Type, TC_Name, TC_Associativity)
Set TC_Entity(0) = E
TC.AppendInnerLoop (TC_Entity)
TC.Evaluate
'ThisDrawing.SetVariable "HPDRAWORDER", 1
End Sub
Function AddLayer(LayerName As String)
'判断文档之中是否存在图框系列图层
' 如果没有，则新建该系列图层
Dim LayerExist As Boolean
Dim L As AcadLayer
For Each L In ThisDrawing.Layers
If L.Name = LayerName Then LayerExist = True
Next
If LayerExist = False Then
Set L = ThisDrawing.Layers.Add(LayerName)
L.color = 1
End If
End Function
'获取CAD坐标系统和屏幕像素的比值
Function ViewScreen() As Double
Dim ScreenSize As Variant
ScreenSize = ThisDrawing.GetVariable("screensize") '当前视口的屏幕宽度和高度
Dim H As Variant
H = ThisDrawing.GetVariable("viewsize") '当前视图图形的实际高度
ViewScreen = Abs(H / ScreenSize(1))
End Function
'***************************************************
'字符串（默认空格为分隔符）转变为数组或empty
'***************************************************
Function StoDim(ByVal S As String, Optional div As String) As Variant
Dim s_len As Integer '字符串长度
Dim s_p As Integer '查找开始位置
Dim gs() As String
Dim i As Integer
Dim j As Integer
If div = "" Then div = " "
i = 0
s_p = 1
S = LTrim(S + div)
s_len = Len(S)
j = 0
While s_p <= s_len '找到最后子串
If Mid(S, s_p, 1) = div Then '如果找到分隔符
'取子字符串
If s_p > 1 Then
ReDim Preserve gs(j)
gs(j) = Left(S, s_p - 1)
j = j + 1
End If
S = LTrim(Right(S, s_len - s_p))
s_len = Len(S) '替换后新串长度
s_p = 1 '下次开始查找的位置
i = i + 1
Else
s_p = s_p + 1 '如果没有找分隔符，从下一个开始
End If
Wend
'空数组
If j = 0 Then Exit Function
StoDim = gs '得到字符串数组
End Function
'命令行提示
Function Prompt(str As String)
ThisDrawing.Utility.Prompt str & vbCrLf
End Function
'创建匿名组，如果有则序号加1，如果没有则创建
Function NiMingZu(S As String) As String
Dim G As AcadGroup
Dim N As Long
For Each G In ThisDrawing.Groups
If Left(G.Name, Len(S)) = S Then N = N + 1
Next
NiMingZu = S & N + 1
End Function
'点到直线的垂足
Function ChuiZuP2L(p1 As Variant, p2 As Variant, P3 As Variant) As Variant
Dim M(0 To 5) As Double
Dim T As Double
Dim P4(2) As Double
'如果三点在一条直线上,则垂足就是P3点。
'判断三点是否在一条直线上
If ThreeP_IsOnline(p1, p2, P3) = True Then
ChuiZuP2L = P3
Else
'直线P1-P2的向量{M(0),M(1),M(2)}
M(0) = p2(0) - p1(0)
M(1) = p2(1) - p1(1)
M(2) = p2(2) - p1(2)
'直线P2-P3的向量{M(3),M(4),M(5)}
M(3) = p2(0) - P3(0)
M(4) = p2(1) - P3(1)
M(5) = p2(2) - P3(2)
T = -(M(0) * M(3) + M(1) * M(4) + M(2) * M(5)) / (M(0) ^ 2 + M(1) ^ 2 + M(2) ^ 2)
'垂足
P4(0) = M(0) * T + p2(0)
P4(1) = M(1) * T + p2(1)
P4(2) = M(2) * T + p2(2)
ChuiZuP2L = P4
End If
End Function
'点排序(同一条直线上的点)
Function DianPaiXu1(ByRef Plist() As Variant)
Dim i As Long
i = UBound(Plist)
Dim M As Variant
Dim N As Variant
Dim j As Long
Dim L As Long
Dim temp As Variant
For j = 1 To i
M = Plist(j)
For L = j + 1 To i
N = Plist(L)
If M(0) + M(1) > N(0) + N(1) Then
temp = Plist(j)
Plist(j) = Plist(L)
Plist(L) = temp
End If
Next
Next
End Function
Function Prompt(str As String)
ThisDrawing.Utility.Prompt str & vbCrLf
End Function
'创建匿名组，如果有则序号加1，如果没有则创建
Function NiMingZu(S As String) As String
Dim G As AcadGroup
Dim N As Long
For Each G In ThisDrawing.Groups
If Left(G.Name, Len(S)) = S Then N = N + 1
Next
NiMingZu = S & N + 1
End Function
'点到直线的垂足
Function ChuiZuP2L(p1 As Variant, p2 As Variant, P3 As Variant) As Variant
Dim M(0 To 5) As Double
Dim T As Double
Dim P4(2) As Double
'如果三点在一条直线上,则垂足就是P3点。
'判断三点是否在一条直线上
If ThreeP_IsOnline(p1, p2, P3) = True Then
ChuiZuP2L = P3
Else
'直线P1-P2的向量{M(0),M(1),M(2)}
M(0) = p2(0) - p1(0)
M(1) = p2(1) - p1(1)
M(2) = p2(2) - p1(2)
'直线P2-P3的向量{M(3),M(4),M(5)}
M(3) = p2(0) - P3(0)
M(4) = p2(1) - P3(1)
M(5) = p2(2) - P3(2)
T = -(M(0) * M(3) + M(1) * M(4) + M(2) * M(5)) / (M(0) ^ 2 + M(1) ^ 2 + M(2) ^ 2)
'垂足
P4(0) = M(0) * T + p2(0)
P4(1) = M(1) * T + p2(1)
P4(2) = M(2) * T + p2(2)
ChuiZuP2L = P4
End If
End Function
'点排序(同一条直线上的点)
Function DianPaiXu1(ByRef Plist() As Variant)
Dim i As Long
i = UBound(Plist)
Dim M As Variant
Dim N As Variant
Dim j As Long
Dim L As Long
Dim temp As Variant
For j = 1 To i
M = Plist(j)
For L = j + 1 To i
N = Plist(L)
If M(0) + M(1) > N(0) + N(1) Then
temp = Plist(j)
Plist(j) = Plist(L)
Plist(L) = temp
End If
Next
Next
End Function
直线的角度 是与平面的夹角 而 polarPOint 方法所用的是空间的角度 所以还是不可以的。
| 发表评论 - 不要忘了输入验证码哦！ |