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中這樣子的修改屬性，自動賦值怎么修改這段代碼呢？謝謝！
uj5u.com熱心網友回復：
坐等啊，急用uj5u.com熱心網友回復：
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中這樣子的修改屬性，自動賦值怎么修改這段代碼呢？謝謝！
uj5u.com熱心網友回復：
Case 4 自動賦值代碼？100開始遞增？？？？？？？？？？ ？？？？？？？？？？？？？？？？？？？？？？？
在case 4部分添加一句 count=count+1不就久可以了嗎?
當然，count為一個模塊級或全域變數，且初始值為100
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/134072.html
標籤：VBA