[编程交流] 最大VBA数

Blockslist = Array("Block-1", "Block-7", "Block-35", "Block-2", "Block-11")

Dim BlockItem As Integer
Dim LastIndex As String: Dim CurrentIndex As String
LastIndex = Mid(Blockslist(0), 7)                'retain first index as reference
For BlockItem = 1 To UBound(Blockslist)
   CurrentIndex = Mid(Blockslist(BlockItem), 7)
   If CInt(CurrentIndex) > CInt(LastIndex) Then   'compare with current item's index
       LastIndex = CurrentIndex                   'and retain it if bigger
   End If
Next BlockItem
LastIndex = LastIndex + 1                          'increase maximum index 

Public Function SelectBlocksByPattern(ByVal NamePattern As String)
   Dim theBlock As Variant: Dim BlocksList As Variant
   Dim BlockName As String
   BlocksList = Array()
   For Each theBlock In ThisDrawing.Blocks                       'parse blocks database
       BlockName = theBlock.Name                                 'retain block's name
       If Left(BlockName, Len(NamePattern)) = NamePattern Then   'compare with argument pattern
           ReDim BlocksList(UBound(BlocksList) + 1)              'and retain it it match
           BlocksList(UBound(BlocksList)) = BlockName
       End If
   Next theBlock
   SelectBlocksByPattern = BlocksList                            'return found blocks list
End Function

BlocksList = SelectBlocksByPattern("Block-")

Public Sub Lindex()
Dim BlockItem As Integer
Dim LastIndex As String: Dim CurrentIndex As String
BlocksList = SelectBlocksByPattern("Block-")
LastIndex = Mid(BlocksList(0), 7)                'retain first index as reference
For BlockItem = 1 To UBound(BlocksList)
   CurrentIndex = Mid(BlocksList(BlockItem), 7)
   If CInt(CurrentIndex) > CInt(LastIndex) Then   'compare with current item's index
       LastIndex = CurrentIndex                   'and retain it if bigger
   End If
Next BlockItem
LastIndex = LastIndex + 1                          'increase maximum index
MsgBox LastIndex
End Sub
Public Function SelectBlocksByPattern(ByVal NamePattern As String)
   Dim theBlock As Variant: Dim BlocksList As Variant
   Dim BlockName As String
   BlocksList = Array()
   For Each theBlock In ThisDrawing.Blocks                       'parse blocks database
       BlockName = theBlock.Name                                 'retain block's name
       If Left(BlockName, Len(NamePattern)) = NamePattern Then   'compare with argument pattern
           ReDim BlocksList(UBound(BlocksList) + 1)              'and retain it it match
           BlocksList(UBound(BlocksList)) = BlockName
       End If
   Next theBlock
   SelectBlocksByPattern = BlocksList                            'return found blocks list
End Function

Public Sub Lindex()
   Dim BlockItem As Integer
   Dim LastIndex As String: Dim CurrentIndex As String
   [color=red]Dim BlocksList As Variant[/color]
   [color=black]BlocksList = SelectBlocksByPattern("Block-")[/color]
[color=red]    If UBound(BlocksList) = -1 Then Exit Sub           'exit if no block available[/color]
   LastIndex = CInt(Mid(BlocksList(0), 7))            'retain first index as reference
   For BlockItem = 1 To UBound(BlocksList)
       CurrentIndex = Mid(BlocksList(BlockItem), 7)
       If CInt(CurrentIndex) > LastIndex Then         'compare with current item's index
           LastIndex = CurrentIndex                   'and retain it if bigger
       End If
   Next BlockItem
   LastIndex = LastIndex + 1                          'increase maximum index
MsgBox LastIndex
End Sub
Public Function SelectBlocksByPattern(ByVal NamePattern As String)
   Dim theBlock As Variant: Dim BlocksList As Variant
   Dim BlockName As String
   BlocksList = Array()
   For Each theBlock In ThisDrawing.Blocks                       'parse blocks database
       BlockName = theBlock.Name                                 'retain block's name
       If Left(BlockName, Len(NamePattern)) = NamePattern Then   'compare with argument pattern
           ReDim [color=red]Preserve[/color] BlocksList(UBound(BlocksList) + 1)     'and retain it it match
           BlocksList(UBound(BlocksList)) = BlockName
       End If
   Next theBlock
   SelectBlocksByPattern = BlocksList                            'return found blocks list
End Function