Я как-то уже делал такую, но в этот раз я добавил возможность регулировки параметров создания.
Для работы нужна dx8vb.dll. Выход по двойному клику. С новым годом!
- Код: Выделить всё
' frm3DFirTree - главная форма
' © Кривоус Анатолий Анатольевич (The trick), 2014
Option Explicit
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type RECTF
Left As Single
Top As Single
Right As Single
Bottom As Single
End Type
Private Type LOGFONTA
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
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 GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As Long
Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal Graphics As Long, ByVal lColor As Long) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, Bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, Graphics 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 GdipSetSmoothingMode Lib "gdiplus" (ByVal Graphics As Long, ByVal SmoothingMd As Long) As Long
Private Declare Function GdipDrawArc Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single, ByVal startAngle As Single, ByVal sweepAngle As Single) As Long
Private Declare Function GdipDrawString Lib "gdiplus" (ByVal Graphics As Long, ByVal str As Long, ByVal Length As Long, ByVal thefont As Long, layoutRect As RECTF, ByVal StringFormat As Long, ByVal Brush As Long) As Long
Private Declare Function GdipCreateStringFormat Lib "gdiplus" (ByVal formatAttributes As Long, ByVal language As Integer, StringFormat As Long) As Long
Private Declare Function GdipDeleteStringFormat Lib "gdiplus" (ByVal StringFormat As Long) As Long
Private Declare Function GdipCreateFontFromLogfontA Lib "gdiplus" (ByVal hdc As Long, logFont As LOGFONTA, createdfont As Long) As Long
Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal Brush As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal ARGB As Long, Brush As Long) As Long
Private Declare Function GdipDeleteFont Lib "gdiplus" (ByVal curFont As Long) As Long
Private Declare Function GdipSetTextRenderingHint Lib "gdiplus" (ByVal Graphics As Long, ByVal Mode As Long) As Long
Private Declare Function GdipSetStringFormatAlign Lib "gdiplus" (ByVal StringFormat As Long, ByVal align As Long) As Long
Private Declare Function GdipFillRectangle 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 GdipSetSolidFillColor Lib "gdiplus" (ByVal Brush As Long, ByVal ARGB 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 ArrPtr Lib "msvbvm60" Alias "VarPtr" (ptr() As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SendMessageA Lib "user32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As Any) As Long
Private Declare Function ColorHLSToRGB Lib "shlwapi.dll" (ByVal wHue As Integer, ByVal wLuminance As Integer, ByVal wSaturation As Integer) 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 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 Sub ReleaseCapture Lib "user32" ()
Private Declare Sub memcpy Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Const HWND_TOPMOST As Long = -1
Private Const SWP_NOACTIVATE As Long = &H10&
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOOWNERZORDER As Long = &H200
Private Const WS_EX_TOPMOST As Long = &H8&
Private Const GWL_EXSTYLE As Long = &HFFFFFFEC
Private Const WS_EX_LAYERED As Long = &H80000
Private Const ULW_ALPHA As Long = &H2
Private Const HTCAPTION As Long = 2
Private Const WM_NCLBUTTONDOWN As Long = &HA1
Private Const SPI_GETWORKAREA As Long = 48
Private Const AB_32Bpp255 As Long = 33488896
Private Const PixelFormat32bppARGB As Long = &H26200A
Private Const PixelFormat32bppPARGB As Long = &HE200B
Private Const UnitPixel As Long = 2
Private Const SmoothingModeAntiAlias As Long = 4
Private Type Size
cx As Long
cy As Long
End Type
Private Type RECT
iLeft As Long
iTop As Long
iRight As Long
iBottom As Long
End Type
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Type Ray
Position As D3DVECTOR
Direction As D3DVECTOR
End Type
Private Type Branch
Segment As Ray
Thickness As Single
Length As Single
ParentIndex As Long
End Type
Private Type TreeItem
Depth As Long
ParentIndex As Long
ChildsCount As Long
Childs() As Long
End Type
Private Type Tree
ItemsCount As Long
Branches() As Branch
Items() As TreeItem
End Type
Private Const GRANULARITY As Long = 10
Private Const SLIDERSIZE As Long = 32
Private Const PI As Single = 3.14159265358979
Private mFirTree As Tree
Private mStartBranch As Single ' Начало веток снизу дерева (0..1)
Private mBranchStep As Single ' Шаг веток (0..1)
Private mCurvature As Single ' Кривизна (0..1)
Private mBranchDensity As Single ' Кучность веток (0..1)
Private mBranchAngle As Single ' Угол веток (0..1)
Private mRandomization As Single ' Рандомизация (0..1)
Private mReduction As Single ' Сокращение длин (0..1)
Private mBranchDetail As Single ' Детализация ветки (0..1)
Private mBranchThick As Single ' Толщина ветки (0..1)
Private mBranchCurve As Single ' Кривизна ветки (0..1)
Private mNeedleDensity As Single ' Количество иголок (0..1)
Private mNeedleSize As Single ' Ширина иголок (0..1)
Private mBallHue As Single ' Оттенок шаров (0..1)
Private mSeed As Single ' Последовательность (0..1)
Private Type VertexFormat
Position As D3DVECTOR
Normal As D3DVECTOR
u As Single
v As Single
End Type
Private Const vFlag As Long = D3DFVF_XYZ Or D3DFVF_NORMAL Or D3DFVF_TEX1
Dim dx As DirectX8
Dim d3d As Direct3D8
Dim dev As Direct3DDevice8
Dim srfDpth As Direct3DSurface8
Dim srfBuff As Direct3DSurface8
Dim tmpSrf As Direct3DSurface8
Dim texBuff As Direct3DTexture8
Dim bufWood As Direct3DVertexBuffer8
Dim bufNdle As Direct3DVertexBuffer8
Dim bufBall As Direct3DVertexBuffer8
Dim bufStar As Direct3DVertexBuffer8
Dim texBark As Direct3DTexture8
Dim texNdle As Direct3DTexture8
Dim vSize As Long
Dim wpCount As Long
Dim npCount As Long
Dim bpCount As Long
Dim spCount As Long
Dim rotAngY As Single
Dim sVis As Long
Dim sMode As Long
Dim sSel As Long
Dim gdipToken As Long
Dim gdipPen As Long
Dim gdipBrush As Long
Dim gdipFont As Long
Dim gdipFmt As Long
' // Создать дерево
Private Function CreateFirTree() As Boolean
Rnd -1
Randomize mSeed * 327680
ClearBranches
' Добавляем ствол
AddBranch NewBranch(vec3(0, 0, 0), vec3(0, 1, 0), 1, 1)
' Добавляем ветки
Dim percent As Single
' Стартовая позиция снизу
percent = mStartBranch * 0.25
' "Прикрепляем" ветки
Do While percent < 1
AttachBranch percent, mReduction * 0.6 + 0.2
percent = percent + (mBranchStep + 1) * 0.025
Loop
End Function
' // Прикрепить ветку
Private Sub AttachBranch(ByVal percent As Single, _
ByVal brLength As Single, _
Optional ByVal ParentIndex As Long = 0)
Dim brCount As Long
Dim angVal As Single
Dim mtx As D3DMATRIX
Dim Length As Single
Dim thick As Single
Dim idx As Long
Dim dir As D3DVECTOR
Dim ax2 As D3DVECTOR
Dim axs As D3DVECTOR
Dim posVec As D3DVECTOR
Dim tmpVec As D3DVECTOR
Dim deltVec As D3DVECTOR
Dim rndOfst As Single
Dim prntIdx As Long
With mFirTree.Branches(ParentIndex)
' Ось
axs = .Segment.Direction
' Длина ветки в зависимости от кривизны
Length = GetBezier(percent, mCurvature) * brLength
' Толщина ветки в зависимости от толщины родительской ветки в этом месте
thick = BranchInterp(.Thickness, percent)
' Количество веток вокруг ствола
If ParentIndex = 0 Then
brCount = Rand(3, (mBranchDensity + 1) * 5)
Else
brCount = Rnd * 2 + 1
End If
angVal = 2 * PI / brCount
' Получаем начальный перпендикулярный вектор
dir = GetPerpendicular(axs)
D3DXVec3Normalize dir, dir
' Получаем вектор относительно которого будем отклонять ветки
D3DXVec3Cross ax2, axs, dir
' Отклоняем
If ParentIndex = 0 Then
D3DXMatrixRotationAxis mtx, ax2, Randomization(PI / 4 * (mBranchAngle * 2 - 1), PI / 4)
Else
D3DXMatrixRotationAxis mtx, ax2, -PI / 3
End If
D3DXVec3TransformCoord dir, dir, mtx
' Сначала прокручиваем на рандомный угол для того чтобы все ветки были в разных плоскостях
D3DXMatrixRotationAxis mtx, axs, Rnd * PI
D3DXVec3TransformCoord dir, dir, mtx
' Получаем вращение вокруг ствола
D3DXMatrixRotationAxis mtx, axs, angVal
' Получаем позицию для вставки
posVec.x = .Segment.Direction.x * .Length * percent + .Segment.Position.x
posVec.y = .Segment.Direction.y * .Length * percent + .Segment.Position.y
posVec.z = .Segment.Direction.z * .Length * percent + .Segment.Position.z
' Получаем вектор расстояния между двумя соседними ветками
deltVec.x = .Segment.Direction.x * (mBranchStep + 1) * 0.025
deltVec.y = .Segment.Direction.y * (mBranchStep + 1) * 0.025
deltVec.z = .Segment.Direction.z * (mBranchStep + 1) * 0.025
End With
' Прокручиваем вокруг ствола
Do While brCount
D3DXVec3TransformCoord dir, dir, mtx
' Вставляем по кругу ветки относительно ствола
rndOfst = Randomization(0, (mBranchStep + 1) * 0.025)
tmpVec.x = deltVec.x * rndOfst + posVec.x
tmpVec.y = deltVec.y * rndOfst + posVec.y
tmpVec.z = deltVec.z * rndOfst + posVec.z
prntIdx = AddBranch(NewBranch(tmpVec, _
dir, _
thick, _
Randomization(Length, Length * 0.5)), _
ParentIndex)
If ParentIndex = 0 Then
Dim percent2 As Single
percent2 = 0.25
Do While percent2 < 1
AttachBranch percent2, Length * (mReduction * 0.6 + 0.2), prntIdx
percent2 = Randomization(percent2 + 0.25, 0.25)
Loop
End If
brCount = brCount - 1
Loop
End Sub
' // Очистка дерева
Private Sub ClearBranches()
mFirTree.ItemsCount = 0
Erase mFirTree.Branches()
Erase mFirTree.Items()
End Sub
' // Функция добавляет дочернюю ветку
Private Function AddBranch(mBranch As Branch, Optional ByVal ParentIndex As Long = -1) As Long
Dim idx As Long
Dim cld As Long
idx = mFirTree.ItemsCount
If idx >= ArrayCount(ArrPtr(mFirTree.Branches())) Then
ReDim Preserve mFirTree.Branches(idx + GRANULARITY)
ReDim Preserve mFirTree.Items(idx + GRANULARITY)
End If
mFirTree.Branches(idx) = mBranch
mFirTree.Branches(idx).ParentIndex = ParentIndex
With mFirTree.Items(idx)
If ParentIndex >= 0 Then
.Depth = mFirTree.Items(ParentIndex).Depth + 1
With mFirTree.Items(ParentIndex)
cld = .ChildsCount
If cld >= ArrayCount(ArrPtr(.Childs())) Then
ReDim Preserve .Childs(idx + GRANULARITY)
End If
.Childs(cld) = idx
.ChildsCount = .ChildsCount + 1
End With
End If
.ParentIndex = ParentIndex
End With
mFirTree.ItemsCount = mFirTree.ItemsCount + 1
AddBranch = idx
End Function
' // Создать 3D модель
Private Function Create3DModel() As Boolean
Dim bufSize As Long
Dim bufSizeByte As Long
Dim Index As Long
Dim vtxWood() As VertexFormat
Dim vtxNdle() As VertexFormat
Dim vtxBall() As VertexFormat
Dim vtxStar() As VertexFormat
Dim wIdx As Long
Dim nIdx As Long
Dim bIdx As Long
Dim sIdx As Long
Dim sides As Long
' Буфер
ReDim Preserve vtxWood(30000& - 1)
ReDim Preserve vtxNdle(30000& - 1)
ReDim Preserve vtxBall(30000& - 1)
ReDim Preserve vtxStar(30000& - 1)
wpCount = 0
npCount = 0
bpCount = 0
spCount = 0
' Количество сторон ветки
sides = mBranchDetail * 6 + 4
For Index = 0 To mFirTree.ItemsCount - 1
With mFirTree.Branches(Index)
Dim shlVec As D3DVECTOR
Dim tmpVec As D3DVECTOR
Dim endVec As D3DVECTOR
Dim posVec(3) As D3DVECTOR
Dim norm1 As D3DVECTOR
Dim norm2 As D3DVECTOR
Dim mtx As D3DMATRIX
Dim numOfSegs As Long
Dim iSeg As Long
Dim rad(1) As Single
Dim sideLen As Single
Dim iTri As Long
Dim iSide As Long
Dim thick As Single
Dim texX As Single
Dim texY As Single
Dim texdX As Single
Dim texdY As Single
thick = .Thickness * 0.01 * (mBranchThick + 1)
' Конец ветки
D3DXVec3Scale endVec, .Segment.Direction, .Length
D3DXVec3Add endVec, .Segment.Position, endVec
' Находим вектор перпендикулярный ветке
shlVec = GetPerpendicular(.Segment.Direction)
D3DXVec3Normalize shlVec, shlVec
' Получаем нормали
D3DXMatrixRotationAxis mtx, .Segment.Direction, PI / sides
D3DXVec3TransformCoord norm1, shlVec, mtx
D3DXMatrixRotationAxis mtx, .Segment.Direction, -PI / sides
D3DXVec3TransformCoord norm2, shlVec, mtx
' Находим вращение вокруг ветки
D3DXMatrixRotationAxis mtx, .Segment.Direction, PI * 2 / sides
' Количество сегментов
numOfSegs = .Length * (mBranchDetail * 15 + 2)
If numOfSegs < 1 Then numOfSegs = 1
' Проход по сегментам
rad(0) = BranchInterp(thick, 0)
posVec(0) = .Segment.Position
iSeg = 1
' Количество треугольников
wpCount = wpCount + numOfSegs * sides * 2
' Выделяем буфер под вершины
If wpCount * 3 > UBound(vtxWood) Then
ReDim Preserve vtxWood(wpCount * 3 + 30000&)
End If
' Приращение текстуры
texdY = 1 / numOfSegs
texdX = 1 / sides
texY = 0
Do While iSeg <= numOfSegs
D3DXVec3Lerp posVec(1), .Segment.Position, endVec, iSeg / numOfSegs
rad(1) = BranchInterp(thick, iSeg / numOfSegs)
iSide = 0
texX = 0
Do While iSide < sides
' Находим вектор касательной к поверхности относительно разреза ветки
D3DXVec3Cross tmpVec, shlVec, .Segment.Direction
For iTri = 0 To 1
' Размер стороны многоугольника пополам, т.к. вектор нормали смотрит в центр
sideLen = rad(iTri) * Tan(PI / sides)
vtxWood(wIdx).Position.x = sideLen * tmpVec.x + posVec(iTri).x + shlVec.x * rad(iTri)
vtxWood(wIdx).Position.y = sideLen * tmpVec.y + posVec(iTri).y + shlVec.y * rad(iTri)
vtxWood(wIdx).Position.z = sideLen * tmpVec.z + posVec(iTri).z + shlVec.z * rad(iTri)
vtxWood(wIdx).u = texX
vtxWood(wIdx).v = texY + iTri * texdY
vtxWood(wIdx).Normal = norm2
wIdx = wIdx + 1
If iTri = 1 Then vtxWood(wIdx) = vtxWood(wIdx - 1): wIdx = wIdx + 1
If iTri = 1 Then vtxWood(wIdx) = vtxWood(wIdx - 3): wIdx = wIdx + 1
vtxWood(wIdx).Position.x = -sideLen * tmpVec.x + posVec(iTri).x + shlVec.x * rad(iTri)
vtxWood(wIdx).Position.y = -sideLen * tmpVec.y + posVec(iTri).y + shlVec.y * rad(iTri)
vtxWood(wIdx).Position.z = -sideLen * tmpVec.z + posVec(iTri).z + shlVec.z * rad(iTri)
vtxWood(wIdx).u = texX + texdX
vtxWood(wIdx).v = texY + iTri * texdY
vtxWood(wIdx).Normal = norm1
wIdx = wIdx + 1
Next
' Поворот к следующей стороне
D3DXVec3TransformCoord shlVec, shlVec, mtx
D3DXVec3TransformCoord norm2, norm2, mtx
D3DXVec3TransformCoord norm1, norm1, mtx
iSide = iSide + 1
texX = texX + texdX
Loop
texY = texY + texdY
rad(0) = rad(1)
posVec(0) = posVec(1)
iSeg = iSeg + 1
Loop
' Конструируем иголки
Dim numOfNdl As Long
Dim iNeedle As Long
Dim ndlLen As Single
numOfNdl = mNeedleDensity * 3 + 2
npCount = npCount + numOfNdl * 2
sideLen = mNeedleSize * 0.05 + 0.01
If Index = 0 Then
rad(1) = BranchInterp(thick, 1) + sideLen / 4
rad(0) = BranchInterp(thick, 0) + sideLen / 4
Else
rad(1) = BranchInterp(thick, 1) + sideLen
rad(0) = BranchInterp(thick, 0) + sideLen
End If
D3DXMatrixRotationAxis mtx, .Segment.Direction, PI / numOfNdl
' Буфер под вершины
If nIdx + numOfNdl * 6 > UBound(vtxNdle) Then
ReDim Preserve vtxNdle(nIdx + numOfNdl * 6 + 30000&)
End If
ndlLen = .Length + 0.05
Do While numOfNdl
D3DXVec3Cross tmpVec, shlVec, .Segment.Direction
vtxNdle(nIdx).Position.x = shlVec.x * rad(0) + .Segment.Position.x
vtxNdle(nIdx).Position.y = shlVec.y * rad(0) + .Segment.Position.y
vtxNdle(nIdx).Position.z = shlVec.z * rad(0) + .Segment.Position.z
vtxNdle(nIdx).u = .Length
vtxNdle(nIdx).v = 0
nIdx = nIdx + 1
vtxNdle(nIdx).Position.x = shlVec.x * rad(1) + .Segment.Position.x + .Segment.Direction.x * ndlLen
vtxNdle(nIdx).Position.y = shlVec.y * rad(1) + .Segment.Position.y + .Segment.Direction.y * ndlLen
vtxNdle(nIdx).Position.z = shlVec.z * rad(1) + .Segment.Position.z + .Segment.Direction.z * ndlLen
vtxNdle(nIdx).u = 0
vtxNdle(nIdx).v = 0
nIdx = nIdx + 1
vtxNdle(nIdx).Position.x = -shlVec.x * rad(0) + .Segment.Position.x
vtxNdle(nIdx).Position.y = -shlVec.y * rad(0) + .Segment.Position.y
vtxNdle(nIdx).Position.z = -shlVec.z * rad(0) + .Segment.Position.z
vtxNdle(nIdx).u = .Length
vtxNdle(nIdx).v = 1
nIdx = nIdx + 1
vtxNdle(nIdx) = vtxNdle(nIdx - 1): nIdx = nIdx + 1
vtxNdle(nIdx) = vtxNdle(nIdx - 3): nIdx = nIdx + 1
vtxNdle(nIdx).Position.x = -shlVec.x * rad(1) + .Segment.Position.x + .Segment.Direction.x * ndlLen
vtxNdle(nIdx).Position.y = -shlVec.y * rad(1) + .Segment.Position.y + .Segment.Direction.y * ndlLen
vtxNdle(nIdx).Position.z = -shlVec.z * rad(1) + .Segment.Position.z + .Segment.Direction.z * ndlLen
vtxNdle(nIdx).u = 0
vtxNdle(nIdx).v = 1
nIdx = nIdx + 1
' Поворот к следующей стороне
D3DXVec3TransformCoord shlVec, shlVec, mtx
numOfNdl = numOfNdl - 1
Loop
Dim ballSize As Single
' Игрушки (шары)
If Index Then
If mFirTree.Items(.ParentIndex).Depth = 0 And .Segment.Position.y < Rnd Then
posVec(0) = vec3(0, 1, 0)
iSeg = 1
numOfSegs = 8
ballSize = 0.015
D3DXMatrixRotationY mtx, PI * 2 / numOfSegs
If bIdx + numOfSegs * numOfSegs * 6 > UBound(vtxBall) Then
ReDim Preserve vtxBall(bIdx + numOfSegs * numOfSegs * 6 + 30000&)
End If
Do While iSeg <= numOfSegs
posVec(1) = vec3(0, Cos(iSeg / numOfSegs * PI), Sin(iSeg / numOfSegs * PI))
iSide = 0
Do While iSide < numOfSegs
D3DXVec3TransformCoord posVec(2), posVec(0), mtx
D3DXVec3TransformCoord posVec(3), posVec(1), mtx
For iTri = 0 To 2
vtxBall(bIdx).Position.x = posVec(iTri).x * ballSize + .Segment.Position.x + .Segment.Direction.x * .Length
vtxBall(bIdx).Position.y = posVec(iTri).y * ballSize + .Segment.Position.y + .Segment.Direction.y * .Length - 0.02
vtxBall(bIdx).Position.z = posVec(iTri).z * ballSize + .Segment.Position.z + .Segment.Direction.z * .Length
vtxBall(bIdx).Normal = posVec(iTri)
bIdx = bIdx + 1
Next
For iTri = 3 To 1 Step -1
vtxBall(bIdx).Position.x = posVec(iTri).x * ballSize + .Segment.Position.x + .Segment.Direction.x * .Length
vtxBall(bIdx).Position.y = posVec(iTri).y * ballSize + .Segment.Position.y + .Segment.Direction.y * .Length - 0.02
vtxBall(bIdx).Position.z = posVec(iTri).z * ballSize + .Segment.Position.z + .Segment.Direction.z * .Length
vtxBall(bIdx).Normal = posVec(iTri)
bIdx = bIdx + 1
Next
posVec(0) = posVec(2)
posVec(1) = posVec(3)
iSide = iSide + 1
bpCount = bpCount + 2
Loop
posVec(0) = posVec(1)
iSeg = iSeg + 1
Loop
End If
End If
End With
'Exit For
Next
' Звезда
Dim ang As Single
Dim starSize As Single
Dim starOfst As Single
starSize = 0.06
starOfst = 1 + starSize / 2
For iTri = 0 To 1
ang = PI / 10
For iSeg = 0 To 9
vtxStar(sIdx).Position = vec3(0, starOfst, (iTri * 2 - 1) * 0.2 * starSize)
sIdx = sIdx + 1
If iSeg Then
vtxStar(sIdx + iTri).Position = vtxStar(sIdx - 2 - iTri).Position
Else
vtxStar(sIdx + iTri).Position = vec3(Cos(ang) * starSize, Sin(ang) * starSize + starOfst, 0)
ang = ang - PI / 5
End If
sIdx = sIdx + 1
If iSeg Mod 2 Then
vtxStar(sIdx - iTri).Position = vec3(Cos(ang) * starSize, Sin(ang) * starSize + starOfst, 0)
Else
vtxStar(sIdx - iTri).Position = vec3(Cos(ang) * 0.5 * starSize, Sin(ang) * starSize * 0.5 + starOfst, 0)
End If
D3DXVec3Subtract posVec(0), vtxStar(sIdx - 2).Position, vtxStar(sIdx).Position
D3DXVec3Subtract posVec(1), vtxStar(sIdx - 1).Position, vtxStar(sIdx).Position
D3DXVec3Cross vtxStar(sIdx - 2).Normal, posVec(0), posVec(1)
D3DXVec3Normalize vtxStar(sIdx - 2).Normal, vtxStar(sIdx - 2).Normal
vtxStar(sIdx - 1).Normal = vtxStar(sIdx - 2).Normal
vtxStar(sIdx).Normal = vtxStar(sIdx - 2).Normal
ang = ang - PI / 5
sIdx = sIdx + 1
Next
Next
spCount = 20
Dim ptr As Long
bufSize = 3 * wpCount: vSize = Len(vtxWood(0)): bufSizeByte = bufSize * vSize
Set bufWood = dev.CreateVertexBuffer(bufSizeByte, 0, vFlag, D3DPOOL_DEFAULT)
bufWood.Lock 0, bufSizeByte, ptr, 0
memcpy ByVal ptr, vtxWood(0), bufSizeByte
bufWood.Unlock
bufSize = 3 * npCount: vSize = Len(vtxNdle(0)): bufSizeByte = bufSize * vSize
Set bufNdle = dev.CreateVertexBuffer(bufSizeByte, 0, vFlag, D3DPOOL_DEFAULT)
bufNdle.Lock 0, bufSizeByte, ptr, 0
memcpy ByVal ptr, vtxNdle(0), bufSizeByte
bufNdle.Unlock
bufSize = 3 * bpCount: vSize = Len(vtxBall(0)): bufSizeByte = bufSize * vSize
Set bufBall = dev.CreateVertexBuffer(bufSizeByte, 0, vFlag, D3DPOOL_DEFAULT)
bufBall.Lock 0, bufSizeByte, ptr, 0
memcpy ByVal ptr, vtxBall(0), bufSizeByte
bufBall.Unlock
bufSize = 3 * spCount: vSize = Len(vtxStar(0)): bufSizeByte = bufSize * vSize
Set bufStar = dev.CreateVertexBuffer(bufSizeByte, 0, vFlag, D3DPOOL_DEFAULT)
bufStar.Lock 0, bufSizeByte, ptr, 0
memcpy ByVal ptr, vtxStar(0), bufSizeByte
bufStar.Unlock
End Function
' // Визуализация
Private Sub Render()
Dim mat As D3DMATERIAL8
Dim clr As Long
dev.BeginScene
dev.Clear 0, ByVal 0&, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &H1000000, 1, 0
dev.SetVertexShader vFlag
dev.SetStreamSource 0, bufWood, vSize
dev.SetTexture 0, texBark
dev.SetRenderState D3DRS_CULLMODE, D3DCULL_CCW
dev.SetRenderState D3DRS_ZWRITEENABLE, 1
dev.SetRenderState D3DRS_ALPHABLENDENABLE, 0
dev.SetRenderState D3DRS_LIGHTING, 1
dev.SetTextureStageState 0, D3DTSS_COLOROP, D3DTOP_MODULATE
dev.SetTextureStageState 0, D3DTSS_COLORARG1, D3DTA_TEXTURE
dev.SetTextureStageState 0, D3DTSS_COLORARG2, D3DTA_DIFFUSE
dev.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_SELECTARG1
dev.SetTextureStageState 0, D3DTSS_ALPHAARG1, D3DTA_DIFFUSE
mat.diffuse = col(1, 1, 1)
dev.SetMaterial mat
dev.DrawPrimitive D3DPT_TRIANGLELIST, 0, wpCount
clr = ColorHLSToRGB(mBallHue * 240, 120, 240)
mat.diffuse = col((clr And &HFF) / &H100, (clr And &HFF00&) / &H10000, (clr And &HFF0000) / &H1000000)
mat.specular = col(1, 1, 1)
mat.power = 5
dev.SetMaterial mat
dev.SetStreamSource 0, bufBall, vSize
dev.SetTextureStageState 0, D3DTSS_COLOROP, D3DTOP_SELECTARG1
dev.SetTextureStageState 0, D3DTSS_COLORARG1, D3DTA_DIFFUSE
dev.SetRenderState D3DRS_SPECULARENABLE, 1
dev.SetRenderState D3DRS_SPECULARMATERIALSOURCE, D3DMCS_MATERIAL
dev.DrawPrimitive D3DPT_TRIANGLELIST, 0, bpCount
dev.SetStreamSource 0, bufStar, vSize
mat.diffuse = col(1, 0, 0)
mat.specular = col(1, 1, 1)
mat.power = 30
dev.SetMaterial mat
dev.DrawPrimitive D3DPT_TRIANGLELIST, 0, spCount
dev.SetStreamSource 0, bufNdle, vSize
dev.SetTexture 0, texNdle
dev.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE
dev.SetRenderState D3DRS_ZWRITEENABLE, 0
dev.SetRenderState D3DRS_SRCBLEND, D3DBLEND_SRCALPHA
dev.SetRenderState D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA
dev.SetRenderState D3DRS_BLENDOP, D3DBLENDOP_ADD
dev.SetRenderState D3DRS_ALPHABLENDENABLE, 1
dev.SetRenderState D3DRS_LIGHTING, 0
dev.SetRenderState D3DRS_SPECULARENABLE, 0
dev.SetTextureStageState 0, D3DTSS_COLOROP, D3DTOP_SELECTARG1
dev.SetTextureStageState 0, D3DTSS_COLORARG1, D3DTA_TEXTURE
dev.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_SELECTARG1
dev.SetTextureStageState 0, D3DTSS_ALPHAARG1, D3DTA_TEXTURE
dev.DrawPrimitive D3DPT_TRIANGLELIST, 0, npCount
dev.EndScene
dev.CopyRects srfBuff, ByVal 0&, 0, tmpSrf, ByVal 0&
Dim lrc As D3DLOCKED_RECT
Dim bi As BITMAPINFO
bi.bmiHeader.biSize = Len(bi.bmiHeader)
bi.bmiHeader.biBitCount = 32
bi.bmiHeader.biHeight = -Me.ScaleHeight
bi.bmiHeader.biWidth = Me.ScaleWidth
bi.bmiHeader.biPlanes = 1
tmpSrf.LockRect lrc, ByVal 0&, 0
Dim gdipBitmap As Long
Dim gdipGraphics As Long
Dim dat() As Long
If sMode Then
GdipCreateBitmapFromScan0 bi.bmiHeader.biWidth, -bi.bmiHeader.biHeight, lrc.Pitch, PixelFormat32bppPARGB, ByVal lrc.pBits, gdipBitmap
GdipGetImageGraphicsContext gdipBitmap, gdipGraphics
GdipSetSmoothingMode gdipGraphics, SmoothingModeAntiAlias
DrawSlider gdipGraphics
GdipDeleteGraphics gdipGraphics
GdipDisposeImage gdipBitmap
End If
SetDIBitsToDevice Me.hdc, 0, 0, Me.ScaleWidth, Me.ScaleHeight, 0, 0, 0, Me.ScaleHeight, ByVal lrc.pBits, bi, 0
tmpSrf.UnlockRect
Dim pt As Size
Dim sz As Size
Dim pos As Size
pt.cx = Me.Left / Screen.TwipsPerPixelX
pt.cy = Me.Top / Screen.TwipsPerPixelY
sz.cx = Me.ScaleWidth
sz.cy = Me.ScaleHeight
UpdateLayeredWindow Me.hWnd, Me.hdc, pt, sz, Me.hdc, pos, 0, AB_32Bpp255, ULW_ALPHA
Me.Refresh
End Sub
' // Отрисовка слайдера
Private Sub DrawSlider(ByVal Graphics As Long)
Dim idx As Long
Dim x As Long
Dim y As Long
Dim ang As Single
Dim v As Single
Dim fmt As Long
Dim lbl As String
Dim rc As RECTF
Dim a As Long
y = 5: x = 5
If sMode = 1 Or sMode = 3 Then a = sVis * &H1000000 Else a = &H80000000
GdipSetSolidFillColor gdipBrush, &HF0F0F0 Or a
GdipFillRectangle Graphics, gdipBrush, 0, 0, (SLIDERSIZE + 10) * 3, (SLIDERSIZE + 10) * 5 + 5
GdipSetSolidFillColor gdipBrush, &H0 Or a
GdipSetTextRenderingHint Graphics, 4
For idx = 0 To 13
Select Case idx
Case 0: v = mStartBranch: lbl = "START"
Case 1: v = mCurvature: lbl = "CURVE"
Case 2: v = mBranchStep: lbl = "STEP"
Case 3: v = mBranchDensity: lbl = "DENSITY"
Case 4: v = mBranchAngle: lbl = "ANGLE"
Case 5: v = mRandomization: lbl = "RANDOM"
Case 6: v = mReduction: lbl = "REDUCT"
Case 7: v = mBranchDetail: lbl = "DETAIL"
Case 8: v = mBranchThick: lbl = "THICK"
Case 9: v = mBranchCurve: lbl = "TRUNK"
Case 10: v = mNeedleDensity: lbl = "DENSITY"
Case 11: v = mNeedleSize: lbl = "SIZE"
Case 12: v = mBallHue: lbl = "HUE"
Case 13: v = mSeed: lbl = "SEED"
End Select
ang = v * 270
If idx > 0 And (idx Mod 3) = 0 Then
x = 5
y = y + SLIDERSIZE + 10
End If
rc.Left = x
rc.Top = y + SLIDERSIZE
rc.Right = SLIDERSIZE
rc.Bottom = 10
GdipSetPenWidth gdipPen, 1
GdipSetPenColor gdipPen, a
GdipDrawArc Graphics, gdipPen, x, y, SLIDERSIZE, SLIDERSIZE, 45, -270
GdipDrawArc Graphics, gdipPen, x + 8, y + 8, SLIDERSIZE - 16, SLIDERSIZE - 16, 45, -270
GdipSetPenWidth gdipPen, 6
GdipSetPenColor gdipPen, &H8000& Or a
GdipDrawArc Graphics, gdipPen, x + 3, y + 3, SLIDERSIZE - 6, SLIDERSIZE - 6, 135, ang
GdipDrawString Graphics, StrPtr(lbl), Len(lbl), gdipFont, rc, gdipFmt, gdipBrush
x = x + SLIDERSIZE + 10
Next
End Sub
Private Sub Form_DblClick()
Unload Me
End Sub
Private Sub Form_Load()
Dim rc As RECT
SystemParametersInfo SPI_GETWORKAREA, 0, rc, 0
SetWindowPos Me.hWnd, 0, rc.iRight - Me.ScaleWidth, rc.iBottom - Me.ScaleHeight, 0, 0, SWP_NOSIZE Or SWP_NOOWNERZORDER
mCurvature = 0.5
mReduction = 0.5
Dim d3dpp As D3DPRESENT_PARAMETERS
Set dx = New DirectX8
Set d3d = dx.Direct3DCreate()
d3dpp.Windowed = 1
d3dpp.SwapEffect = D3DSWAPEFFECT_DISCARD
d3dpp.BackBufferFormat = D3DFMT_A8R8G8B8
d3dpp.BackBufferCount = 1
d3dpp.EnableAutoDepthStencil = 1
d3dpp.AutoDepthStencilFormat = D3DFMT_D16
Set dev = d3d.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Me.hWnd, D3DCREATE_HARDWARE_VERTEXPROCESSING, d3dpp)
Set texBuff = dev.CreateTexture(Me.ScaleWidth, Me.ScaleHeight, 1, D3DUSAGE_RENDERTARGET, D3DFMT_A8R8G8B8, D3DPOOL_DEFAULT)
Set srfDpth = dev.CreateDepthStencilSurface(Me.ScaleWidth, Me.ScaleHeight, D3DFMT_D16, D3DMULTISAMPLE_NONE)
Set srfBuff = texBuff.GetSurfaceLevel(0)
Set tmpSrf = dev.CreateImageSurface(Me.ScaleWidth, Me.ScaleHeight, D3DFMT_A8R8G8B8)
dev.SetRenderTarget srfBuff, srfDpth, 0
Dim mtx As D3DMATRIX
D3DXMatrixLookAtLH mtx, vec3(0, 0.5, -5), vec3(0, 0.5, 0), vec3(0, 1, 0)
dev.SetTransform D3DTS_VIEW, mtx
D3DXMatrixPerspectiveLH mtx, 0.25, 0.25, 1, 100
dev.SetTransform D3DTS_PROJECTION, mtx
dev.SetTextureStageState 0, D3DTSS_MIPFILTER, D3DTEXF_LINEAR
dev.SetTextureStageState 0, D3DTSS_MINFILTER, D3DTEXF_LINEAR
Dim lth As D3DLIGHT8
lth.Type = D3DLIGHT_POINT
lth.diffuse = col(1, 1, 1)
lth.specular = col(1, 1, 1)
lth.Position = vec3(0, 1, -1)
lth.Attenuation1 = 0.6
lth.Range = 100
dev.SetLight 0, lth
dev.LightEnable 0, 1
SetWindowLong Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED
Dim gpInput As GdiplusStartupInput
Dim logFnt As LOGFONTA
gpInput.GdiplusVersion = 1
If GdiplusStartup(gdipToken, gpInput) Then Unload Me: Exit Sub
GdipCreatePen1 0, 1, UnitPixel, gdipPen
GdipCreateSolidFill &H800000F0, gdipBrush
logFnt.lfCharSet = 0
logFnt.lfHeight = -8
logFnt.lfWeight = 400
logFnt.lfFaceName = "Arial" & vbNullChar
GdipCreateFontFromLogfontA Me.hdc, logFnt, gdipFont
GdipCreateStringFormat 0, &H409, gdipFmt
GdipSetStringFormatAlign gdipFmt, 1
sSel = -1
mStartBranch = 0.4
mBranchStep = 0.2
mCurvature = 0.5
mBranchDensity = 0.5
mBranchAngle = 0.6
mRandomization = 0.4
mReduction = 0.4
mBranchDetail = 0.5
mBranchThick = 0.2
mBranchCurve = 0.3
mNeedleDensity = 0.3
mNeedleSize = 0.2
mBallHue = 0
mSeed = 0
CreateFirTree
Create3DModel
CreateBarkTexture
CreateNeedlesTexture
End Sub
' // Функция создания ветки
Private Function NewBranch(Position As D3DVECTOR, Direction As D3DVECTOR, ByVal Thickness As Single, ByVal Length As Single) As Branch
NewBranch.Segment.Position = Position
NewBranch.Segment.Direction = Direction
NewBranch.Thickness = Thickness
NewBranch.Length = Length
End Function
' // Функция создания векторов
Private Function vec3(ByVal x As Single, ByVal y As Single, ByVal z As Single) As D3DVECTOR
vec3.x = x: vec3.y = y: vec3.z = z
End Function
' // Функция создания цвета
Private Function col(ByVal r As Single, ByVal g As Single, ByVal b As Single) As D3DCOLORVALUE
col.r = r: col.g = g: col.b = b: col.a = 1
End Function
' // Получает количество элементов массива
Private Function ArrayCount(ByVal ptr As Long) As Long
GetMem4 ByVal ptr, ptr
If ptr = 0 Then Exit Function
GetMem4 ByVal ptr + &H10, ArrayCount
End Function
' // Получает значение квадратичной кривой Безье в точке x, с контрольными точками (0, 1), (z, z), (1, 0)
Private Function GetBezier(ByVal x As Single, ByVal z As Single) As Single
Dim t As Single, b As Single
b = -2 * z
If b = -1 Then GetBezier = 1 - x: Exit Function
t = (b + Sqr(b * b + 4 * (1 + b) * x)) / (2 * (b + 1))
GetBezier = (1 - t) * (1 - t) + 2 * z * t * (1 - t)
End Function
' // Возвращает перпендикуляр
Private Function GetPerpendicular(v As D3DVECTOR) As D3DVECTOR
If v.z = 0 And v.y = 0 Then
GetPerpendicular = vec3(v.y, -v.x, 0)
Else
GetPerpendicular = vec3(0, v.z, -v.y)
End If
End Function
' // Возвращает случайное число из диапазона
Private Function Rand(ByVal v1 As Single, ByVal v2 As Single) As Single
Rand = Rnd * (v2 - v1) + v1
End Function
' // Интерполяция для веток
Private Function BranchInterp(ByVal v As Single, ByVal t As Single) As Single
If t > 1 Then t = 1 Else If t < 0 Then t = 0
BranchInterp = GetBezier(t, mBranchCurve) * v
End Function
' // Добавить случайность
Private Function Randomization(ByVal v As Single, ByVal factor As Single) As Single
Randomization = v + (Rnd * factor - factor / 2) * mRandomization
End Function
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If sMode = 2 Then
sSel = -1
If x > 5 And y > 5 And x < (SLIDERSIZE + 10) * 3 And y < (SLIDERSIZE + 10) * 5 + 5 Then
Dim row As Long
Dim col As Long
x = x - 5
y = y - 5
If (x Mod (SLIDERSIZE + 10)) > SLIDERSIZE Then GoTo MOVEWINDOW
If (y Mod (SLIDERSIZE + 10)) > SLIDERSIZE Then GoTo MOVEWINDOW
row = x \ (SLIDERSIZE + 10)
col = y \ (SLIDERSIZE + 10)
sSel = row + col * 3
Exit Sub
End If
sVis = &H80
End If
MOVEWINDOW:
Dim pos As Currency
ReleaseCapture
GetCursorPos pos
SendMessageA Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, pos
sMode = 1
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Static oy As Single
If sSel >= 0 Then
Dim delta As Single
delta = -(y - oy) / 100
Select Case sSel
Case 0
mStartBranch = mStartBranch + delta
If mStartBranch > 1 Then mStartBranch = 1 Else If mStartBranch < 0 Then mStartBranch = 0
Case 1
mCurvature = mCurvature + delta
If mCurvature > 1 Then mCurvature = 1 Else If mCurvature < 0 Then mCurvature = 0
Case 2
mBranchStep = mBranchStep + delta
If mBranchStep > 1 Then mBranchStep = 1 Else If mBranchStep < 0 Then mBranchStep = 0
Case 3
mBranchDensity = mBranchDensity + delta
If mBranchDensity > 1 Then mBranchDensity = 1 Else If mBranchDensity < 0 Then mBranchDensity = 0
Case 4
mBranchAngle = mBranchAngle + delta
If mBranchAngle > 1 Then mBranchAngle = 1 Else If mBranchAngle < 0 Then mBranchAngle = 0
Case 5
mRandomization = mRandomization + delta
If mRandomization > 1 Then mRandomization = 1 Else If mRandomization < 0 Then mRandomization = 0
Case 6
mReduction = mReduction + delta
If mReduction > 1 Then mReduction = 1 Else If mReduction < 0 Then mReduction = 0
Case 7
mBranchDetail = mBranchDetail + delta
If mBranchDetail > 1 Then mBranchDetail = 1 Else If mBranchDetail < 0 Then mBranchDetail = 0
Case 8
mBranchThick = mBranchThick + delta
If mBranchThick > 1 Then mBranchThick = 1 Else If mBranchThick < 0 Then mBranchThick = 0
Case 9
mBranchCurve = mBranchCurve + delta
If mBranchCurve > 1 Then mBranchCurve = 1 Else If mBranchCurve < 0 Then mBranchCurve = 0
Case 10
mNeedleDensity = mNeedleDensity + delta
If mNeedleDensity > 1 Then mNeedleDensity = 1 Else If mNeedleDensity < 0 Then mNeedleDensity = 0
Case 11
mNeedleSize = mNeedleSize + delta
If mNeedleSize > 1 Then mNeedleSize = 1 Else If mNeedleSize < 0 Then mNeedleSize = 0
Case 12
mBallHue = mBallHue + delta
If mBallHue > 1 Then mBallHue = 1 Else If mBallHue < 0 Then mBallHue = 0
Case 13
mSeed = mSeed + delta / 10
If mSeed > 1 Then mSeed = 1 Else If mSeed < 0 Then mSeed = 0
End Select
Render
sVis = &H80
End If
oy = y
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If sSel >= 0 Then
ClearBranches
CreateFirTree
Create3DModel
End If
sSel = -1
End Sub
' // Функция генерирует текстуру иголок
Private Sub CreateNeedlesTexture()
Dim out() As Long
Dim w As Long
Dim h As Long
Dim x As Long
Dim y As Long
Dim n As Long
Dim t As Long
ReDim out(1023, 31)
w = UBound(out, 1) + 1: h = UBound(out, 2) + 1
For x = 0 To w - h \ 2 - 1 Step 5
t = (1 - x / w) * 8
For n = t To h \ 2 - 1
out(x + n, n) = &HFF008000
out(x + n + 1, n) = &HFF008000
out(x + (h \ 2 - n) + t, n + h \ 2 - t) = &HFF008000
out(x + (h \ 2 - n) + t + 1, n + h \ 2 - t) = &HFF008000
Next
Next
Dim lrc As D3DLOCKED_RECT
Set texNdle = dev.CreateTexture(w, h, 1, 0, D3DFMT_A8R8G8B8, D3DPOOL_MANAGED)
texNdle.LockRect 0, lrc, ByVal 0&, 0
memcpy ByVal lrc.pBits, out(0, 0), w * h * 4
texNdle.UnlockRect 0
End Sub
' // Функция генерирует текстуру коры
Private Sub CreateBarkTexture()
Dim vals(3) As Single
Dim x As Long
Dim x2 As Long
Dim y2 As Long
Dim ix As Long
Dim iy As Long
Dim y As Long
Dim w As Long
Dim h As Long
Dim v1 As Single
Dim v2 As Single
Dim t1 As Single
Dim t2 As Single
Dim i As Long
Dim div As Long
Dim perl() As Single
Dim nx As Long
Dim ny As Long
Dim out() As Long
ReDim out(255, 255)
w = UBound(out, 1) + 1: h = UBound(out, 2) + 1
ReDim perl(w - 1, h - 1)
i = 128
div = Log(i) / Log(2)
Do While i
For x = 0 To w - 1 Step w \ i: For y = 0 To h - 1 Step h \ i
x2 = x + w \ i: y2 = y + h \ i
If x2 > w Then x2 = w
If y2 > h Then y2 = h
vals(0) = Noise(x, y) / div: vals(1) = Noise(x2, y) / div
vals(2) = Noise(x, y2) / div: vals(3) = Noise(x2, y2) / div
For ix = x To x2 - 1
t1 = (ix - x) / (x2 - x)
v1 = vals(0) * (1 - t1) + vals(1) * t1
v2 = vals(2) * (1 - t1) + vals(3) * t1
For iy = y To y2 - 1
t2 = (iy - y) / (y2 - y)
perl(ix, iy) = perl(ix, iy) + v1 * (1 - t2) + v2 * t2
Next
Next
Next: Next
i = i \ 2
Loop
For x = 0 To w - 1: For y = 0 To h - 1
nx = perl(x, y) * 32
ny = perl(y, x) * 32
nx = Sqr(nx * nx + ny * ny) + x
v1 = Abs((nx Mod 16) / 8 - 1)
out(x, y) = RGB(v1 * 64, v1 * 130, v1 * 255)
Next: Next
Dim lrc As D3DLOCKED_RECT
Set texBark = dev.CreateTexture(w, h, 1, 0, D3DFMT_A8R8G8B8, D3DPOOL_MANAGED)
texBark.LockRect 0, lrc, ByVal 0&, 0
memcpy ByVal lrc.pBits, out(0, 0), w * h * 4
texBark.UnlockRect 0
End Sub
' // Функция шума
Private Function Noise(ByVal x As Long, ByVal y As Long) As Single
Dim x2 As Long, y2 As Long
x = x Mod 256: y = y Mod 256
x2 = (x + y) Mod 43: y2 = y Mod 32
x = ((x2 * x + 59) * 157) Mod 3469
y = ((y + y2 + x) + 139) Mod 2837
Noise = (x * y) / 7
Noise = Noise - Fix(Noise)
End Function
Private Sub Form_Unload(Cancel As Integer)
GdipDeletePen gdipPen
GdipDeleteBrush gdipBrush
GdipDeleteFont gdipFont
GdipDeleteStringFormat gdipFmt
GdiplusShutdown gdipToken
Set srfDpth = Nothing
Set srfBuff = Nothing
Set tmpSrf = Nothing
Set texBuff = Nothing
Set bufWood = Nothing
Set bufNdle = Nothing
Set bufBall = Nothing
Set bufStar = Nothing
Set texBark = Nothing
Set texNdle = Nothing
Set dev = Nothing
Set d3d = Nothing
Set dx = Nothing
End Sub
Private Sub tmrTimer_Timer()
Dim mtx As D3DMATRIX
rotAngY = rotAngY + 0.01
D3DXMatrixRotationY mtx, rotAngY
dev.SetTransform D3DTS_WORLD, mtx
Select Case sMode
Case 1
sVis = sVis + 16
If sVis >= &H80 Then
sVis = &H80
sMode = 2
End If
Case 2
sVis = sVis - 1
If sVis = 0 Then
sVis = &H7F
sMode = 3
End If
Case 3
sVis = sVis - 16
If sVis <= 0 Then
sVis = 0
sMode = 0
End If
End Select
Render
SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOACTIVATE
End Sub
</offtopic>
