求论坛里面VBA中精通CAD的帮我看看

釜底抽薪

Sub selectff16() '创建高程点
Dim myss As AcadSelectionSet
Dim Startzb(), endzb(), Startzb1, endzb1, ats() As Variant
Dim retent As Object
Dim n, ad As Integer
Dim currInsertionPoint As Variant
Dim zxyx, zxyy As Double
Dim xory As Boolean '用于判断是否图出高程,如果没有图解出高程则删除高程点,没有图解出高程为真

Dim returnPnt As Variant
Do
On Error GoTo ErrorHandler
returnPnt = ThisDrawing.Utility.GetPoint(, "输入高程点的位置： ")
If returnPnt(0) = 0 Then
Exit Do
End If
    Dim blockRefObj As AcadBlockReference
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(returnPnt, "GC200", 0.5, 0.5, 0.5, 0)
    zxyx = returnPnt(0)
    zxyy = returnPnt(1)
    xory = True
    Call qaoyuangaocheng1(xory, (zxyx), (zxyy), 10, 1)
    If xory Then
       blockRefObj.Delete
    End If
Loop
ErrorHandler:
End Sub

Sub qaoyuangaocheng1(xory As Boolean, zxyx1 As Double, zxyy1 As Double, fangechang As Integer, degaoji As Double)

'    Dim Excel As Excel.Application
'    Dim ExcelSheet As Object
'    Dim ExcelWorkbook As Object
'     Set Excel = GetObject(, "Excel.Application")
'    Set ExcelWorkbook = Excel.Workbooks
'    Set ExcelSheet = Excel.ActiveSheet

Dim myss1 As AcadSelectionSet
Dim sendpoint() As Double  '用于判断要图解点的X或Y轴线所相交的等高线的交点离图解点左右或上下最近的两个点是否在一条等高线,如果是则退出.
Set myss1 = ThisDrawing.SelectionSets.Add("mys221212")
'If xory Then '如果是竖直线
    Dim ats(), ats1(), intPoints, intpoints1 As Variant
    Dim point1(0 To 2) As Double
    Dim point2(0 To 2) As Double
    Dim gpCode(15) As Integer
    Dim dataValue(15) As Variant

'    gpCode(0) = 8
'    dataValue(0) = "方格网"
   gpCode(0) = -4: dataValue(0) = "<or"
   gpCode(1) = -4: dataValue(1) = "<and"
   gpCode(2) = 8: dataValue(2) = "jqx"
'   gpCode(3) = -4: dataValue(3) = "<>"
   gpCode(3) = -4: dataValue(3) = "<or"
   gpCode(4) = 0: dataValue(4) = "Polyline"
   gpCode(5) = 0: dataValue(5) = "LWPolyline"
   gpCode(6) = -4: dataValue(6) = "or>"
   gpCode(7) = -4: dataValue(7) = "and>"
   gpCode(8) = -4: dataValue(8) = "<and"
   gpCode(9) = 8: dataValue(9) = "DGX"
'   gpCode(8) = -4: dataValue(8) = "<>"
   gpCode(10) = -4: dataValue(10) = "<or"
   gpCode(11) = 0: dataValue(11) = "Polyline"
   gpCode(12) = 0: dataValue(12) = "LWPolyline"
   gpCode(13) = -4: dataValue(13) = "or>"
   gpCode(14) = -4: dataValue(14) = "and>"
   gpCode(15) = -4: dataValue(15) = "or>"


    Dim groupCode As Variant, dataCode As Variant
    groupCode = gpCode
    dataCode = dataValue
    Dim mode As Integer
    mode = acSelectionSetCrossing
    point1(0) = zxyx1 - fangechang: point1(1) = zxyy1 - fangechang: point1(2) = 0
    point2(0) = zxyx1 + fangechang: point2(1) = zxyy1 + fangechang: point2(2) = 0
    myss1.Select mode, point1, point2, groupCode, dataCode
    '选中要图解高程的点位置周围以方格网间距为距离的所有等高线
