Private Sub cmdPolygons_Click()
' Draw random Polygons
    Dim X As Long, Y As Long, X2 As Long, Y2 As Long
    Dim Color As Long
    Dim varTemp As Variant
    
    'Dim pts(2) As POINTAPI
    Dim pts As clsVertices2
    
    Set pts = New clsVertices2
    Dim iNdex As Long
    Dim tt As Single
    tt = Timer
    
    For iNdex =  1  To  700 
    
    pts.NumVertices = RndInt( 16 )
    'Debug.Print "NumVertices:" & pts.NumVertices
    'DoEvents
    ' Limit our random values<grin>
    For X =  0  To pts.NumVertices -  1 
     pts.SetVertsX X, RndInt(pb.dib_width)
     pts.SetVertsY X, RndInt(pb.dib_height)
    Next X
    
    'pts(1).x = RndInt(pb.dib_width)
    'pts(1).y = RndInt(pb.dib_height)
    'pts(2).x = RndInt(pb.dib_width)
    'pts(2).y = RndInt(pb.dib_height)
    
    'varTemp = pts
    
    'pb.PolygonVertices = varTemp
     Color = RGB(RndInt( 256 ), RndInt( 256 ), RndInt( 256 ))
    '
    ' Call the Polygon Method to draw some random Polygons
    pb.PreparePolygon2 pts, Color
    pts.ClearArrayContent
    
    'pb.DrawPolygon pts, Color
    
    Next
    
    pb.UpdateScreen
    DoEvents
    Set pts = Nothing
    MsgBox Timer - tt
End Sub

' clsVertices2
' Required for Polygon API call

'Updated by Victosha 23.12.2004

Option Compare Binary
Option Explicit


Private Declare Sub CopyMemory Lib "kernel32" Alias _
    "RtlMoveMemory" (pDst As Any, pSrc As Any, _
    ByVal ByteLen As Long)
    
'Описание ZeroMemory в WinAPI32.txt неправльное. Потерял некоторое время, пока понял это:
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, _
    ByVal numBytes As Long)

'структура для хранения информации о размерности
Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type

'описатель одномерного массива
Private Type SAFEARRAY1D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds( 0  To  0 ) As SAFEARRAYBOUND
End Type


'Шаг увеличения длины массива
'для экономии к-ва редимов
'здесь надо установить размер наиболее вероятного
'размера массива точек
'очень слабо - почти незаметно влияние на общую скорость
'
Const CChunkSize As Long =  50 &


' Number of vertices for our Polygon
Private m_NumVertices As Long

' Array to hold the vertices
' тип массива пришлось сменить, иначе проблема с определением адресов
Private m_pts() As Currency 'POINTAPI

'просто текущая длина массива
Private uArrayBound As Long

'описатель массива
Private pSaPtr As SAFEARRAY1D


Private Function VarPtrArray(arr As Variant) As Long
'функция для определения адреса массива
  CopyMemory VarPtrArray, ByVal VarPtr(arr) +  8 &,  4 &
End Function

Private Sub GetArrPtr()
'формирует описатель массива точек
  Dim arrPtr As Long
  Dim saPtr As Long
  
  arrPtr = VarPtrArray(m_pts)
  
  ' восстанавливаем адрес описателя
  CopyMemory ByVal VarPtr(saPtr), ByVal arrPtr,  4 &
  
  'копируем информацию в описатель массива
  CopyMemory pSaPtr, ByVal saPtr, _
        Len(pSaPtr) ' - 8 * (60 - cDims)
        
End Sub

Private Sub reserveArray(ByVal x As Long)
'выделяет память под массив
  If x <  1 & Then x =  1 &
  If x > uArrayBound Then
    ReDim Preserve m_pts((x -  1 &) + CChunkSize) As Currency
    uArrayBound = UBound(m_pts)
    GetArrPtr
  End If
End Sub

Friend Sub ClearArrayContent()
'очищает массив, заполняя его нулями
Dim numElems As Long
  numElems = pSaPtr.cbElements * pSaPtr.Bounds( 0 ).cElements
  ZeroMemory m_pts( 0 &), ByVal numElems
  GetArrPtr
  m_NumVertices =  0 &
