Как добавить в список ListBox большое количество строк, чтобы это было быстро по времени?

Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const LB_INITSTORAGE = &H1A8
Private Const LB_ADDSTRING = &H180
 
Private Sub Command1_Click()
    Dim i As Integer
    Dim tick As Long
    
    List1.Clear
    tick = GetTickCount
    
    For i = 0 To 10000
        List1.AddItem i
    Next
    Me.Caption = GetTickCount - tick ' 1311 ml
End Sub
 
Private Sub Command2_Click()
    Dim i As Integer
    Dim tick As Long
    
    List1.Clear
    tick = GetTickCount
    
    List1.Visible = False
    
    For i = 0 To 10000
        List1.AddItem i
    Next
    
    List1.Visible = True
    
    Me.Caption = GetTickCount - tick ' 468 ml
End Sub
 
 
Private Sub Command3_Click()
    Dim i As Integer
    Dim tick As Long
    Dim str As String
    Dim hwndList As Long
    
    str = "123"
    hwndList = List1.hwnd
    
    List1.Clear
    tick = GetTickCount
    
    'List1.Visible = False
    
    Debug.Print SendMessage(hwndList, LB_INITSTORAGE, 10001, CLng(LenB(str) * 10001))
    
    For i = 0 To 10000
        SendMessage hwndList, LB_ADDSTRING, 0, StrPtr(str)
    Next
    'List1.Visible = True
    
    Me.Caption = GetTickCount - tick ' 1310 ml
End Sub

Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Const LF_FACESIZE As Long = 32
Private Type LOGFONT
LFHeight As Long
LFWidth As Long
LFEscapement As Long
LFOrientation As Long
LFWeight As Long
LFItalic As Byte
LFUnderline As Byte
LFStrikeOut As Byte
LFCharset As Byte
LFOutPrecision As Byte
LFClipPrecision As Byte
LFQuality As Byte
LFPitchAndFamily As Byte
LFFaceName(0 To ((LF_FACESIZE * 2) - 1)) As Byte
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, ByVal lpdwProcessId As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectW" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal XLeft As Long, ByVal YTop As Long, ByVal hIcon As Long, ByVal CXWidth As Long, ByVal CYWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectW" (ByRef lpLogFont As LOGFONT) As Long
Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal Color As Long, ByVal hPal As Long, ByRef RGBResult As Long) As Long
Public Function ProperControlName(ByVal Control As VB.Control) As String
Dim Index As Long
On Error Resume Next
Index = Control.Index
If Err.Number <> 0 Or Index < 0 Then ProperControlName = Control.Name Else ProperControlName = Control.Name & "(" & Index & ")"
On Error GoTo 0
End Function
Public Function MousePointerID(ByVal MousePointer As Integer) As Long
Select Case MousePointer
    Case vbArrow
        Const IDC_ARROW As Long = 32512
        MousePointerID = IDC_ARROW
    Case vbCrosshair
        Const IDC_CROSS As Long = 32515
        MousePointerID = IDC_CROSS
    Case vbIbeam
        Const IDC_IBEAM As Long = 32513
        MousePointerID = IDC_IBEAM
    Case vbIconPointer ' Obselete, replaced Icon with Hand
        Const IDC_HAND As Long = 32649
        MousePointerID = IDC_HAND
    Case vbSizePointer, vbSizeAll
        Const IDC_SIZEALL As Long = 32646
        MousePointerID = IDC_SIZEALL
    Case vbSizeNESW
        Const IDC_SIZENESW As Long = 32643
        MousePointerID = IDC_SIZENESW
    Case vbSizeNS
        Const IDC_SIZENS As Long = 32645
        MousePointerID = IDC_SIZENS
    Case vbSizeNWSE
        Const IDC_SIZENWSE As Long = 32642
        MousePointerID = IDC_SIZENWSE
    Case vbSizeWE
        Const IDC_SIZEWE As Long = 32644
        MousePointerID = IDC_SIZEWE
    Case vbUpArrow
        Const IDC_UPARROW As Long = 32516
        MousePointerID = IDC_UPARROW
    Case vbHourglass
        Const IDC_WAIT As Long = 32514
        MousePointerID = IDC_WAIT
    Case vbNoDrop
        Const IDC_NO As Long = 32648
        MousePointerID = IDC_NO
    Case vbArrowHourglass
        Const IDC_APPSTARTING As Long = 32650
        MousePointerID = IDC_APPSTARTING
    Case vbArrowQuestion
        Const IDC_HELP As Long = 32651
        MousePointerID = IDC_HELP
    Case 16
        Const IDC_WAITCD As Long = 32663 ' Undocumented
        MousePointerID = IDC_WAITCD
