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
Reply With Quote
