[原创]批量改编号工具

dianbotang

 

 可针对相同前后缀的文本字符串，或所有文本字符串，将其中数字同步加减某一个数，要求其中只含一组数字。

 

Option Explicit
'相同前后缀的字符串中的数字同步增加或减少()
Private Sub CommandButton1_Click()
  UserForm1.hide
 
  Dim prefix As String '前缀
  prefix = TextBox1.Text
  Dim postfix As String '后缀
  postfix = TextBox2.Text
  Dim StartNumber As Double '初值
  StartNumber = Val(TextBox3.Text)
  If TextBox3.Text = "" Then StartNumber = 1
  Dim EndNumber As Double '终值
  EndNumber = Val(TextBox4.Text)
  If TextBox4.Text = "" Then EndNumber = 1000000000000#
  Dim increment As Double '增量
  increment = Val(TextBox5.Text)
 
'设置选择过滤器
  Dim FilterType(1) As Integer
  Dim FilterData(1) As Variant
  FilterType(0) = 0
  FilterData(0) = "text,mtext"
  FilterType(1) = 1
  FilterData(1) = prefix & "*" & postfix
 
'安全创建选择集
  On Error Resume Next
  Dim SSet As AcadSelectionSet
  If Not IsNull(ThisDrawing.SelectionSets.Item("Example")) Then
    Set SSet = ThisDrawing.SelectionSets.Item("Example")
    SSet.Delete
  End If
  Set SSet = ThisDrawing.SelectionSets.Add("Example")
  SSet.SelectOnScreen FilterType, FilterData

'修改编号
  Dim TextObj As AcadEntity '文本
  Dim TextStr As String '文本字符串
  Dim NumberStr As Double '文本字符串中的数字
  Dim N As Long '统计修改编号个数
  N = 0
  For Each TextObj In SSet
    TextStr = TextObj.TextString
    If NumberOfTextStr(TextStr) <> "" Then '只对含有数字的文本进行操作
      NumberStr = Val(NumberOfTextStr(TextStr))
      If NumberStr >= StartNumber And NumberStr <= EndNumber Then
        NumberStr = NumberStr + increment
        TextStr = prefix & CStr(NumberStr) & postfix
        TextObj.TextString = TextStr
        N = N + 1
      End If
    End If
  Next
  MsgBox "共修改了" & N & "个编号！"
  UserForm1.Show
End Sub

Private Sub CommandButton2_Click()
  TextBox1 = ""
  TextBox2 = ""
  TextBox3 = ""
  TextBox4 = ""
  TextBox5 = ""
End Sub

Private Sub CommandButton3_Click()
  End
End Sub

'提取字符串中的数字，其中只含有一处数字和小数点
Function NumberOfTextStr(ByVal TextStr As String) As String
  Dim NumberStr As String
  NumberStr = ""
  Dim i As Long
  For i = 1 To Len(TextStr)
    If (Asc(Mid(TextStr, i, 1)) >= 48 And Asc(Mid(TextStr, i, 1)) <= 57) Or Asc(Mid(TextStr, i, 1)) = 46 Then
      NumberStr = NumberStr & Mid(TextStr, i, 1)
    End If
  Next i
  NumberOfTextStr = NumberStr
End Function

Private Sub UserForm_Click()

End Sub

Option Explicit
'所有字符串中的数字同步增加或减少()
Private Sub CommandButton1_Click()
  UserForm2.hide
 
  Dim StartNumber As Double '初值
  StartNumber = Val(TextBox1.Text)
  If TextBox1.Text = "" Then StartNumber = 1
  Dim EndNumber As Double '终值
  EndNumber = Val(TextBox2.Text)
  If TextBox2.Text = "" Then EndNumber = 1000000000000#
  Dim increment As Double '增量
  increment = Val(TextBox3.Text)
 
'设置选择过滤器
  Dim FilterType(0) As Integer
  Dim FilterData(0) As Variant
  FilterType(0) = 0
  FilterData(0) = "text,mtext"
 
'安全创建选择集
  On Error Resume Next
  Dim SSet As AcadSelectionSet
  If Not IsNull(ThisDrawing.SelectionSets.Item("Example")) Then
    Set SSet = ThisDrawing.SelectionSets.Item("Example")
    SSet.Delete
  End If
  Set SSet = ThisDrawing.SelectionSets.Add("Example")
  SSet.SelectOnScreen FilterType, FilterData

'修改编号
  Dim TextObj As AcadEntity '文本
  Dim TextStr As String '文本字符串
  Dim prefix As String '前缀
  Dim postfix As String '后缀
  Dim NumberStr As Double '文本字符串中的数字
  Dim N As Long '统计修改编号个数
  N = 0
  Dim i As Long
  For Each TextObj In SSet
    TextStr = TextObj.TextString
    prefix = ""
    postfix = ""
    If NumberOfTextStr(TextStr) <> "" Then '只对含有数字的文本进行操作
      For i = 1 To Len(TextStr) '取得数字的前缀
        If (Asc(Mid(TextStr, i, 1)) >= 48 And Asc(Mid(TextStr, i, 1)) <= 57) Or Asc(Mid(TextStr, i, 1)) = 46 Then
          Exit For
        Else
          prefix = prefix & Mid(TextStr, i, 1)
        End If
      Next i
      For i = Len(TextStr) To 1 Step -1 '取得数字的后缀
        If (Asc(Mid(TextStr, i, 1)) >= 48 And Asc(Mid(TextStr, i, 1)) <= 57) Or Asc(Mid(TextStr, i, 1)) = 46 Then
          Exit For
        Else
          postfix = Mid(TextStr, i, 1) & postfix
        End If
      Next i
      NumberStr = Val(NumberOfTextStr(TextStr))
      If NumberStr >= StartNumber And NumberStr <= EndNumber Then
        NumberStr = NumberStr + increment
        TextStr = prefix & CStr(NumberStr) & postfix
        TextObj.TextString = TextStr
        N = N + 1
      End If
    End If
  Next
  MsgBox "共修改了" & N & "个编号！"
  UserForm2.Show
End Sub

Private Sub CommandButton2_Click()
  End
End Sub

'提取字符串中的数字，其中只含有一处数字和小数点
Function NumberOfTextStr(ByVal TextStr As String) As String
  Dim NumberStr As String
  NumberStr = ""
  Dim i As Double
  For i = 1 To Len(TextStr)
    If (Asc(Mid(TextStr, i, 1)) >= 48 And Asc(Mid(TextStr, i, 1)) <= 57) Or Asc(Mid(TextStr, i, 1)) = 46 Then
      NumberStr = NumberStr & Mid(TextStr, i, 1)
    End If
  Next i
  NumberOfTextStr = NumberStr
End Function

Private Sub UserForm_Click()

End Sub

 

kunlongmann

怎么沒有辦法看到圖片呢

兰州人

关注这个帖子

3wlds

关注   

lqyqyy

怎么用啊？？？？

znyan

用正则表达式提取数字比较轻松，也不在乎你有多少个数字。

blues_眼语

命令是什么怎么用啊

wwswwswws

在论坛里多泡泡，网上收收就知道怎么用了

清风明月名字

谢谢楼主代码分享！很少看到有人发VBA代码

zhangcan0515

谢谢老师分享的内容