End Sub


Property Get getPointerToArray() As Long
'возвращает указатель на первый элемент массива
'для последующего использования функциями отрисовки
'в соответствующих декларациях нужно подправить x as POINTAPI на ByVal x As Long
  getPointerToArray = pSaPtr.pvData
End Property



Friend Property Let NumVertices(ByVal x As Long)
' Erase m_pts
' Zero based index
  If x =  0  Then x =  1 
  
  If x > uArrayBound Then
    reserveArray x
  End If
  
  m_NumVertices = x -  1 
End Property

Friend Property Get NumVertices() As Long
  NumVertices = m_NumVertices
End Property

Friend Property Get VertsX(x) As Long
  CopyMemory ByVal VarPtr(VertsX), ByVal (pSaPtr.pvData + x *  8 &),  4 &
End Property

Friend Property Get VertsY(x) As Long
  CopyMemory ByVal VarPtr(VertsY), ByVal (pSaPtr.pvData + x *  8 & +  4 &),  4 &
End Property


Friend Function SetVertsX(inDex As Long, x As Long)
  CopyMemory ByVal pSaPtr.pvData + inDex *  8 &, ByVal VarPtr(x),  4 &
'm_pts(inDex).X = X
End Function

Friend Function SetVertsY(inDex As Long, x As Long)
  CopyMemory ByVal pSaPtr.pvData + inDex *  8 & +  4 &, ByVal VarPtr(x),  4 &
'm_pts(inDex).Y = X
End Function

Friend Function SetVertsXY(inDex As Long, x As Long, y As Long)
'предпочтительно устанавлиать точки ею, единицы процентов на этом выиграются
   CopyMemory ByVal pSaPtr.pvData + inDex *  8 &, ByVal VarPtr(x),  4 &
   CopyMemory ByVal pSaPtr.pvData + inDex *  8 & +  4 &, ByVal VarPtr(y),  4 &
End Function

Private Sub Class_Initialize()
' To reduce errors setup as 2 vertices
  'firstStart = True
  NumVertices =  1 &
End Sub

Private Sub Terminate()
On Error Resume Next
    Erase m_pts
End Sub

Private Sub Class_Terminate()
  Terminate
End Sub

Private Declare Function Polygon2 Lib "gdi32" Alias "Polygon" _
(ByVal hdc As Long, ByVal lpPoint As Long, ByVal nCount As Long) As Long

Friend Sub PreparePolygon2(pts As clsVertices2, Optional TempFillColor As Long =  0 )
    
    Dim hNewBrush As Long
    Dim hOldBrush As Long
    'Dim pt() As POINTAPI
    'Dim x As Long
    
On Error GoTo Exit_Err
    
   'ReDim pt(pts.NumVertices)
    
   'For X = 0 To pts.NumVertices
   '  pt(X).X = pts.VertsX(X)
   '  pt(X).Y = pts.VertsY(X)
   'Next
   
    If TempFillColor <>  0  Then
        hNewBrush = apiCreateSolidBrush(TempFillColor)
    Else
    ' Use FillColor Prop
        hNewBrush = apiCreateSolidBrush(m_FillColor)
    End If
    
    ' Select new brush onto our DC
    hOldBrush = SelectObject(m_hDC, hNewBrush)
    
    ' Draw the Polygon
    Call Polygon2(m_hDC, ByVal pts.getPointerToArray, pts.NumVertices)
    
    Call SelectObject(m_hDC, hOldBrush)
    Call DeleteObject(hNewBrush)
    
    '' Update the display
    'Me.DIBtoPictureData


Exit_OK:
Exit Sub

Exit_Err:

MsgBox Err.Description, vbCritical, "Error Number:" & Err.Number
GoTo Exit_OK:
End Sub

Friend Property Get VertsX(X) As Long
  Dim adr As Long
  adr = pSaPtr.pvData + X *  8 &
  CopyMemory ByVal VarPtr(VertsX), ByVal adr,  4 &
End Property

Friend Property Get VertsY(X) As Long
  Dim adr As Long
  adr = pSaPtr.pvData + X *  8 & +  4 &
  CopyMemory ByVal VarPtr(VertsY), ByVal adr,  4 &
End Property