End Select
End Function
Public Sub RefreshMousePointer(Optional ByVal hWndFallback As Long)
Const WM_SETCURSOR As Long = &H20, WM_NCHITTEST As Long = &H84, WM_MOUSEMOVE As Long = &H200
Dim P As POINTAPI, hWndCursor As Long
GetCursorPos P
hWndCursor = GetCapture()
If hWndCursor = 0 Then hWndCursor = WindowFromPoint(P.X, P.Y)
If hWndCursor <> 0 Then
    If GetWindowThreadProcessId(hWndCursor, 0) <> App.ThreadID Then hWndCursor = hWndFallback
Else
    hWndCursor = hWndFallback
End If
If hWndCursor <> 0 Then SendMessage hWndCursor, WM_SETCURSOR, hWndCursor, ByVal MakeDWord(SendMessage(hWndCursor, WM_NCHITTEST, 0, ByVal Make_XY_lParam(P.X, P.Y)), WM_MOUSEMOVE)
End Sub
Public Function OLEFontIsEqual(ByVal Font As StdFont, ByVal FontOther As StdFont) As Boolean
If Font Is Nothing Then
    If FontOther Is Nothing Then OLEFontIsEqual = True
ElseIf FontOther Is Nothing Then
    If Font Is Nothing Then OLEFontIsEqual = True
Else
    If Font.Name = FontOther.Name And Font.Size = FontOther.Size And Font.Charset = FontOther.Charset And Font.Weight = FontOther.Weight And _
    Font.Underline = FontOther.Underline And Font.Italic = FontOther.Italic And Font.Strikethrough = FontOther.Strikethrough Then
        OLEFontIsEqual = True
    End If
End If
End Function
Public Function CreateGDIFontFromOLEFont(ByVal Font As IFont) As Long
If Font Is Nothing Then Exit Function
Dim LF As LOGFONT
' hFont will be cleared when the IFont reference goes out of scope or is set to nothing.
GetObjectAPI Font.hFont, LenB(LF), LF
CreateGDIFontFromOLEFont = CreateFontIndirect(LF)
End Function
Public Function GetShiftStateFromParam(ByVal wParam As Long) As ShiftConstants
Const MK_SHIFT As Long = &H4, MK_CONTROL As Long = &H8
If (wParam And MK_SHIFT) = MK_SHIFT Then GetShiftStateFromParam = vbShiftMask
If (wParam And MK_CONTROL) = MK_CONTROL Then GetShiftStateFromParam = GetShiftStateFromParam Or vbCtrlMask
If GetKeyState(vbKeyMenu) < 0 Then GetShiftStateFromParam = GetShiftStateFromParam Or vbAltMask
End Function
 
Public Function GetMouseStateFromParam(ByVal wParam As Long) As MouseButtonConstants
Const MK_LBUTTON As Long = &H1, MK_RBUTTON As Long = &H2, MK_MBUTTON As Long = &H10
If (wParam And MK_LBUTTON) = MK_LBUTTON Then GetMouseStateFromParam = vbLeftButton
If (wParam And MK_RBUTTON) = MK_RBUTTON Then GetMouseStateFromParam = GetMouseStateFromParam Or vbRightButton
If (wParam And MK_MBUTTON) = MK_MBUTTON Then GetMouseStateFromParam = GetMouseStateFromParam Or vbMiddleButton
End Function
 
