[VB6] - Using GDI+ for generation a fir-tree.

Hello everyone! I present to you a Christmas tree generated using GDI+.

Code:

---

Option Explicit
' Ёлка VB6
' © Кривоус Анатолий Анатольевич (The trick), 2013
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type Vector
    x As Single
    y As Single
End Type
Private Type COLORBYTES
    BlueByte As Byte
    GreenByte As Byte
    RedByte As Byte
    AlphaByte As Byte
End Type
Private Type COLORLONG
    longval As Long
End Type
Private Type RECT
    iLeft As Long
    iTop As Long
    iRight As Long
    iBottom As Long
End Type
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, Graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As Long, Pen As Long) As Long
Private Declare Function GdipDeletePen Lib "gdiplus" (ByVal Pen As Long) As Long
Private Declare Function GdipSetPenColor Lib "gdiplus" (ByVal Pen As Long, ByVal ARGB As Long) As Long
Private Declare Function GdipSetPenWidth Lib "gdiplus" (ByVal Pen As Long, ByVal Width As Single) As Long
Private Declare Function GdipDrawLine Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single) As Long
Private Declare Function GdipFillPolygon2 Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, Points As Vector, ByVal Count As Long) As Long
Private Declare Function GdipDrawPolygon Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, Points As Vector, ByVal Count As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal ARGB As Long, Brush As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "gdiplus" (ByVal Graphics As Long, ByVal SmoothingMd As Long) As Long
Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal Brush As Long) As Long
Private Declare Function GdipSetSolidFillColor Lib "gdiplus" (ByVal Brush As Long, ByVal ARGB As Long) As Long
Private Declare Function GdipFillEllipse Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipSetPathGradientCenterColor Lib "gdiplus" (ByVal Brush As Long, ByVal lColors As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "gdiplus" (ByVal Brush As Long, ARGB As Long, Count As Long) As Long
Private Declare Function GdipSetPathGradientCenterPoint Lib "gdiplus" (ByVal Brush As Long, Points As Vector) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "gdiplus" (ByVal Path As Long, polyGradient As Long) As Long
Private Declare Function GdipDeletePath Lib "gdiplus" (ByVal Path As Long) As Long
Private Declare Function GdipCreatePath Lib "gdiplus" (ByVal brushmode As Long, Path As Long) As Long
Private Declare Function GdipAddPathEllipse Lib "gdiplus" (ByVal Path As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipFillPath Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, ByVal Path As Long) As Long
Private Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal Graphics As Long, Bitmap As Long) As Long
Private Declare Function GdipDrawImage Lib "gdiplus" (ByVal Graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal Graphics As Long, ByVal lColor As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, stride As Long, ByVal PixelFormat As Long, scan0 As Any, Bitmap As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, Graphics As Long) As Long
Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, ByVal crKey As Long, pblend As Long, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
 
Private Const HWND_TOPMOST As Long = -1
Private Const HTCAPTION As Long = 2
Private Const WM_NCLBUTTONDOWN As Long = &HA1
Private Const SPI_GETWORKAREA = 48
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE As Long = -20
Private Const ULW_ALPHA = &H2
Private Const AB_32Bpp255 = 33488896
Private Const BranchCount = 25, Ratio = 2, Factor = 3
Private Const ScaleNeedles = 10, AngleNeedles = 0.45, MinBranch = 25, MaxWidth = 10, StarSize = 25, SphereSize = 10, LampSize = 8
 
Private Const UnitPixel = 2, SmoothingModeAntiAlias = 4, PixelFormat32bppARGB = &H26200A
Dim MaxLen As Single
Dim token As Long, GpInput As GdiplusStartupInput, gr As Long, gr2 As Long, pn As Long, br As Long, bg As Long
Dim Lamp() As Vector, pt() As Vector, sw As Single
Dim WithEvents Tmr As Timer
 
