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熱心網友回復：
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熱心網友回復：
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熱心網友回復：
CAD 的？給什么賦值啊…………
未安裝CAD，一直沒使用過這個軟體。
uj5u.com熱心網友回復：
其實就是vba開發的，就是加一個 宗地圖屬性 宗地號加個前綴從100開始遞增的數就可以了。謝謝！
uj5u.com熱心網友回復：
不清楚你要給什么賦值、如何賦值啊。沒有使用過這軟體，自然不知道你說的 “宗地圖屬性”是什么東東……
你要“自動賦值”，
知道起始值和終止值（也就是次數在回圈之前能確定），可以用 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
uj5u.com熱心網友回復：
不是很明白。不知這樣行不行：先定義一個模塊級或全域變數count并初始化為100，然后在case 4部分添加一句代碼 count=count+1在需要的時候判斷count.....
uj5u.com熱心網友回復：
哪位大哥可以給解釋下上面的代碼都是些什么意思呢？
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/134074.html
標籤：VBA