Public Function GetShiftStateFromMsg() As ShiftConstants
If GetKeyState(vbKeyShift) < 0 Then GetShiftStateFromMsg = vbShiftMask
If GetKeyState(vbKeyControl) < 0 Then GetShiftStateFromMsg = GetShiftStateFromMsg Or vbCtrlMask
If GetKeyState(vbKeyMenu) < 0 Then GetShiftStateFromMsg = GetShiftStateFromMsg Or vbAltMask
End Function
 
Public Function PtrToObj(ByVal ObjectPointer As Long) As Object
Dim TempObj As Object
CopyMemory TempObj, ObjectPointer, 4
Set PtrToObj = TempObj
CopyMemory TempObj, 0&, 4
End Function
 
Public Function ProcPtr(ByVal Address As Long) As Long
ProcPtr = Address
End Function
 
Public Function LoWord(ByVal DWord As Long) As Integer
If DWord And &H8000& Then
    LoWord = DWord Or &HFFFF0000
Else
    LoWord = DWord And &HFFFF&
End If
End Function
 
Public Function HiWord(ByVal DWord As Long) As Integer
HiWord = (DWord And &HFFFF0000) \ &H10000
End Function
 
Public Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
MakeDWord = (CLng(HiWord) * &H10000) Or (LoWord And &HFFFF&)
End Function
 
Public Function Get_X_lParam(ByVal lParam As Long) As Long
Get_X_lParam = lParam And &H7FFF&
If lParam And &H8000& Then Get_X_lParam = Get_X_lParam Or &HFFFF8000
End Function
 
Public Function Get_Y_lParam(ByVal lParam As Long) As Long
Get_Y_lParam = (lParam And &H7FFF0000) \ &H10000
If lParam And &H80000000 Then Get_Y_lParam = Get_Y_lParam Or &HFFFF8000
End Function
 
Public Function Make_XY_lParam(ByVal X As Long, ByVal Y As Long) As Long
Make_XY_lParam = LoWord(X) Or (&H10000 * LoWord(Y))
End Function
 
Public Function UTF32CodePoint_To_UTF16(ByVal CodePoint As Long) As String
If CodePoint >= &HFFFF8000 And CodePoint <= &H10FFFF Then
    Dim HW As Integer, LW As Integer
    If CodePoint < &H10000 Then
        HW = 0
        LW = CUIntToInt(CodePoint And &HFFFF&)
    Else
        CodePoint = CodePoint - &H10000
        HW = (CodePoint \ &H400) + &HD800
        LW = (CodePoint Mod &H400) + &HDC00
    End If
    If HW = 0 Then UTF32CodePoint_To_UTF16 = ChrW(LW) Else UTF32CodePoint_To_UTF16 = ChrW(HW) & ChrW(LW)
End If
End Function
Public Function StrToVar(ByVal Text As String) As Variant
If Text = vbNullString Then
    StrToVar = Empty
Else
    Dim B() As Byte
    B() = Text
    StrToVar = B()
End If
End Function
Public Function UnsignedAdd(ByVal Start As Long, ByVal Incr As Long) As Long
UnsignedAdd = ((Start Xor &H80000000) + Incr) Xor &H80000000
End Function
Public Function CUIntToInt(ByVal Value As Long) As Integer
Const OFFSET_2 As Long = 65536
Const MAXINT_2 As Integer = 32767
If Value < 0 Or Value >= OFFSET_2 Then Err.Raise 6
If Value <= MAXINT_2 Then
    CUIntToInt = Value
Else
    CUIntToInt = Value - OFFSET_2
End If
End Function
Public Function CIntToUInt(ByVal Value As Integer) As Long
Const OFFSET_2 As Long = 65536
If Value < 0 Then
    CIntToUInt = Value + OFFSET_2