Private Function vec(x As Single, y As Single) As Vector: vec.x = x: vec.y = y: End Function
Private Function Lerp(x As Single, y As Single, t As Single) As Single: Lerp = x * (1 - t) + y * t: End Function
Private Sub Branch(Pos As Vector, dir As Vector, ByVal f As Long, v As Vector)
    Dim nPos As Vector, nDir As Vector, l As Single, d As Single, q As Long, p As Single, z As Single, dr As Long
    l = Sqr(dir.x * dir.x + dir.y * dir.y)
    If Abs(Pos.x - sw + dir.x) > Abs(v.x) Then v = vec(Pos.x + dir.x - sw, Pos.y + dir.y)
    GdipSetPenWidth pn, l / MaxLen * MaxWidth / 2: GdipSetPenColor pn, &H80562B00
    GdipDrawLine gr2, pn, Pos.x, Pos.y, Pos.x + dir.x, Pos.y + dir.y
    p = 1 / l * Factor
    GdipSetPenWidth pn, 1: GdipSetPenColor pn, &H80200020 Or (CLng(l / MaxLen * 128 + 127) * &H100)
    Do While d < 1
        nPos = vec(Lerp(Pos.x, Pos.x + dir.x, d), Lerp(Pos.y, Pos.y + dir.y, d))
        nDir = vec((Cos(AngleNeedles) * dir.x * d - Sin(AngleNeedles) * dir.y * d) / l * ScaleNeedles, _
                  (Sin(AngleNeedles) * dir.x * d + Cos(AngleNeedles) * dir.y * d) / l * ScaleNeedles)
        GdipDrawLine gr2, pn, nPos.x, nPos.y, nPos.x + nDir.x, nPos.y + nDir.y
        nDir = vec((Cos(-AngleNeedles) * dir.x * d - Sin(-AngleNeedles) * dir.y * d) / l * ScaleNeedles, _
                  (Sin(-AngleNeedles) * dir.x * d + Cos(-AngleNeedles) * dir.y * d) / l * ScaleNeedles)
        GdipDrawLine gr2, pn, nPos.x, nPos.y, nPos.x + nDir.x, nPos.y + nDir.y
        d = d + p
    Loop
    If l < MinBranch Or f > 3 Then Exit Sub
    q = Rnd * 4 + 2: p = 1 / (q - 1): d = 0
    Do While q > 0
        nPos = vec(Lerp(Pos.x, Pos.x + dir.x, d), Lerp(Pos.y, Pos.y + dir.y, d))
        z = z + p: d = Rnd * 0.35 + 0.275: dr = 2
        Do While dr
            nDir = vec((Cos(d) * dir.x - Sin(d) * dir.y) / Ratio, (Sin(d) * dir.x + Cos(d) * dir.y) / Ratio)
            Branch nPos, nDir, f + 1, v: dr = dr - 1: d = -d
        Loop
        q = q - 1
    Loop
End Sub
Private Sub Form_DblClick()
    Unload Me
End Sub
Private Sub Form_Load()
    Dim n As Long, dy As Single, dx As Single, oy As Single, br2 As Long
    Dim Pth As Long, Col As Long, sp() As Vector, v As Vector, rc As RECT
    If SystemParametersInfo(SPI_GETWORKAREA, 0, rc, 0) = 0 Then End
    SetWindowPos Me.hWnd, HWND_TOPMOST, rc.iRight - 293, rc.iBottom - 336, 293, 336, 0
    GpInput.GdiplusVersion = 1
    If GdiplusStartup(token, GpInput) Then End
    If GdipCreateFromHDC(Me.hdc, gr) Then Unload Me
    If GdipCreateSolidFill(&HFF562B00, br) Then Unload Me
    If GdipCreatePen1(&HFF562B00, 1, UnitPixel, pn) Then Unload Me
    If GdipCreateBitmapFromScan0(Me.ScaleWidth, Me.ScaleHeight, Me.ScaleWidth * 4, PixelFormat32bppARGB, ByVal 0, bg) Then Unload Me
    If GdipGetImageGraphicsContext(bg, gr2) Then Unload Me
    If GdipSetSmoothingMode(gr, SmoothingModeAntiAlias) Then Unload Me
    If GdipSetSmoothingMode(gr2, SmoothingModeAntiAlias) Then Unload Me
    Set Tmr = Me.Controls.Add("VB.Timer", "Tmr")
    ReDim pt(BranchCount * 2 - 1): ReDim Lamp(BranchCount \ 3 - 2): ReDim sp(BranchCount \ 4 - 1)
    n = Me.ScaleWidth / 3: dy = Me.ScaleHeight / BranchCount / 1.4: sw = Me.ScaleWidth / 2
    dx = n / BranchCount: oy = Me.ScaleHeight * 0.25: MaxLen = Sqr(n * n + 30 * 30)
    pt(0) = vec(sw, oy): pt(1) = vec(Me.ScaleWidth / 2 - 8, Me.ScaleHeight): pt(2) = vec(sw + 8, pt(1).y)
    GdipFillPolygon2 gr2, br, pt(0), 3
    Branch vec(sw, oy + Me.ScaleHeight / 1.5), vec(0, -Me.ScaleHeight / 3), 0, vec(0, 0)
    For n = 0 To BranchCount - 1
        pt(n * 2) = vec(0, 0): pt(n * 2 + 1) = vec(0, 0)
        Call Branch(vec(sw, n * dy + oy), vec(-dx * n, -30), 0, pt(n * 2)): pt(n * 2).x = pt(n * 2).x + sw
        Call Branch(vec(sw, n * dy + oy), vec(dx * n, -30), 0, pt(n * 2 + 1)): pt(n * 2 + 1).x = pt(n * 2 + 1).x + sw
        If n Mod 3 = 0 And n > 1 And n < BranchCount - 1 Then Lamp((n - 1) \ 3) = pt(n * 2)
        If n Mod 4 = 0 And n > 1 Then sp((n - 1) \ 4) = pt(n * 2 + 1)
    Next
    For n = 0 To UBound(sp): dy = (sp(n).x - sw): For dx = 0 To dy Step 10
        v = vec(Lerp(sp(n).x, sw - dy, dx / dy), Lerp(sp(n).y, sp(n).y + 10, Sin(dx / dy * 3.14) * (dy / MaxLen) * 2))
        GdipCreatePath 0, Pth
        GdipAddPathEllipse Pth, v.x - SphereSize, v.y - SphereSize / 2, SphereSize, SphereSize
        GdipCreatePathGradientFromPath Pth, br2
        GdipSetPathGradientCenterPoint br2, vec(v.x - SphereSize / 3, v.y - SphereSize / 3)
        Col = QBColor(Rnd * 15)
        GdipSetPathGradientCenterColor br2, ARGB(255, vbWhite)
        GdipSetPathGradientSurroundColorsWithCount br2, ARGB(64, Col), 1
        GdipFillPath gr2, br2, Pth: GdipDeleteBrush br2: GdipDeletePath Pth
    Next: Next
    dx = 2.199
    For n = 0 To 9 Step 2
        pt(n) = vec(Cos(dx) * StarSize + Me.ScaleWidth / 2, Sin(dx) * StarSize + oy - StarSize - 15): dx = dx + 0.628
        pt(n + 1) = vec(Cos(dx) * StarSize / 2 + Me.ScaleWidth / 2, Sin(dx) * StarSize / 2 + oy - StarSize - 15): dx = dx + 0.628
    Next
    SetWindowLong Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    Tmr.Enabled = True: Tmr.Interval = 32: Call Tmr_Timer