'     Call ThisDrawing.ModelSpace.AddLine(point1, point2)
'    myss1.Highlight (True) '亮显所选择的物体
    If myss1.Count = 0 Then '如果没有选择到物体则退出
        myss1.Delete

        Exit Sub
    Else
       Dim a, b, c As Integer
       ReDim sendpoint(myss1.Count)
       ReDim ats(myss1.Count)
       ReDim intPoints(3, myss1.Count)
       For a = 0 To myss1.Count - 1
            Set ats(a) = myss1.Item(a)
             Dim coord As Variant
             Dim coord1(0 To 2) As Double
             Dim coord2(0 To 2) As Double
               ' On Error Resume Next
            coord = ats(a).Coordinate(0) '求出这条等高线第一点的3D坐标
            If UBound(coord) = 1 Then '如果是轻便多义线则只有2D坐标
                 ReDim coord(3) '因为只有x和y二个点,所以要扩展数组
                 coord(2) = ats(a).Elevation '求出这条轻便多义线的标高
            ElseIf coord(2) = 0 Then
                 coord(2) = ats(a).Elevation
            End If
            coord2(0) = 0: coord2(1) = 0: coord2(2) = coord(2)
            coord1(0) = 0: coord1(1) = 0: coord1(2) = 0

    Dim fgux As AcadPolyline
    Dim points5(0 To 5) As Double
    ' Define the 2D polyline points
    points5(0) = zxyx1: points5(1) = zxyy1 - 50: points5(2) = 0
    points5(3) = zxyx1: points5(4) = zxyy1 + 50: points5(5) = 0
    ' Create a lightweight Polyline object in model space
    Set fgux = ThisDrawing.ModelSpace.AddPolyline(points5) '这是二维多段线，z只能等于0，在后面在用移动命令将这条线提高到需要的高度


            fgux.Move coord1, coord2 '将这条竖直方格网线的标高提高到和这条等高线的标高相同,如果不相同它们就没有交点
            intpoints1 = fgux.IntersectWith(ats(a), acExtendThisEntity) '求出它们的交点的3D坐标,求交点时只有竖直线延长，等高线不延长
            fgux.Delete
  '          fgux.Move coord2, coord1 '将这条竖直线降低到标高为0的位置,以方便下次使用
            If UBound(intpoints1) > 0 Then '如果有交点
                 intPoints(0, a) = intpoints1(0)
                 intPoints(1, a) = intpoints1(1)
                 intPoints(2, a) = intpoints1(2) '将X、Y、Z写入到数组intpoints中
               If UBound(intpoints1) > 3 Then
                    For c = LBound(intpoints1) To UBound(intpoints1) Step 3
                    '如果有多个交点则看那个交点离图解点位置最近，则将最近点的X、Y、Z写入到数组intpoints中
                    '因为等高线是闭合的也是不规则的，所有有可能有多个交点
                    If Abs(intpoints1(c + 1) - zxyy1) < Abs(intPoints(1, a) - zxyy1) Then
                      intPoints(0, a) = intpoints1(c)
                      intPoints(1, a) = intpoints1(c + 1)
                      intPoints(2, a) = intpoints1(c + 2)
                     End If
                     Next
                      sendpoint(a) = 0
                     For c = LBound(intpoints1) To UBound(intpoints1) Step 3
                    '如果有多个交点则看那个交点离图解点位置第二近，则将第二近点的Y写入到数组sendpoint中
                    If Round(intpoints1(c + 1), 7) <> Round(intPoints(1, a), 7) Then
                    If Abs(intpoints1(c + 1) - intPoints(1, a)) < Abs(sendpoint(a) - intPoints(1, a)) Then
                      sendpoint(a) = intpoints1(c + 1)
                     End If
                     End If
                     Next
               End If
            End If
'            ExcelSheet.Cells(a + 1, 1) = intPoints(0, a)
'            ExcelSheet.Cells(a + 1, 2) = intPoints(1, a)
'            ExcelSheet.Cells(a + 1, 3) = intPoints(2, a)
       Next

        Dim miny1, minz1 As Double
        miny1 = 0
'将miny1=0，这样有利与下面的条件选择，如果取任义一个交点坐标就有可能取到最大的那么下面的条件第一个条件就合，
'但是第二个条件就合不了。那么就无法选择出最大，但小于图解点的交点.
        minz1 = 0
        For b = 0 To a - 1
            If intPoints(1, b) > miny1 And intPoints(1, b) < zxyy1 Then
            miny1 = intPoints(1, b)
            minz1 = intPoints(2, b)
            End If
        Next
        For b = 0 To a - 1
            If sendpoint(b) > miny1 And sendpoint(b) < zxyy1 Then
            GoTo atcde '如果有离判断出来的离图解点最近的交点还要近的交点,则退出
            End If
        Next

       Dim miny, minz As Double
       miny = miny1 + fangechang
