自己动手,改进CASS中欠缺的功能

CQBOY

VBA编写的坐标标注程序（测量用）

Public Sub PTBZ()
On Error Resume Next
'创建名为"坐标标注"的新图层
    Dim layerObj As AcadLayer
    Set layerObj = ThisDrawing.Layers.Add("坐标标注")
    layerObj.Color = acRed
'设置为当前图层
    Dim newlayer As AcadLayer
    Set newlayer = ThisDrawing.Layers("坐标标注")
    ThisDrawing.ActiveLayer = newlayer

'定义线
Dim plineObj As AcadLWPolyline '二维轻量多段线
Dim points(0 To 5) As Double
Dim spnt As Variant  '需标注点
Dim epnt As Variant
Dim textobj As AcadText
Dim BZ As AcadTextStyle    '文字样式
Dim H As Double            '文字高度
Dim WZ As Double           '文字位置
Dim xins(0 To 2) As Double 'x坐标插入点
Dim yins(0 To 2) As Double 'y坐标插入点

Set BZ = ThisDrawing.TextStyles.Add("BZ") '设定文字样式
Set BZ = ThisDrawing.ActiveTextStyle
BZ.width = 0.8
BZ.fontFile = "romant.shx"

On Error GoTo err
H = ThisDrawing.Utility.GetReal("文字高度：")

'循环
    Dim counter As Integer
    For counter = 0 To 50

spnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "标注点：")
epnt = ThisDrawing.Utility.GetPoint(spnt, vbCr & "标注坐标")
If IsEmpty(spnt) Then Exit Sub
If H < 5 Then                  '调整文字位置
WZ = 1
Else
WZ = Int(H / 5)
End If

If epnt(0) > spnt(0) Then      '定位文字位置
xins(0) = epnt(0) + 0.5: xins(1) = epnt(1) + WZ: xins(2) = 0
yins(0) = epnt(0) + 0.5: yins(1) = epnt(1) - (WZ + H): yins(2) = 0
Else
xins(0) = epnt(0) - H * 9.1: xins(1) = epnt(1) + 1: xins(2) = 0
yins(0) = epnt(0) - H * 9.1: yins(1) = epnt(1) - (H + 1): yins(2) = 0
End If

x = Format(spnt(1), "####0.000")
y = Format(spnt(0), "####0.000")

points(0) = spnt(0): points(1) = spnt(1)
points(2) = epnt(0): points(3) = epnt(1)
If epnt(0) > spnt(0) Then
points(4) = epnt(0) + H * 9.1: points(5) = epnt(1)
Else
points(4) = epnt(0) - H * 9.1: points(5) = epnt(1)
End If

Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points) '二维轻量多段线
Set textobj = ThisDrawing.ModelSpace.AddText("X=" & x, xins, H)
textobj.Color = acGreen

Set textobj = ThisDrawing.ModelSpace.AddText("Y=" & y, yins, H)
textobj.Color = acGreen

Next

err:
End

End Sub

zjsmlzp

njcknfy,你好

谢谢你发的坐标标注程序，能不能搞得注记X、Y之间的一水平线的长度与坐标数字串一样长？谢谢！

guzhiak

我是干工程测量的，以前比较少用cass，看版主技术了得，敢问一下怎么学得

wml88

cass5.1作方格网2条边不能和设计的重合,(既边不在整数上)如何办?

zjsmlzp

njcknfy，你好

    请给编个能在CAD2004或CAD2005中自动注记面积，能按要求数量调整面积的程序（CASS中有这程序）。谢谢！

wuling619

google earth 太好了

jdhszh

搂主一定对CASS很熟悉，请你给我解释一下...\SYSTEM下的index.ini和work.def都记录的是什么内容，我现在需要做一个从国标4位码的CAD图件转为存CASS的程序，请给予帮助。谢谢！

caizhiming

看来楼主对Auto CAD的熟悉程度达到了非一般的境界了啊！

我想请问楼主：

在Auto CAD中如何批量绘制1：10000的图框（54坐标系和80坐标系）

谢谢楼住了！！

caizhiminglcy@yahoo.com.cn

luohaoa

高贴！虽然我不是搞测量的！