End Sub
 
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    ReleaseCapture
    SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    If pn Then GdipDeletePen (pn)
    If br Then GdipDeleteBrush (br)
    If gr Then GdipDeleteGraphics (gr)
    If gr2 Then GdipDeleteGraphics (gr2)
    If bg Then GdipDisposeImage (bg)
    GdiplusShutdown (token)
End Sub
Private Sub Tmr_Timer()
    Static n As Long, c As Long, d As Single, x As Long, y As Long, dx As Single, Pth As Long, br2 As Long, v As Vector, _
        Col As Long, B As Single, s As Single, dir As Single, sz As Currency, pts As Currency
    d = Sin(c / 10): c = (c + 1) Mod 31: dir = 1
    GdipGraphicsClear gr, &HFF000000
    GdipDrawImage gr, bg, 0, 0
    GdipSetSolidFillColor br, ARGB(d * 128 + 127, vbBlue): GdipSetPenWidth pn, 1: GdipSetPenColor pn, &HFFFF5050
    GdipFillPolygon2 gr, br, pt(0), 10
    GdipDrawPolygon gr, pn, pt(0), 10
    For n = 0 To 9
        GdipDrawLine gr, pn, Me.ScaleWidth / 2, Me.ScaleHeight * 0.25 - StarSize - 15, pt(n).x, pt(n).y
    Next
    For n = 0 To UBound(Lamp): d = sw - Lamp(n).x: dir = -dir: For x = 0 To d Step 2
        B = Abs(Sin(s))
        v = vec(Lerp(Lamp(n).x, sw + d, x / d), Lerp(Lamp(n).y, Lamp(n).y + 10, Sin(x / d * 3.14) * (d / MaxLen) * 3))
        GdipCreatePath 0, Pth
        GdipAddPathEllipse Pth, v.x - LampSize / 2, v.y - LampSize / 2, LampSize, LampSize
        GdipCreatePathGradientFromPath Pth, br2
        GdipSetPathGradientCenterPoint br2, vec(v.x, v.y)
        GdipSetPathGradientCenterColor br2, ARGB(B * 255, vbCyan)
        GdipSetPathGradientSurroundColorsWithCount br2, 0, 1
        GdipFillPath gr, br2, Pth: GdipDeleteBrush br2: GdipDeletePath Pth
        s = s + 2 * dir
    Next:  Next
    Me.Refresh
    sz = (Me.ScaleWidth + CCur(Me.ScaleHeight) * 4294967296#) / 10000
    UpdateLayeredWindow Me.hWnd, Me.hdc, ByVal 0, sz, Me.hdc, pts, 0, AB_32Bpp255, ULW_ALPHA
End Sub
Public Function ARGB(ByVal Alpha As Byte, Col As Long) As Long
  Dim bytestruct As COLORBYTES
  Dim result As COLORLONG
  With bytestruct
      .AlphaByte = Alpha
      .RedByte = (Col And &HFF0000) \ &H10000
      .GreenByte = (Col And &HFF00&) \ &H100
      .BlueByte = (Col And &HFF)
  End With
  LSet result = bytestruct
  ARGB = result.longval
End Function

---