可以给源码吗
密码是多少啊！
<p>密码记不得了，下面是源码，可能和前面发的不完全一致。<br/><br/>'<br/>' 本软件免费可供进行任何用途需求的拷贝、修改及发行, 但请遵循下述原则:<br/>'<br/>' 1) 上列的版权通告必须出现在每一份拷贝里。<br/>' 2) 相关的说明文档也必须载有版权通告及本项许可通告。<br/>'<br/>' 本软件仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊<br/>' 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。</p><p>Sub copyAndChangeH()<br/> ThisDrawing.Utility.Prompt "欢迎使用《复制并改变标高》启动命令:CopyAndChangeH"<br/> '选择文字<br/> Dim ssetobjEx() As AcadObject<br/> On Error Resume Next<br/> <br/> Dim ssetobj As AcadSelectionSet<br/> ThisDrawing.SelectionSets("copyText").Delete<br/> Set ssetobj = ThisDrawing.SelectionSets.Add("copyText")<br/> <br/> ssetobj.SelectOnScreen<br/> If ssetobj.Count = 0 Then GoTo Finish '如果没有选择物体，结束程序<br/> <br/> Dim pickedObjs As AcadEntity<br/> ReDim ssetobjEx(0 To ssetobj.Count - 1) '数组，把复制后的物体成为ssetobj集合的中间步骤<br/> Dim k As Integer 'K为ssetobjex的下标<br/> Dim Att1 As Variant<br/> Dim n As Double<br/> n = getDrawScale / getPrintScale<br/> <br/> Dim pnt1, pnt2 As Variant<br/> pnt1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "选择复制起始点:")<br/> If Err Then GoTo Finish<br/> <br/>100 pnt2 = ThisDrawing.Utility.GetPoint(pnt1, vbCrLf & "选择复制终点:")<br/> If Err Then GoTo Finish<br/> k = 0<br/> For Each pickedObjs In ssetobj<br/> Set pickedObjsCopy = pickedObjs.Copy<br/> pickedObjsCopy.Move pnt1, pnt2<br/> <br/> If pickedObjsCopy.ObjectName = "AcDbText" Then<br/> weishu = Len(pickedObjsCopy.TextString) - InStr(pickedObjsCopy.TextString, ".")<br/> formatstring1 = "0." & String(weishu, "0")<br/> If InStr(UCase(pickedObjsCopy.TextString), "%%P") <> 0 Then<br/> pickedObjsCopy.TextString = Right(pickedObjsCopy.TextString, Len(pickedObjsCopy.TextString) - 3)<br/> End If<br/> '如果有正负号，则先去除<br/> pickedObjsCopy.TextString = _<br/> Format(pickedObjsCopy.TextString + (pnt2(1) - pnt1(1)) * n / 1000, formatstring1)<br/> '如果数字等于0，则加正负号<br/> If Val(pickedObjsCopy.TextString) = 0 Then pickedObjsCopy.TextString = "%%p0.000"<br/> <br/> ElseIf pickedObjs.ObjectName = "AcDbBlockReference" Then<br/> Att1 = pickedObjsCopy.GetAttributes()<br/> weishu = Len(Att1(0).TextString) - InStr(Att1(0).TextString, ".")<br/> '如果有正负号，则先去除<br/> If InStr(UCase(Att1(0).TextString), "%%P") <> 0 Then<br/> Att1(0).TextString = Right(Att1(0).TextString, Len(Att1(0).TextString) - 3)<br/> End If<br/> formatstring1 = "0." & String(weishu, "0")<br/> Att1(0).TextString = _<br/> Format(Att1(0).TextString + (pnt2(1) - pnt1(1)) * n / 1000, formatstring1)<br/> '如果数字等于0，则加正负号<br/> If Val(Att1(0).TextString) = 0 Then Att1(0).TextString = "%%p0.000"<br/> End If<br/> Set ssetobjEx(k) = pickedObjsCopy<br/> k = k + 1<br/> Next<br/> pnt1 = pnt2<br/> ssetobj.Clear<br/> ssetobj.AddItems ssetobjEx<br/> Err.Clear<br/> GoTo 100<br/>Finish:<br/> ssetobj.Delete<br/>End Sub<br/>Public Function getDrawScale() As Double<br/> On Error Resume Next<br/> Dim res As Integer<br/> Dim def As Integer<br/> def = ThisDrawing.GetVariable("USERI4")<br/> Do<br/> res = ThisDrawing.Utility.GetInteger("请输入图形比例,例1:100应该输入100<" & def & ">:")<br/> If Err Then Err.Clear: res = def<br/> If res <> 0 Then Exit Do<br/> Loop<br/> ThisDrawing.SetVariable "USERI4", res<br/> getDrawScale = res<br/>End Function<br/>Public Function getPrintScale() As Double<br/> On Error Resume Next<br/> Dim res As Integer<br/> res = ThisDrawing.GetVariable("USERI5")<br/> If res = 0 Then<br/> res = ThisDrawing.Utility.GetInteger("请输入图形打印输出比例,例100:1应该输入100<1>:")<br/> If Err Then Err.Clear: res = 1<br/> ThisDrawing.SetVariable "USERI5", res<br/> End If<br/> getPrintScale = res<br/>End Function<br/></p>
<p>可以复制，不会自动计算修改标高.</p>
<p>不过还是谢谢楼主。</p>
谢谢，受益非浅
怎么用的呵！下了！什么都不变！感觉和COG一样
能用的示范一下撒，好像数字不会变的
这个我怎么没想过呢，至少思路就很好啊