'同上的道理,将miny = miny1 + fangechang就可以选择出最小的，但大于图解点的交点
       minz = minz1
       For b = 0 To a - 1
            If intPoints(1, b) < miny And intPoints(1, b) > zxyy1 Then
                 miny = intPoints(1, b)
                 minz = intPoints(2, b)
            End If
       Next
       For b = 0 To a - 1
            If sendpoint(b) < miny And sendpoint(b) > zxyy1 Then
            GoTo atcde '如果有离判断出来的离图解点最近的交点还要近的交点,则退出
            End If
       Next
'    myss1.Highlight (False)
'   myss1.Delete

    End If
     '将求的离图解点最近的两个交点高程相交，看等不等于等高距，如果等说明是选择的图解点最近的两条等高线，则求出图解点的高程。

'    points5(0) = zxyx1: points5(1) = miny: points5(2) = 0
'    points5(3) = zxyx1: points5(4) = miny1: points5(5) = 0
'    Call ThisDrawing.ModelSpace.AddPolyline(points5)


    If minz1 - minz = degaoji Then
    minz = minz + (miny - zxyy1) * degaoji / (miny - miny1)
    Dim insertionPoint(0 To 2) As Double
    ElseIf minz1 - minz = -degaoji Then
    minz = minz - (miny - zxyy1) * degaoji / (miny - miny1)
    Else
    GoTo atcde
    End If
    Dim textObj As AcadText
    insertionPoint(0) = zxyx1 + 2.725: insertionPoint(1) = zxyy1: insertionPoint(2) = 0
    Set textObj = ThisDrawing.ModelSpace.AddText(Format(minz, "0.00"), insertionPoint, 1) '将图解出来的高程写到图纸上
    textObj.StyleName = "hz" '设置文本样式名
    textObj.Alignment = acAlignmentMiddle '设置文本对齐方式中间
    textObj.TextAlignmentPoint = insertionPoint '设置文本对齐点坐标
    xory = False
    myss1.Delete
    Exit Sub
    'myss1.Delete
atcde:
'Else '如果水平线
'    Dim gpCode(0) As Integer
'    Dim dataValue(0), ats(), ats1(), intPoints, intpoints1 As Variant
'    Dim point1(0 To 2) As Double
'    Dim point2(0 To 2) As Double
'   gpCode(0) = -4: dataValue(0) = "<or"
'   gpCode(1) = -4: dataValue(1) = "<and"
'   gpCode(1) = 8: dataValue(1) = "8110"
'   gpCode(3) = 0: dataValue(3) = "Polyline"
'   gpCode(4) = -4: dataValue(4) = "and>"
'   gpCode(5) = -4: dataValue(5) = "<and"
'   gpCode(2) = 8: dataValue(2) = "8120"
'   gpCode(7) = 0: dataValue(7) = "Polyline"
'   gpCode(8) = -4: dataValue(8) = "and>"
'   gpCode(3) = -4: dataValue(3) = "or>"
   '    Dim groupCode As Variant, dataCode As Variant
'    groupCode = gpCode
'    dataCode = dataValue
'    Dim mode As Integer
'    mode = acSelectionSetCrossing
'    point1(0) = zxyx1 - fangechang: point1(1) = zxyy1 - fangechang: point1(2) = 0
'    point2(0) = zxyx1 + fangechang: point2(1) = zxyy1 + fangechang: point2(2) = 0
'    myss1.Select mode, point1, point2, groupCode, dataCode
'     Call ThisDrawing.ModelSpace.AddLine(point1, point2)
'    myss1.Highlight (True)
'    If myss1.Count = 0 Then
'        myss1.Delete
'        Exit Sub
'    Else
'       Dim a, b, c As Integer
'       ReDim sendpoint(myss1.Count)
'       ReDim ats(myss1.Count)
'       ReDim intPoints(3, myss1.Count)
       For a = 0 To myss1.Count - 1
            Set ats(a) = myss1.Item(a)
'             Dim coord As Variant
'             Dim coord1(0 To 2) As Double
'             Dim coord2(0 To 2) As Double
               ' On Error Resume Next
            coord = ats(a).Coordinate(0)
            If UBound(coord) = 1 Then
                 ReDim coord(3)
                 coord(2) = ats(a).Elevation
            ElseIf coord(2) = 0 Then
                 coord(2) = ats(a).Elevation
            End If
            coord2(0) = 0: coord2(1) = 0: coord2(2) = coord(2)
            coord1(0) = 0: coord1(1) = 0: coord1(2) = 0

    points5(0) = zxyx1: points5(1) = zxyy1: points5(2) = 0
    points5(3) = zxyx1 + 50: points5(4) = zxyy1: points5(5) = 0
    ' Create a lightweight Polyline object in model space
    Set fgux = ThisDrawing.ModelSpace.AddPolyline(points5) '这是二维多段线，z只能等于0，在后面在用移动命令将这条线提高到需要的高度


            fgux.Move coord1, coord2
            intpoints1 = fgux.IntersectWith(ats(a), acExtendThisEntity)
            fgux.Delete
