<P>VBA编写的坐标标注程序（测量用）</P>
<P>Public Sub PTBZ()<BR>On Error Resume Next<BR>'创建名为"坐标标注"的新图层<BR> Dim layerObj As AcadLayer<BR> Set layerObj = ThisDrawing.Layers.Add("坐标标注")<BR> layerObj.Color = acRed<BR>'设置为当前图层<BR> Dim newlayer As AcadLayer<BR> Set newlayer = ThisDrawing.Layers("坐标标注")<BR> ThisDrawing.ActiveLayer = newlayer</P>
<P>'定义线<BR>Dim plineObj As AcadLWPolyline '二维轻量多段线<BR>Dim points(0 To 5) As Double<BR>Dim spnt As Variant '需标注点<BR>Dim epnt As Variant<BR>Dim textobj As AcadText<BR>Dim BZ As AcadTextStyle '文字样式<BR>Dim H As Double '文字高度<BR>Dim WZ As Double '文字位置<BR>Dim xins(0 To 2) As Double 'x坐标插入点<BR>Dim yins(0 To 2) As Double 'y坐标插入点</P>
<P>Set BZ = ThisDrawing.TextStyles.Add("BZ") '设定文字样式<BR>Set BZ = ThisDrawing.ActiveTextStyle<BR>BZ.width = 0.8<BR>BZ.fontFile = "romant.shx"</P>
<P><BR>On Error GoTo err<BR>H = ThisDrawing.Utility.GetReal("文字高度：")</P>
<P>'循环<BR> Dim counter As Integer<BR> For counter = 0 To 50</P>
<P>spnt = ThisDrawing.Utility.GetPoint(, vbCrLf & "标注点：")<BR>epnt = ThisDrawing.Utility.GetPoint(spnt, vbCr & "标注坐标")<BR>If IsEmpty(spnt) Then Exit Sub<BR>If H < 5 Then '调整文字位置<BR>WZ = 1<BR>Else<BR>WZ = Int(H / 5)<BR>End If</P>
<P>If epnt(0) > spnt(0) Then '定位文字位置<BR>xins(0) = epnt(0) + 0.5: xins(1) = epnt(1) + WZ: xins(2) = 0<BR>yins(0) = epnt(0) + 0.5: yins(1) = epnt(1) - (WZ + H): yins(2) = 0<BR>Else<BR>xins(0) = epnt(0) - H * 9.1: xins(1) = epnt(1) + 1: xins(2) = 0<BR>yins(0) = epnt(0) - H * 9.1: yins(1) = epnt(1) - (H + 1): yins(2) = 0<BR>End If</P>
<P>x = Format(spnt(1), "####0.000")<BR>y = Format(spnt(0), "####0.000")</P>
<P>points(0) = spnt(0): points(1) = spnt(1)<BR>points(2) = epnt(0): points(3) = epnt(1)<BR>If epnt(0) > spnt(0) Then<BR>points(4) = epnt(0) + H * 9.1: points(5) = epnt(1)<BR>Else<BR>points(4) = epnt(0) - H * 9.1: points(5) = epnt(1)<BR>End If</P>
<P>Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points) '二维轻量多段线<BR>Set textobj = ThisDrawing.ModelSpace.AddText("X=" & x, xins, H)<BR>textobj.Color = acGreen</P>
<P>Set textobj = ThisDrawing.ModelSpace.AddText("Y=" & y, yins, H)<BR>textobj.Color = acGreen</P>
<P><BR>Next</P>
<P>err:<BR>End</P>
<P>End Sub</P>
<P><A name=84476><FONT color=#000066><B>njcknfy</B></FONT></A>,你好</P>
<P>谢谢你发的坐标标注程序，能不能搞得注记X、Y之间的一水平线的长度与坐标数字串一样长？谢谢！</P>
<P>我是干工程测量的，以前比较少用cass，看版主技术了得，敢问一下怎么学得</P>
cass5.1作方格网2条边不能和设计的重合,(既边不在整数上)如何办?
<P><A name=84476><FONT color=#000066><B>njcknfy</B></FONT></A>，你好</P>
<P> 请给编个能在CAD2004或CAD2005中自动注记面积，能按要求数量调整面积的程序（CASS中有这程序）。谢谢！</P>
google earth 太好了
本帖最后由 作者 于 2006-2-6 10:33:12 编辑
搂主一定对CASS很熟悉，请你给我解释一下...\SYSTEM下的index.ini和work.def都记录的是什么内容，我现在需要做一个从国标4位码的CAD图件转为存CASS的程序，请给予帮助。谢谢！
<P>看来楼主对Auto CAD的熟悉程度达到了非一般的境界了啊！</P>
<P>我想请问楼主：</P>
<P>在Auto CAD中如何批量绘制1：10000的图框（54坐标系和80坐标系）</P>
<P>谢谢楼住了！！</P>
<P><A href="mailto:caizhiminglcy@yahoo.com.cn" target="_blank" >caizhiminglcy@yahoo.com.cn</A></P>
<P>高贴！虽然我不是搞测量的！</P>