自动赋值代码？100开始递增？？？？
本帖最后由 bcrun 于 2013-11-29 14:31:08 编辑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中这样子的修改属性，自动赋值怎么修改这段代码呢？谢谢！
Private Function getSouthBM(ByRef aEnt As AcadEntity) As StringCAD 的？
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中这样子的修改属性，自动赋值怎么修改这段代码呢？谢谢！
给什么赋值啊…………
未安装CAD，一直没使用过这个软件。
其实就是vba开发的，就是加一个 宗地图属性 宗地号加个前缀从100开始递增的数就可以了。谢谢！ 不清楚你要给什么赋值、如何赋值啊。
没有使用过这软件，自然不知道你说的 “宗地图属性”是什么东东……
你要“自动赋值”，
知道起始值和终止值（也就是次数在循环之前能确定），可以用 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 不是很明白。不知这样行不行：先定义一个模块级或全局变量count并初始化为100，然后在case 4部分添加一句代码 count=count+1
在需要的时候判断count.....
哪位大哥可以给解释下上面的代码都是些什么意思呢？
补充：VB , VBA