Else
    CIntToUInt = Value
End If
End Function
Public Function DPI_X() As Long
Const LOGPIXELSX As Long = 88
Dim hDCScreen As Long
hDCScreen = GetDC(0)
If hDCScreen <> 0 Then
    DPI_X = GetDeviceCaps(hDCScreen, LOGPIXELSX)
    ReleaseDC 0, hDCScreen
End If
End Function
 
Public Function DPI_Y() As Long
Const LOGPIXELSY As Long = 90
Dim hDCScreen As Long
hDCScreen = GetDC(0)
If hDCScreen <> 0 Then
    DPI_Y = GetDeviceCaps(hDCScreen, LOGPIXELSY)
    ReleaseDC 0, hDCScreen
End If
End Function
 
Public Function DPICorrectionFactor() As Single
Static Done As Boolean, Value As Single
If Done = False Then
    Value = ((96 / DPI_X()) * 15) / Screen.TwipsPerPixelX
    Done = True
End If
' Returns exactly 1 when no corrections are required.
DPICorrectionFactor = Value
End Function
 
Public Function CHimetricToPixel_X(ByVal Width As Long) As Long
Const HIMETRIC_PER_INCH As Long = 2540
CHimetricToPixel_X = (Width * DPI_X()) / HIMETRIC_PER_INCH
End Function
 
Public Function CHimetricToPixel_Y(ByVal Height As Long) As Long
Const HIMETRIC_PER_INCH As Long = 2540
CHimetricToPixel_Y = (Height * DPI_Y()) / HIMETRIC_PER_INCH
End Function
 
Public Function PixelsPerDIP_X() As Single
Static Done As Boolean, Value As Single
If Done = False Then
    Value = (DPI_X() / 96)
    Done = True
End If
PixelsPerDIP_X = Value
End Function
'
Public Function PixelsPerDIP_Y() As Single
Static Done As Boolean, Value As Single
If Done = False Then
    Value = (DPI_Y() / 96)
    Done = True
End If
PixelsPerDIP_Y = Value
End Function
Public Function WinColor(ByVal Color As Long, Optional ByVal hPal As Long) As Long
If OleTranslateColor(Color, hPal, WinColor) <> 0 Then WinColor = -1
End Function
Public Function BitmapHandleFromPicture(ByVal Picture As IPictureDisp, Optional ByVal BackColor As OLE_COLOR) As Long
If Picture Is Nothing Then Exit Function
With Picture
If .Handle <> 0 Then
    Dim hDCScreen As Long, hDC As Long, hBmp As Long, hBmpOld As Long
    Dim CX As Long, CY As Long, Brush As Long
    CX = CHimetricToPixel_X(.Width)
    CY = CHimetricToPixel_Y(.Height)
    Brush = CreateSolidBrush(WinColor(BackColor))
    hDCScreen = GetDC(0)
    If hDCScreen <> 0 Then
        hDC = CreateCompatibleDC(hDCScreen)
        If hDC <> 0 Then
            hBmp = CreateCompatibleBitmap(hDCScreen, CX, CY)
            If hBmp <> 0 Then
                hBmpOld = SelectObject(hDC, hBmp)
                If .Type = vbPicTypeIcon Then
                    Const DI_NORMAL As Long = &H3
                    DrawIconEx hDC, 0, 0, .Handle, CX, CY, 0, Brush, DI_NORMAL
                Else
                    Dim RC As RECT
                    RC.Right = CX
                    RC.Bottom = CY
                    FillRect hDC, RC, Brush
                    .Render hDC Or 0&, 0&, 0&, CX Or 0&, CY Or 0&, 0&, .Height, .Width, -.Height, ByVal 0&
                End If
                SelectObject hDC, hBmpOld
                BitmapHandleFromPicture = hBmp
            End If
            DeleteDC hDC
        End If
        ReleaseDC 0, hDCScreen
    End If
    DeleteObject Brush
End If
End With
End Function

'Created by Testuser 09.05.24