自动赋值代码？100开始递增？？？？

zero8500 2013-11-26 01:10:02

Private Function getSouthBM(ByRef aEnt As AcadEntity) As String

On Error GoTo EH

  getSouthBM = getSouthX(aEnt)

EH:

  'Debug.Print "产生错误于模块  getSouthCodeBM,错误说明为:     " & Err.Description

End Function





Private Function getSouthX(ByRef aEnt As AcadEntity, Optional idx As Integer = 1) As String

On Error GoTo EH



    Dim xdataOut As Variant

    Dim xtypeOut As Variant

    Dim groupCode As Variant, dataCode As Variant

    aEnt.GetXData "SOUTH", xtypeOut, xdataOut

    If IsEmpty(xtypeOut) Then

      getSouthX = ""

    Else

      getSouthX = CStr(xdataOut(idx))

    End If

    Exit Function

EH:



End Function

Private Sub setSouthX(ByRef aEnt As AcadEntity, ByRef sVal As String, Optional idx As Integer = 1)

On Error GoTo EH



    Dim xdataOut As Variant

    Dim xtypeOut As Variant

    Dim groupCode As Variant, dataCode As Variant

    aEnt.GetXData "SOUTH", xtypeOut, xdataOut

    xdataOut(idx) = sVal

    aEnt.SetXData xtypeOut, xdataOut



    

    Exit Sub

EH:



End Sub











Private Function getSouthZDH(ByRef aEnt As AcadEntity) As String

On Error GoTo EH

  getSouthZDH = getSouthX(aEnt, 2)

EH:



End Function

Private Function getSouthQLR(ByRef aEnt As AcadEntity) As String

On Error GoTo EH

  getSouthQLR = getSouthX(aEnt, 3)

EH:



End Function



Private Function getSouthDLH(ByRef aEnt As AcadEntity) As String

On Error GoTo EH

  getSouthDLH = getSouthX(aEnt, 4)

EH:



End Function



Private Sub BatchModify(idx As Integer)

 'idx =2 修改宗地号 idx =3 修改权利人 idx =4 修改地类

On Error Resume Next

  Dim aEnt As AcadEntity

  Dim sOld As String

  Dim sNew As String

  '<1>加前缀<2>加后缀<3>字符替换

  Dim sPstr As String '前缀

  Dim sEstr As String '后缀

  Dim sFind, sReplace As String

  Dim sOp As String

  

  sFind = ""

  sReplace = ""

  sPstr = ""

  sEstr = ""

  

  sOp = ThisDrawing.Utility.GetString(False, "<1>加前缀<2>加后缀<3>字符替换<4>前缀自动赋值")

  

  Select Case CInt(sOp)

    Case 1

      sPstr = ThisDrawing.Utility.GetString(False, "输入前缀 :" + vbCrLf)

    Case 2

      sEstr = ThisDrawing.Utility.GetString(False, vbCrLf & "输入后缀 :" + vbCrLf)

    Case 3

      sFind = ThisDrawing.Utility.GetString(False, vbCrLf & "请输入查找的字符 :" + vbCrLf)

      sReplace = ThisDrawing.Utility.GetString(True, vbCrLf & "请输入替换的字符 :" + vbCrLf)

    Case 4

    

        自动赋值代码？100开始递增？？？？？？？？？？

          

？？？？？？？？？？？？？？？？？？？？？？？



    Case Else

  End Select

    



  For Each aEnt In ThisDrawing.ModelSpace

    If getSouthBM(aEnt) = "300000" Then  '权属线

      sOld = getSouthX(aEnt, idx)



      If sReplace = " " Then sReplace = ""

      sNew = sPstr & Replace(sOld, sFind, sRepalce) & sEstr

      setSouthX aEnt, sNew, idx

      

    End If

  Next

  



End Sub



Public Sub modifyDJH()

BatchModify (2)

End Sub



Public Sub modifyQLR()

BatchModify (3)

End Sub

Public Sub modifyDLH()

BatchModify (4)

End Sub

大家好，请问CAD中这样子的修改属性，自动赋值怎么修改这段代码呢？谢谢！

...全文

392 7 打赏收藏转发到动态举报

写回复

用AI写文章

7 条回复

切换为时间正序

请发表友善的回复…

发表回复

zero8500 2013-11-27

打赏
举报

引用 2 楼 zero8500 的回复:

