'Benötigt wird eine Picturebox
Option Explicit
 
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
 
Private Declare Function FillRect& Lib "user32" (ByVal hdc&, ConstRect As RECT, _
  ByVal HdcBrush&)
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor&)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
 
Private FarbBrush&(255)
 
Private Sub Form_Load()
'benötigte Brushs erstellen
 
Dim i%
 
Randomize
For i = 0 To 255
  FarbBrush(i) = CreateSolidBrush(Rnd * vbWhite)
Next i
 
End Sub
 
Private Sub Form_Activate()
 
Dim SW&, SH&, P1hdc&, i&, Block As RECT, T1!, T2!
 
Me.ScaleMode = vbPixels
Me.BackColor = RGB(0, 0, 64)
With Picture1
  .ScaleMode = vbPixels
  .AutoRedraw = True
  .BackColor = vbBlack
  SW = .ScaleWidth
  SH = .ScaleHeight
  P1hdc = .hdc
 
  T1 = Timer
  Do: Loop Until Timer > T1
  T1 = Timer
  For i = 1 To 1000
    With Block
      .Left = Rnd * (SW - 30) 'X-Position
      .Top = Rnd * (SH - 30) 'Y-Position
      .Right = .Left + 5 + Rnd * 25 'Breite
      .Bottom = .Top + 5 + Rnd * 25 'Höhe
    End With
    'Rechteck zeichnen
    FillRect P1hdc, Block, FarbBrush(Int(Rnd * 256))
  Next i
  .Refresh
End With
T2 = Timer
MsgBox "Zeit: " & (T2 - T1) & " Sek."
 
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
'Brushs wieder löschen
 
Dim i%
 
For i = 0 To 255
  Call DeleteObject(FarbBrush(i))
Next i
 
End Sub

Gruss,

Zardoz