'           fgux.Move coord2, coord1
            If UBound(intpoints1) > 0 Then
                 intPoints(0, a) = intpoints1(0)
                 intPoints(1, a) = intpoints1(1)
                 intPoints(2, a) = intpoints1(2)
               If UBound(intpoints1) > 3 Then
                    For c = LBound(intpoints1) To UBound(intpoints1) Step 3
                    '如果有多个交点则看那个交点离图解点位置最近，则将最近点的X、Y、Z写入到数组intpoints中
                    '因为等高线是闭合的也是不规则的，所有有可能有多个交点
                    If Abs(intpoints1(c) - zxyx1) < Abs(intPoints(0, a) - zxyx1) Then
                      intPoints(0, a) = intpoints1(c)
                      intPoints(1, a) = intpoints1(c + 1)
                      intPoints(2, a) = intpoints1(c + 2)
                     End If
                     Next
                     sendpoint(a) = 0
                     For c = LBound(intpoints1) To UBound(intpoints1) Step 3
                    '如果有多个交点则看那个交点离图解点位置第二近，则将第二近点的Y写入到数组sendpoint中
                    If Round(intpoints1(c), 7) <> Round(intPoints(0, a), 7) Then
                    If Abs(intpoints1(c) - intPoints(0, a)) < Abs(sendpoint(a) - intPoints(0, a)) Then
                      sendpoint(a) = intpoints1(c)
                     End If
                     End If
                     Next
               End If
            End If
'            ExcelSheet.Cells(a + 1, 1) = intPoints(0, a)
'            ExcelSheet.Cells(a + 1, 2) = intPoints(1, a)
'            ExcelSheet.Cells(a + 1, 3) = intPoints(2, a)
       Next

        Dim minx1 As Double
        minx1 = 0
        minz1 = 0
        For b = 0 To a - 1
            If intPoints(0, b) > minx1 And intPoints(0, b) < zxyx1 Then
            minx1 = intPoints(0, b)
            minz1 = intPoints(2, b)
            End If
        Next
        For b = 0 To a - 1
            If sendpoint(b) > minx1 And sendpoint(b) < zxyx1 Then
            myss1.Delete

            Exit Sub '如果有离判断出来的离图解点最近的交点还要近的交点,则退出
            End If
        Next


       Dim minx As Double
       minx = minx1 + fangechang
       minz = minz1
       For b = 0 To a - 1
            If intPoints(0, b) < minx And intPoints(0, b) > zxyx1 Then
                 minx = intPoints(0, b)
                 minz = intPoints(2, b)
            End If
       Next
       For b = 0 To a - 1
            If sendpoint(b) < minx And sendpoint(b) > zxyx1 Then
            myss1.Delete
            Exit Sub '如果有离判断出来的离图解点最近的交点还要近的交点,则退出
            End If
       Next

'    myss1.Highlight (False)
    myss1.Delete

'    End If


'    points5(0) = minx: points5(1) = zxyy1: points5(2) = 0
'    points5(3) = minx1: points5(4) = zxyy1: points5(5) = 0
'    Call ThisDrawing.ModelSpace.AddPolyline(points5)


    If minz1 - minz = degaoji Then
    minz = minz + (minx - zxyx1) * degaoji / (minx - minx1)
    ElseIf minz1 - minz = -degaoji Then
    minz = minz - (minx - zxyx1) * degaoji / (minx - minx1)
    Else
    Exit Sub
    End If
    insertionPoint(0) = zxyx1 + 2.725: insertionPoint(1) = zxyy1: insertionPoint(2) = 0
    Set textObj = ThisDrawing.ModelSpace.AddText(Format(minz, "0.00"), insertionPoint, 1)
    textObj.StyleName = "hz" '设置文本样式名
    textObj.Alignment = acAlignmentMiddle '设置文本对齐方式中间
    textObj.TextAlignmentPoint = insertionPoint '设置文本对齐点坐标
    xory = False
'    Dim insertionPoint(0 To 2) As Double
'End If
End Sub

WIN7系统下能运行，一到了WIN10就运行不了了   我在代码中提示的标红了

爱疯

太多看不下去，瞎猜下

format 换成 vba.format