Сортировка названий блоков

Option Explicit
Public oSset As AcadSelectionSet
Public selObj As AcadEntity
Private Sub cmdGetBlock_Click()
Me.Hide
    Dim bRef As AcadBlockReference
    Dim pick As Variant
    Dim blkName As String
    Dim newName As String
    On Error Resume Next
    ThisDrawing.Utility.GetEntity bRef, pick, "Select a block reference"
    If Err <> 0 Then
        Err.Clear
        MsgBox "You missed.", , "Block Selection Error"
        Exit Sub
    Else
        blkName = bRef.Name
   End If
Dim bName As String
Dim i As Integer
For i = 0 To BlockList.ListCount - 1
If BlockList.List(i) = blkName Then
BlockList.Selected(i + 1) = True
End If
Next i
newName = BlockList.Text
Dim newrefObj As AcadBlockReference
Dim iPoint As Variant
Dim j As Integer
On Error GoTo SecondSet
For Each selObj In oSset
If selObj.Name = blkName Then
iPoint = selObj.insertionPoint
Set newrefObj = ThisDrawing.ModelSpace.InsertBlock(iPoint, newName, 1#, 1#, 1#, 0)
selObj.Delete
End If
i = i + 1
Next
cmdExit.ForeColor = &HFF
SecondSet:
MsgBox Err.Description, vbInformation
Me.Show
End Sub
Function Remove_Dup_Strings(ByVal strArr As Variant) As Variant
Dim clearArr() As String
Dim unitStr As Variant
Dim storeColl As New Collection
Dim findCheck As Boolean
Dim i, k As Long
For i = 0 To UBound(strArr)
For Each unitStr In storeColl
    If unitStr = strArr(i) Then
        findCheck = True
    End If
Next
If findCheck = False Then
    storeColl.Add strArr(i)
Else
    findCheck = False
End If
Next
i = storeColl.count - 1
ReDim clearArr(0 To i) As String
For k = 0 To storeColl.count - 1
        clearArr(k) = storeColl(k + 1)
    Next
Remove_Dup_Strings = clearArr
End Function
Public Function SortShellString(sourceArr As Variant) As Variant
Dim remPic As Integer
Dim cmpFlag As Boolean
Dim iPos As Long
Dim cmpStr As String
remPic = UBound(sourceArr) \ 2
Do While remPic <> 0
Do
cmpFlag = False
For iPos = 0 To UBound(sourceArr) - remPic
If (StrComp(sourceArr(iPos + remPic), sourceArr(iPos), vbTextCompare) = -1) Then
cmpStr = sourceArr(iPos + remPic)
sourceArr(iPos + remPic) = sourceArr(iPos)
sourceArr(iPos) = cmpStr
cmpFlag = True
End If
Next iPos
Loop Until Not cmpFlag
remPic = remPic \ 2
Loop
SortShellString = sourceArr
End Function
Private Sub UserForm_Initialize()
Dim oSetColl As AcadSelectionSets
Dim intGpCode(0) As Integer
Dim GpData(0) As Variant
Dim i As Integer
Dim j As Integer
intGpCode(0) = 0: GpData(0) = "INSERT"
With ThisDrawing
Set oSetColl = .SelectionSets
For Each oSset In oSetColl
If oSset.Name = "$AllBlocks$" Then
oSetColl.Item("$AllBlocks$").Delete
Exit For
End If
Next oSset
Set oSset = oSetColl.Add("$AllBlocks$")
End With
oSset.Select acSelectionSetAll, , , intGpCode, GpData
Dim blkArr() As String
i = 0
ReDim blkArr(oSset.count - 1)
For Each selObj In oSset
blkArr(i) = selObj.Name
i = i + 1
Next
Dim refColl As Variant
refColl = Remove_Dup_Strings(blkArr)
BlockList.List() = SortShellString(refColl)
Me.Hide
End Sub
Private Sub cmdExit_Click()
End
End Sub