田草博客

互联网田草博客


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件 | ID
-随机-|-分布-
-博客论坛-|-﨣﨤﨧﨨-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2024 - 3 48
     12
3456789
10111213141516
17181920212223
24252627282930
31


站点统计

最新评论



由轴线直接生成框架梁或柱 窗间墙
未知 VBA 中常用的函数块   [ 日期:2007-04-01 ]   [ 来自:本站原创 ]  HTML

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



[本日志由 田草 于 2007-11-16 11:17 PM 编辑]


引用这个评论 田草 于 2007-12-22 01: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


引用这个评论 田草 于 2007-12-22 01:15 PM 发表评论: 
'命令行提示
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

引用这个评论 田草 于 2007-04-06 01:32 PM 发表评论: 
直线的角度 是与平面的夹角  而 polarPOint 方法所用的是空间的角度 所以还是不可以的。

发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:3*3=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©