Option Explicit
' © 2003 by Zardoz
 
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 Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hdc&)
Private Declare Function CreatePatternBrush& Lib "gdi32" (ByVal hbmp&)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc&, ByVal X&, ByVal _
  Y&, ByVal crColor&)
Private Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC&, ByVal X&, ByVal _
Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, _
ByVal dwRop&)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc&, ByVal hObject&)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
Private Declare Function DeleteDC& Lib "gdi32" (ByVal hdc&)
Private Declare Function CreatePen& Lib "gdi32" (ByVal fnPenStyle&, ByVal _
  nWidth&, ByVal crColor&)
Private Declare Function CreateCompatibleBitmap& Lib "gdi32" (ByVal hdc&, ByVal _
nWidth&, ByVal nHeight&)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc&, lpPoint As PointAPI, _
ByVal nCount&)
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor&)
Private Declare Function FillRect& Lib "user32" (ByVal hdc&, ConstRect As RECT, _
  ByVal HdcBrush&)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds&)
 
Private FlgEnd As Boolean, FlgBusy As Boolean
 
Private Sub Form_Activate()
 
Dim GreyBrush&, WhitePen&, OldBrush&, OldPen&
Dim P1Hdc&, P1Pic&, LiquidBrush&, BackBrush&
Dim i%, j%, FlowBrush&, SW%, SH%, YPos%, XPos%
Dim P2Hdc&, P2Pic&, XOff&, YOff&, X1&, X2&, XTmp&, Z&
Dim Figur(13) As PointAPI, Block As RECT, T1$, T2$
 
FlgEnd = False
FlgBusy = True
With Me
.WindowState = vbMaximized
.ScaleMode = vbPixels
T1 = "97AA69ADAEB7B7756999BBB8BCBD"
T2 = ""
For i = 1 To Len(T1) Step 2
  T2 = T2 & Chr((("&H" & Mid(T1, i, 2)) - 73) And 255)
Next i
Me.Caption = T2
SW = .ScaleWidth
SH = .ScaleHeight
Randomize
P1Hdc = CreateCompatibleDC(.hdc)
P1Pic = CreateCompatibleBitmap(.hdc, 8, 8)
SelectObject P1Hdc, P1Pic
P2Hdc = CreateCompatibleDC(.hdc)
P2Pic = CreateCompatibleBitmap(.hdc, SW, SH)
SelectObject P2Hdc, P2Pic
WhitePen = CreatePen(0, 0, vbWhite)
GreyBrush = CreateSolidBrush(RGB(210, 210, 210))
LiquidBrush = CreateSolidBrush(RGB(255, 255, 160))
OldPen = SelectObject(P2Hdc, WhitePen)
OldBrush = SelectObject(P2Hdc, GreyBrush)
BackBrush = CreateSolidBrush(RGB(204, 151, 245))
Z = 0
YOff = (SH - 280) \ 2
X1 = 0
X2 = SW / 2 - 203
Do
  For XOff = X1 To X2 Step 2 * Sgn(X2 - X1)
    With Block
      .Left = 0
      .Top = 0
      .Right = 8
      .Bottom = 8
      FillRect P1Hdc, Block, LiquidBrush
      .Right = SW
      .Bottom = SH
      FillRect P2Hdc, Block, BackBrush
    End With
    YPos = (YPos - 1) And 7
    XPos = 2 * Rnd
    For i = 0 To 1
      For j = 0 To 1
        SetPixelV P1Hdc, XPos + i, (YPos + j) And 7, vbWhite
      Next j
    Next i
    For j = 0 To 1
      For i = 0 To 13
        With Figur(i)
          .X = XOff + ("&H" & Mid("0C2F555A83CB7064465D5B46311B", 1 + 2 * i, 2))
          If j = 0 Then
            .Y = YOff + ("&H" & Mid( _
              "10A10D0CA0B201803A0BE0CF11612A13012E12611B", 1 + 3 * i, 3))
          Else
            .X = SW - .X
          End If
        End With
      Next i
      Polygon P2Hdc, Figur(0), 14
    Next j
    FlowBrush = CreatePatternBrush(P1Pic)
    SelectObject P2Hdc, FlowBrush
    For j = 0 To 1
      For i = 0 To 6
        With Figur(i)
          .X = XOff + ("&H" & Mid("5B5E666E70B473", 1 + 2 * i, 2))
          If j = 0 Then
            .Y = YOff + ("&H" & Mid("B1B8BCBDBB5858", 1 + 2 * i, 2))
          Else
            .X = SW - .X
          End If
        End With
      Next i
      Polygon P2Hdc, Figur(0), 7
    Next j
    SelectObject P2Hdc, GreyBrush
    DeleteObject FlowBrush
    BitBlt .hdc, 0, 0, SW, SH, P2Hdc, 0, 0, vbSrcCopy
    DoEvents
    Sleep 10
    If FlgBusy = False Then Exit For
  Next XOff
  If X1 < X2 Then
    Beep
  End If
  If Z < 9 Then
    Z = Z + 1
  End If
  If Z = 1 Then
    X1 = X2 - 50
  ElseIf Z = 5 Then
    X1 = X2
  End If
  XTmp = X1: X1 = X2: X2 = XTmp
Loop While FlgBusy = True
End With
SelectObject P2Hdc, OldPen
SelectObject P2Hdc, OldBrush
DeleteDC P2Hdc
DeleteObject P2Pic
DeleteDC P1Hdc
DeleteObject P1Pic
DeleteObject FlowBrush
DeleteObject BackBrush
DeleteObject GreyBrush
DeleteObject WhitePen
DeleteObject LiquidBrush
FlgEnd = True
Unload Me
 
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
 
If FlgEnd = True Then
  End
Else
  FlgBusy = False
  Cancel = True
End If
 
End Sub

Gruss,

Zardoz