[VBA]一个复制标高后同时改变标高数字的dvb文件

samshs

可以给源码吗

meteorrite

密码是多少啊！

subtlation

密码记不得了，下面是源码，可能和前面发的不完全一致。

'
'   本软件免费可供进行任何用途需求的拷贝、修改及发行, 但请遵循下述原则:
'
'   1)  上列的版权通告必须出现在每一份拷贝里。
'   2)  相关的说明文档也必须载有版权通告及本项许可通告。
'
'   本软件仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊
'   用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认。

Sub copyAndChangeH()
  ThisDrawing.Utility.Prompt "欢迎使用《复制并改变标高》启动命令:CopyAndChangeH"
  '选择文字
  Dim ssetobjEx() As AcadObject
  On Error Resume Next
 
  Dim ssetobj As AcadSelectionSet
  ThisDrawing.SelectionSets("copyText").Delete
  Set ssetobj = ThisDrawing.SelectionSets.Add("copyText")
 
  ssetobj.SelectOnScreen
  If ssetobj.Count = 0 Then GoTo Finish '如果没有选择物体，结束程序
 
  Dim pickedObjs As AcadEntity
  ReDim ssetobjEx(0 To ssetobj.Count - 1) '数组，把复制后的物体成为ssetobj集合的中间步骤
  Dim k As Integer 'K为ssetobjex的下标
  Dim Att1 As Variant
  Dim n As Double
  n = getDrawScale / getPrintScale
 
  Dim pnt1, pnt2 As Variant
  pnt1 = ThisDrawing.Utility.GetPoint(, vbCrLf & "选择复制起始点:")
  If Err Then GoTo Finish
 
100   pnt2 = ThisDrawing.Utility.GetPoint(pnt1, vbCrLf & "选择复制终点:")
  If Err Then GoTo Finish
  k = 0
  For Each pickedObjs In ssetobj
    Set pickedObjsCopy = pickedObjs.Copy
    pickedObjsCopy.Move pnt1, pnt2
   
    If pickedObjsCopy.ObjectName = "AcDbText" Then
      weishu = Len(pickedObjsCopy.TextString) - InStr(pickedObjsCopy.TextString, ".")
      formatstring1 = "0." & String(weishu, "0")
      If InStr(UCase(pickedObjsCopy.TextString), "%%P") <> 0 Then
        pickedObjsCopy.TextString = Right(pickedObjsCopy.TextString, Len(pickedObjsCopy.TextString) - 3)
      End If
      '如果有正负号，则先去除
      pickedObjsCopy.TextString = _
         Format(pickedObjsCopy.TextString + (pnt2(1) - pnt1(1)) * n / 1000, formatstring1)
      '如果数字等于0，则加正负号
      If Val(pickedObjsCopy.TextString) = 0 Then pickedObjsCopy.TextString = "%%p0.000"
   
    ElseIf pickedObjs.ObjectName = "AcDbBlockReference" Then
      Att1 = pickedObjsCopy.GetAttributes()
      weishu = Len(Att1(0).TextString) - InStr(Att1(0).TextString, ".")
      '如果有正负号，则先去除
      If InStr(UCase(Att1(0).TextString), "%%P") <> 0 Then
        Att1(0).TextString = Right(Att1(0).TextString, Len(Att1(0).TextString) - 3)
      End If
      formatstring1 = "0." & String(weishu, "0")
      Att1(0).TextString = _
         Format(Att1(0).TextString + (pnt2(1) - pnt1(1)) * n / 1000, formatstring1)
      '如果数字等于0，则加正负号
      If Val(Att1(0).TextString) = 0 Then Att1(0).TextString = "%%p0.000"
  End If
    Set ssetobjEx(k) = pickedObjsCopy
    k = k + 1
  Next
  pnt1 = pnt2
  ssetobj.Clear
  ssetobj.AddItems ssetobjEx
  Err.Clear
  GoTo 100
Finish:
  ssetobj.Delete
End Sub
Public Function getDrawScale() As Double
  On Error Resume Next
  Dim res As Integer
  Dim def As Integer
  def = ThisDrawing.GetVariable("USERI4")
  Do
    res = ThisDrawing.Utility.GetInteger("请输入图形比例,例1:100应该输入100<" & def & ">:")
    If Err Then Err.Clear: res = def
    If res <> 0 Then Exit Do
  Loop
  ThisDrawing.SetVariable "USERI4", res
  getDrawScale = res
End Function
Public Function getPrintScale() As Double
  On Error Resume Next
  Dim res As Integer
  res = ThisDrawing.GetVariable("USERI5")
  If res = 0 Then
    res = ThisDrawing.Utility.GetInteger("请输入图形打印输出比例,例100:1应该输入100<1>:")
    If Err Then Err.Clear: res = 1
    ThisDrawing.SetVariable "USERI5", res
  End If
  getPrintScale = res
End Function

461045462

可以复制，不会自动计算修改标高.

不过还是谢谢楼主。

zhouxiuxin

谢谢，受益非浅

oo191522416

怎么用的呵！下了！什么都不变！感觉和COG一样

注册

能用的示范一下撒，好像数字不会变的

3xxx

这个我怎么没想过呢，至少思路就很好啊