[原创]批量改编号工具
本帖最后由 作者 于 2009-3-22 1:35:53 编辑 <br /><br /> <p> </p><p> 可针对相同前后缀的文本字符串，或所有文本字符串，将其中数字同步加减某一个数，要求其中只含一组数字。</p><p> </p><p></p><p></p><p></p><p>Option Explicit<br/>'相同前后缀的字符串中的数字同步增加或减少()<br/>Private Sub CommandButton1_Click()<br/> UserForm1.hide<br/> <br/> Dim prefix As String '前缀<br/> prefix = TextBox1.Text<br/> Dim postfix As String '后缀<br/> postfix = TextBox2.Text<br/> Dim StartNumber As Double '初值<br/> StartNumber = Val(TextBox3.Text)<br/> If TextBox3.Text = "" Then StartNumber = 1<br/> Dim EndNumber As Double '终值<br/> EndNumber = Val(TextBox4.Text)<br/> If TextBox4.Text = "" Then EndNumber = 1000000000000#<br/> Dim increment As Double '增量<br/> increment = Val(TextBox5.Text)<br/> <br/>'设置选择过滤器<br/> Dim FilterType(1) As Integer<br/> Dim FilterData(1) As Variant<br/> FilterType(0) = 0<br/> FilterData(0) = "text,mtext"<br/> FilterType(1) = 1<br/> FilterData(1) = prefix & "*" & postfix<br/> <br/>'安全创建选择集<br/> On Error Resume Next<br/> Dim SSet As AcadSelectionSet<br/> If Not IsNull(ThisDrawing.SelectionSets.Item("Example")) Then<br/> Set SSet = ThisDrawing.SelectionSets.Item("Example")<br/> SSet.Delete<br/> End If<br/> Set SSet = ThisDrawing.SelectionSets.Add("Example")<br/> SSet.SelectOnScreen FilterType, FilterData</p><p>'修改编号<br/> Dim TextObj As AcadEntity '文本<br/> Dim TextStr As String '文本字符串<br/> Dim NumberStr As Double '文本字符串中的数字<br/> Dim N As Long '统计修改编号个数<br/> N = 0<br/> For Each TextObj In SSet<br/> TextStr = TextObj.TextString<br/> If NumberOfTextStr(TextStr) <> "" Then '只对含有数字的文本进行操作<br/> NumberStr = Val(NumberOfTextStr(TextStr))<br/> If NumberStr >= StartNumber And NumberStr <= EndNumber Then<br/> NumberStr = NumberStr + increment<br/> TextStr = prefix & CStr(NumberStr) & postfix<br/> TextObj.TextString = TextStr<br/> N = N + 1<br/> End If<br/> End If<br/> Next<br/> MsgBox "共修改了" & N & "个编号！"<br/> UserForm1.Show<br/>End Sub</p><p>Private Sub CommandButton2_Click()<br/> TextBox1 = ""<br/> TextBox2 = ""<br/> TextBox3 = ""<br/> TextBox4 = ""<br/> TextBox5 = ""<br/>End Sub</p><p>Private Sub CommandButton3_Click()<br/> End<br/>End Sub</p><p>'提取字符串中的数字，其中只含有一处数字和小数点<br/>Function NumberOfTextStr(ByVal TextStr As String) As String<br/> Dim NumberStr As String<br/> NumberStr = ""<br/> Dim i As Long<br/> For i = 1 To Len(TextStr)<br/> If (Asc(Mid(TextStr, i, 1)) >= 48 And Asc(Mid(TextStr, i, 1)) <= 57) Or Asc(Mid(TextStr, i, 1)) = 46 Then<br/> NumberStr = NumberStr & Mid(TextStr, i, 1)<br/> End If<br/> Next i<br/> NumberOfTextStr = NumberStr<br/>End Function</p><p>Private Sub UserForm_Click()</p><p>End Sub</p><p></p><p><br/>Option Explicit<br/>'所有字符串中的数字同步增加或减少()<br/>Private Sub CommandButton1_Click()<br/> UserForm2.hide<br/> <br/> Dim StartNumber As Double '初值<br/> StartNumber = Val(TextBox1.Text)<br/> If TextBox1.Text = "" Then StartNumber = 1<br/> Dim EndNumber As Double '终值<br/> EndNumber = Val(TextBox2.Text)<br/> If TextBox2.Text = "" Then EndNumber = 1000000000000#<br/> Dim increment As Double '增量<br/> increment = Val(TextBox3.Text)<br/> <br/>'设置选择过滤器<br/> Dim FilterType(0) As Integer<br/> Dim FilterData(0) As Variant<br/> FilterType(0) = 0<br/> FilterData(0) = "text,mtext"<br/> <br/>'安全创建选择集<br/> On Error Resume Next<br/> Dim SSet As AcadSelectionSet<br/> If Not IsNull(ThisDrawing.SelectionSets.Item("Example")) Then<br/> Set SSet = ThisDrawing.SelectionSets.Item("Example")<br/> SSet.Delete<br/> End If<br/> Set SSet = ThisDrawing.SelectionSets.Add("Example")<br/> SSet.SelectOnScreen FilterType, FilterData</p><p>'修改编号<br/> Dim TextObj As AcadEntity '文本<br/> Dim TextStr As String '文本字符串<br/> Dim prefix As String '前缀<br/> Dim postfix As String '后缀<br/> Dim NumberStr As Double '文本字符串中的数字<br/> Dim N As Long '统计修改编号个数<br/> N = 0<br/> Dim i As Long<br/> For Each TextObj In SSet<br/> TextStr = TextObj.TextString<br/> prefix = ""<br/> postfix = ""<br/> If NumberOfTextStr(TextStr) <> "" Then '只对含有数字的文本进行操作<br/> For i = 1 To Len(TextStr) '取得数字的前缀<br/> If (Asc(Mid(TextStr, i, 1)) >= 48 And Asc(Mid(TextStr, i, 1)) <= 57) Or Asc(Mid(TextStr, i, 1)) = 46 Then<br/> Exit For<br/> Else<br/> prefix = prefix & Mid(TextStr, i, 1)<br/> End If<br/> Next i<br/> For i = Len(TextStr) To 1 Step -1 '取得数字的后缀<br/> If (Asc(Mid(TextStr, i, 1)) >= 48 And Asc(Mid(TextStr, i, 1)) <= 57) Or Asc(Mid(TextStr, i, 1)) = 46 Then<br/> Exit For<br/> Else<br/> postfix = Mid(TextStr, i, 1) & postfix<br/> End If<br/> Next i<br/> NumberStr = Val(NumberOfTextStr(TextStr))<br/> If NumberStr >= StartNumber And NumberStr <= EndNumber Then<br/> NumberStr = NumberStr + increment<br/> TextStr = prefix & CStr(NumberStr) & postfix<br/> TextObj.TextString = TextStr<br/> N = N + 1<br/> End If<br/> End If<br/> Next<br/> MsgBox "共修改了" & N & "个编号！"<br/> UserForm2.Show<br/>End Sub</p><p>Private Sub CommandButton2_Click()<br/> End<br/>End Sub</p><p>'提取字符串中的数字，其中只含有一处数字和小数点<br/>Function NumberOfTextStr(ByVal TextStr As String) As String<br/> Dim NumberStr As String<br/> NumberStr = ""<br/> Dim i As Double<br/> For i = 1 To Len(TextStr)<br/> If (Asc(Mid(TextStr, i, 1)) >= 48 And Asc(Mid(TextStr, i, 1)) <= 57) Or Asc(Mid(TextStr, i, 1)) = 46 Then<br/> NumberStr = NumberStr & Mid(TextStr, i, 1)<br/> End If<br/> Next i<br/> NumberOfTextStr = NumberStr<br/>End Function</p><p>Private Sub UserForm_Click()</p><p>End Sub</p><p></p><p> </p><p></p><p></p><p></p> 怎么沒有辦法看到圖片呢 <p>关注这个帖子</p> 关注 怎么用啊？？？？ 用正则表达式提取数字比较轻松，也不在乎你有多少个数字。 命令是什么怎么用啊在论坛里多泡泡，网上收收就知道怎么用了 谢谢楼主代码分享！很少看到有人发VBA代码 谢谢老师分享的内容
页:
[1]
2