Private Function getSouthBM(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthBM = getSouthX(aEnt)
EH:
  'Debug.Print "产生错误于模块  getSouthCodeBM,错误说明为:     " & Err.Description
End Function


Private Function getSouthX(ByRef aEnt As AcadEntity, Optional idx As Integer = 1) As String
On Error GoTo EH

    Dim xdataOut As Variant
    Dim xtypeOut As Variant
    Dim groupCode As Variant, dataCode As Variant
    aEnt.GetXData "SOUTH", xtypeOut, xdataOut
    If IsEmpty(xtypeOut) Then
      getSouthX = ""
    Else
      getSouthX = CStr(xdataOut(idx))
    End If
    Exit Function
EH:

End Function
Private Sub setSouthX(ByRef aEnt As AcadEntity, ByRef sVal As String, Optional idx As Integer = 1)
On Error GoTo EH

    Dim xdataOut As Variant
    Dim xtypeOut As Variant
    Dim groupCode As Variant, dataCode As Variant
    aEnt.GetXData "SOUTH", xtypeOut, xdataOut
    xdataOut(idx) = sVal
    aEnt.SetXData xtypeOut, xdataOut

    
    Exit Sub
EH:

End Sub





Private Function getSouthZDH(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthZDH = getSouthX(aEnt, 2)
EH:

End Function
Private Function getSouthQLR(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthQLR = getSouthX(aEnt, 3)
EH:

End Function

Private Function getSouthDLH(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthDLH = getSouthX(aEnt, 4)
EH:

End Function

Private Sub BatchModify(idx As Integer)
 'idx =2 修改宗地号 idx =3 修改权利人 idx =4 修改地类
On Error Resume Next
  Dim aEnt As AcadEntity
  Dim sOld As String
  Dim sNew As String
  '<1>加前缀<2>加后缀<3>字符替换
  Dim sPstr As String '前缀
  Dim sEstr As String '后缀
  Dim sFind, sReplace As String
  Dim sOp As String
  
  sFind = ""
  sReplace = ""
  sPstr = ""
  sEstr = ""
  
  sOp = ThisDrawing.Utility.GetString(False, "<1>加前缀<2>加后缀<3>字符替换<4>前缀自动赋值")
  
  Select Case CInt(sOp)
    Case 1
      sPstr = ThisDrawing.Utility.GetString(False, "输入前缀 :" + vbCrLf)
    Case 2
      sEstr = ThisDrawing.Utility.GetString(False, vbCrLf & "输入后缀 :" + vbCrLf)
    Case 3
      sFind = ThisDrawing.Utility.GetString(False, vbCrLf & "请输入查找的字符 :" + vbCrLf)
      sReplace = ThisDrawing.Utility.GetString(True, vbCrLf & "请输入替换的字符 :" + vbCrLf)
    Case 4
    
        自动赋值代码？100开始递增？？？？？？？？？？
          
？？？？？？？？？？？？？？？？？？？？？？？

    Case Else
  End Select
    

  For Each aEnt In ThisDrawing.ModelSpace
    If getSouthBM(aEnt) = "300000" Then  '权属线
      sOld = getSouthX(aEnt, idx)

      If sReplace = " " Then sReplace = ""
      sNew = sPstr & Replace(sOld, sFind, sRepalce) & sEstr
      setSouthX aEnt, sNew, idx
      
    End If
  Next
  

End Sub

Public Sub modifyDJH()
BatchModify (2)
End Sub

Public Sub modifyQLR()
BatchModify (3)
End Sub
Public Sub modifyDLH()
BatchModify (4)
End Sub

大家好，请问CAD中这样子的修改属性，自动赋值怎么修改这段代码呢？谢谢！

哪位大哥可以给解释下上面的代码都是些什么意思呢？

一如既往哈 2013-11-26

打赏
举报

不是很明白。不知这样行不行：先定义一个模块级或全局变量count并初始化为100，然后在case 4部分添加一句代码 count=count+1 在需要的时候判断count.....

舉杯邀明月 2013-11-26

打赏
举报

不清楚你要给什么赋值、如何赋值啊。没有使用过这软件，自然不知道你说的 “宗地图属性”是什么东东…… 你要“自动赋值”，知道起始值和终止值（也就是次数在循环之前能确定），可以用 For循环。不知道次数，但有别的能确定“终止条件”的，可以用Do .... Loop 相信在CAD的VBA代码中，这些语法肯定能支持的。 for 循环： dim iPVal as long iPVal = XXXXX '（这儿用适当的方法计算出终值） for iPVal = 100 to iPVal step 100 sPstr = iPval & ........ ' 加上你需要添加的其它字符 ........... ' 赋值及其它操作 next 用do 循环（两种结束循环的方法，按你的实际环境选择其一）： dim iPVal as long iPVal = 0 do ' 结束循环的方法之一 if (已经没有对象来赋值) then exit do iPVal = iPVal +100 sPstr = iPval & ........ ' 加上你需要添加的其它字符 ........... ' 赋值及其它操作 ' 结束循环的方法之二 if (识别到这是最后一个对象) then exit do loop

zero8500 2013-11-26

打赏
举报

引用 3 楼 Chen8013 的回复:

CAD 的？给什么赋值啊………… 未安装CAD，一直没使用过这个软件。

其实就是vba开发的，就是加一个宗地图属性宗地号加个前缀从100开始递增的数就可以了。谢谢！

舉杯邀明月 2013-11-26

打赏
举报

CAD 的？给什么赋值啊………… 未安装CAD，一直没使用过这个软件。

zero8500 2013-11-26

打赏
举报

Private Function getSouthBM(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthBM = getSouthX(aEnt)
EH:
  'Debug.Print "产生错误于模块  getSouthCodeBM,错误说明为:     " & Err.Description
End Function


Private Function getSouthX(ByRef aEnt As AcadEntity, Optional idx As Integer = 1) As String
On Error GoTo EH

    Dim xdataOut As Variant
    Dim xtypeOut As Variant
    Dim groupCode As Variant, dataCode As Variant
    aEnt.GetXData "SOUTH", xtypeOut, xdataOut
    If IsEmpty(xtypeOut) Then
      getSouthX = ""
    Else
      getSouthX = CStr(xdataOut(idx))
    End If
    Exit Function
EH:

End Function
Private Sub setSouthX(ByRef aEnt As AcadEntity, ByRef sVal As String, Optional idx As Integer = 1)
On Error GoTo EH

    Dim xdataOut As Variant
    Dim xtypeOut As Variant
    Dim groupCode As Variant, dataCode As Variant
    aEnt.GetXData "SOUTH", xtypeOut, xdataOut
    xdataOut(idx) = sVal
    aEnt.SetXData xtypeOut, xdataOut

    
    Exit Sub
EH:

End Sub





Private Function getSouthZDH(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthZDH = getSouthX(aEnt, 2)
EH:

End Function
Private Function getSouthQLR(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthQLR = getSouthX(aEnt, 3)
EH:

End Function

Private Function getSouthDLH(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthDLH = getSouthX(aEnt, 4)
EH:

End Function

Private Sub BatchModify(idx As Integer)
 'idx =2 修改宗地号 idx =3 修改权利人 idx =4 修改地类
On Error Resume Next
  Dim aEnt As AcadEntity
  Dim sOld As String
  Dim sNew As String
  '<1>加前缀<2>加后缀<3>字符替换
  Dim sPstr As String '前缀
  Dim sEstr As String '后缀
  Dim sFind, sReplace As String
  Dim sOp As String
  
  sFind = ""
  sReplace = ""
  sPstr = ""
  sEstr = ""
  
  sOp = ThisDrawing.Utility.GetString(False, "<1>加前缀<2>加后缀<3>字符替换<4>前缀自动赋值")
  
  Select Case CInt(sOp)
    Case 1
      sPstr = ThisDrawing.Utility.GetString(False, "输入前缀 :" + vbCrLf)
    Case 2
      sEstr = ThisDrawing.Utility.GetString(False, vbCrLf & "输入后缀 :" + vbCrLf)
    Case 3
      sFind = ThisDrawing.Utility.GetString(False, vbCrLf & "请输入查找的字符 :" + vbCrLf)
      sReplace = ThisDrawing.Utility.GetString(True, vbCrLf & "请输入替换的字符 :" + vbCrLf)
    Case 4
    
        自动赋值代码？100开始递增？？？？？？？？？？
          
？？？？？？？？？？？？？？？？？？？？？？？

    Case Else
  End Select
    

  For Each aEnt In ThisDrawing.ModelSpace
    If getSouthBM(aEnt) = "300000" Then  '权属线
      sOld = getSouthX(aEnt, idx)

      If sReplace = " " Then sReplace = ""
      sNew = sPstr & Replace(sOld, sFind, sRepalce) & sEstr
      setSouthX aEnt, sNew, idx
      
    End If
  Next
  

End Sub

Public Sub modifyDJH()
BatchModify (2)
End Sub

Public Sub modifyQLR()
BatchModify (3)
End Sub
Public Sub modifyDLH()
BatchModify (4)
End Sub

大家好，请问CAD中这样子的修改属性，自动赋值怎么修改这段代码呢？谢谢！

zero8500 2013-11-26

打赏
举报

Private Function getSouthBM(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthBM = getSouthX(aEnt)
EH:
  'Debug.Print "产生错误于模块  getSouthCodeBM,错误说明为:     " & Err.Description
End Function


Private Function getSouthX(ByRef aEnt As AcadEntity, Optional idx As Integer = 1) As String
On Error GoTo EH

    Dim xdataOut As Variant
    Dim xtypeOut As Variant
    Dim groupCode As Variant, dataCode As Variant
    aEnt.GetXData "SOUTH", xtypeOut, xdataOut
    If IsEmpty(xtypeOut) Then
      getSouthX = ""
    Else
      getSouthX = CStr(xdataOut(idx))
    End If
    Exit Function
EH:

End Function
Private Sub setSouthX(ByRef aEnt As AcadEntity, ByRef sVal As String, Optional idx As Integer = 1)
On Error GoTo EH

    Dim xdataOut As Variant
    Dim xtypeOut As Variant
    Dim groupCode As Variant, dataCode As Variant
    aEnt.GetXData "SOUTH", xtypeOut, xdataOut
    xdataOut(idx) = sVal
    aEnt.SetXData xtypeOut, xdataOut

    
    Exit Sub
EH:

End Sub





Private Function getSouthZDH(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthZDH = getSouthX(aEnt, 2)
EH:

End Function
Private Function getSouthQLR(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthQLR = getSouthX(aEnt, 3)
EH:

End Function

Private Function getSouthDLH(ByRef aEnt As AcadEntity) As String
On Error GoTo EH
  getSouthDLH = getSouthX(aEnt, 4)
EH:

End Function

Private Sub BatchModify(idx As Integer)
 'idx =2 修改宗地号 idx =3 修改权利人 idx =4 修改地类
On Error Resume Next
  Dim aEnt As AcadEntity
  Dim sOld As String
  Dim sNew As String
  '<1>加前缀<2>加后缀<3>字符替换
  Dim sPstr As String '前缀
  Dim sEstr As String '后缀
  Dim sFind, sReplace As String
  Dim sOp As String
  
  sFind = ""
  sReplace = ""
  sPstr = ""
  sEstr = ""
  
  sOp = ThisDrawing.Utility.GetString(False, "<1>加前缀<2>加后缀<3>字符替换<4>前缀自动赋值")
  
  Select Case CInt(sOp)
    Case 1
      sPstr = ThisDrawing.Utility.GetString(False, "输入前缀 :" + vbCrLf)
    Case 2
      sEstr = ThisDrawing.Utility.GetString(False, vbCrLf & "输入后缀 :" + vbCrLf)
    Case 3
      sFind = ThisDrawing.Utility.GetString(False, vbCrLf & "请输入查找的字符 :" + vbCrLf)
      sReplace = ThisDrawing.Utility.GetString(True, vbCrLf & "请输入替换的字符 :" + vbCrLf)
    Case 4
    
        自动赋值代码？100开始递增？？？？？？？？？？
          
？？？？？？？？？？？？？？？？？？？？？？？

    Case Else
  End Select
    

  For Each aEnt In ThisDrawing.ModelSpace
    If getSouthBM(aEnt) = "300000" Then  '权属线
      sOld = getSouthX(aEnt, idx)

      If sReplace = " " Then sReplace = ""
      sNew = sPstr & Replace(sOld, sFind, sRepalce) & sEstr
      setSouthX aEnt, sNew, idx
      
    End If
  Next
  

End Sub

Public Sub modifyDJH()
BatchModify (2)
End Sub

Public Sub modifyQLR()
BatchModify (3)
End Sub
Public Sub modifyDLH()
BatchModify (4)
End Sub

大家好，请问CAD中这样子的修改属性，自动赋值怎么修改这段代码呢？谢谢！

这是一套系统学习C++新标准(C++11/14起步)的课程。课程系统且全面，理论与代码结合，每节课程都会用最简洁的代码讲解对应C++语法点，同时每节课还配了高清字幕，非常通俗易懂。课程共分为三篇：1) 基础篇：这部分主要学习零散的基础语法，比如变量、常量、运算符、数据类型、enum、union、数组、动态数组、字符串、条件结构、循环结构、函数、指针(非常重要)、引用(非常重要，包括C++11开始引入的右值、右值引用)等。2) 面向对象篇：这部分是C++的核心。主要讲解struct、类与对象(其中C++11开始引入的移动构造、移动赋值等非常重要！)、友元、运算符重载、继承(单继承、多继承、虚基类等)、多态(虚函数、纯虚函数等)。3) 模板篇：自定义模板(template，包括函数模板和类模板)、模板的全特化和偏特化、使用C++标准库提供的模板(比如智能指针、STL)等。

rec=0 def autoIncrement(): global rec pStart = 1 pInterval = 1 if (rec == 0): rec = pStart else: rec = rec + pInterval return rec 以上是python代码块，在字段里输入autoIncrement()即可 ...

矢量数据自动编号

1、模糊C均值聚类结果总结如下，需要实现自动给index?赋值，代替下面的代码： 2、即：

arcgis中怎样给字段按1、2、3……赋值 rec=0 def autoIncrement(): global rec pStart = 1 pInterval = 1 if (rec == 0): rec = pStart else: rec = rec + pInterval return rec 以上是python代码块，在字段里输入autoIncre...