Форум программистов, компьютерный форум, киберфорум
The trick
Войти
Регистрация
Восстановить пароль
Рейтинг: 4.86. Голосов: 7.

Генерация ёлки))

Запись от The trick размещена 30.12.2013 в 03:14

К новому году решил сделать анимированную елку на рабочий стол.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
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
Изображения
Тип файла: jpg Безымянный.jpg (85.2 Кб, 1019 просмотров)
Вложения
Тип файла: rar Елка.rar (12.7 Кб, 424 просмотров)
Размещено в Без категории
Показов 10461 Комментарии 12
Всего комментариев 12
Комментарии
  1. Старый комментарий
    Аватар для Памирыч
    Зачетно!
    Там вроде как альфа-канал поддерживается?
    Запись от Памирыч размещена 30.12.2013 в 08:02 Памирыч вне форума
  2. Старый комментарий
    Не плохо :bravo:
    Запись от Release размещена 30.12.2013 в 08:40 Release вне форума
  3. Старый комментарий
    Цитата:
    Сообщение от Памирыч Просмотреть комментарий
    Зачетно!
    Там вроде как альфа-канал поддерживается?
    Спасибо! Да полноценная 32bpp прозрачность, с использованием альфа-канала
    Запись от The trick размещена 30.12.2013 в 11:15 The trick вне форума
  4. Старый комментарий
    Цитата:
    Сообщение от Release Просмотреть комментарий
    Не плохо
    Спасибо!
    Запись от The trick размещена 30.12.2013 в 11:16 The trick вне форума
  5. Старый комментарий
    Аватар для Памирыч
    Всегда мечтал о формате GIF+PNG
    От гифа - анимация, от PNG - альфа (ибо у Гифа нет "полупрозрачности - или пиксель полностью прозрачен, или полностью нет)

    Анатолий, пора изобретать GIFNG))
    Запись от Памирыч размещена 30.12.2013 в 11:21 Памирыч вне форума
  6. Старый комментарий
    Цитата:
    Сообщение от Памирыч Просмотреть комментарий
    Всегда мечтал о формате GIF+PNG
    От гифа - анимация, от PNG - альфа (ибо у Гифа нет "полупрозрачности - или пиксель полностью прозрачен, или полностью нет)

    Анатолий, пора изобретать GIFNG))
    Есть формат APNG, он держит полупрозрачность и поддерживает анимацию, но он не поддерживается GDI+, насколько мне известно, хотя надо будет проверить. Можно написать класс, который будет включать поддержку APNG рисунков в GDI+. А так идея хорошая, может займусь как-нибудь. Впрочем можно использовать секвенцию кадров PNG, имитируя "многокадровость", либо использовать ARGB BMP таким же способом.
    Запись от The trick размещена 30.12.2013 в 11:31 The trick вне форума
  7. Старый комментарий
    Аватар для Arigato
    Понравилась елка!
    Запись от Arigato размещена 30.12.2013 в 18:30 Arigato вне форума
  8. Старый комментарий
    Цитата:
    Сообщение от Arigato_RU Просмотреть комментарий
    Понравилась елка!
    Спасибо!
    Запись от The trick размещена 30.12.2013 в 18:31 The trick вне форума
  9. Старый комментарий
    ВСЁ фигня...
    ГЛАВНОЕ = правильные ярлыки - сразу о человеке всё раскажут...
    Но если доволен он сам, то я тоже доволен...
    Спасибо!!!

    Не по теме:

    Всё время забываю скачать себе эмуляторы детства и молодости...

    Запись от _SASA_ размещена 31.12.2013 в 02:32 _SASA_ вне форума
  10. Старый комментарий
    елка-зашибись просто
    Запись от Agent Smith размещена 12.01.2014 в 21:28 Agent Smith вне форума
  11. Старый комментарий
    Аватар для MrGluck
    Зачёт!
    Запись от MrGluck размещена 12.01.2014 в 21:45 MrGluck вне форума
  12. Старый комментарий
    Аватар для AzaKendler
    Цитата:
    Сообщение от _SASA_ Просмотреть комментарий
    ВСЁ фигня...
    ГЛАВНОЕ = правильные ярлыки - сразу о человеке всё раскажут...
    Но если доволен он сам, то я тоже доволен...
    Спасибо!!!

    Не по теме:

    Всё время забываю скачать себе эмуляторы детства и молодости...

    точняк))
    Запись от AzaKendler размещена 14.01.2014 в 13:30 AzaKendler вне форума
 
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.