3D елка на рабочий стол.

Работа с 2D и 3D графикой, видео, звуком.

Модератор: Mikle

The trick
Постоялец
Постоялец
 
Сообщения: 512
Зарегистрирован: 26.06.2010 (Сб) 23:08

3D елка на рабочий стол.

Сообщение The trick » 04.01.2015 (Вс) 16:51

Изображение
Я как-то уже делал такую, но в этот раз я добавил возможность регулировки параметров создания.
Для работы нужна 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

У вас нет доступа для просмотра вложений в этом сообщении.
Последний раз редактировалось The trick 10.02.2015 (Вт) 20:55, всего редактировалось 2 раз(а).
UA6527P

Mikle
Изобретатель велосипедов
Изобретатель велосипедов
Аватара пользователя
 
Сообщения: 3819
Зарегистрирован: 25.03.2003 (Вт) 14:02
Откуда: Туапсе

Re: 3D елка на рабочий стол.

Сообщение Mikle » 04.01.2015 (Вс) 19:50

Круто, чё. Она ещё и сгенерирована!

The trick
Постоялец
Постоялец
 
Сообщения: 512
Зарегистрирован: 26.06.2010 (Сб) 23:08

Re: 3D елка на рабочий стол.

Сообщение The trick » 04.01.2015 (Вс) 22:28

Добавил dx8vb и прописал ее в манифесте. Теперь регистрация не нужна, достаточно положить ее в папку с EXE. Перезалил туда же.
UA6527P

goldexer
Начинающий
Начинающий
 
Сообщения: 12
Зарегистрирован: 07.07.2013 (Вс) 17:11

Re: 3D елка на рабочий стол.

Сообщение goldexer » 07.01.2015 (Ср) 19:56

При запуске EXE-шника из папки, распакованной из архива, ничего не происходит. Только внизу кнопка на панели задач и больше ровным счетом ничего.
Открыл проект, запустил, елка появилась только в превью окна на панели задач, но на рабочем столе её нет ((

Изображение

Windows 7 x86

Jack Ferre
Продвинутый пользователь
Продвинутый пользователь
Аватара пользователя
 
Сообщения: 132
Зарегистрирован: 17.02.2014 (Пн) 14:31
Откуда: Казахстан, Костанай

Re: 3D елка на рабочий стол.

Сообщение Jack Ferre » 08.01.2015 (Чт) 13:06

2 goldexer
Начальные координаты ёлки 1072х526. Вангую что ваше разрешение экрана 1024x768 и ёлка просто не влезает.
Измените параметры Left и Top формы.

Jack Ferre
Продвинутый пользователь
Продвинутый пользователь
Аватара пользователя
 
Сообщения: 132
Зарегистрирован: 17.02.2014 (Пн) 14:31
Откуда: Казахстан, Костанай

Re: 3D елка на рабочий стол.

Сообщение Jack Ferre » 08.01.2015 (Чт) 13:19

ХР отказывается запускать с манифестом.

Не понимает ветку <trustInfo>

UPD:
Заменил прям в екзешнике на
Код: Выделить всё
    <!-- tInfo>
        <security>
            <requestedPrivileges>
                <requestedExecutionLevel
                    level="asInvoker"
                    uiAccess="false"
                />
            </requestedPrivileges>
        </security>
    </trustI -->

Заработало.
Последний раз редактировалось Jack Ferre 08.01.2015 (Чт) 13:30, всего редактировалось 1 раз.

The trick
Постоялец
Постоялец
 
Сообщения: 512
Зарегистрирован: 26.06.2010 (Сб) 23:08

Re: 3D елка на рабочий стол.

Сообщение The trick » 08.01.2015 (Чт) 13:29

Переделаю чуть позже.
UA6527P

Jack Ferre
Продвинутый пользователь
Продвинутый пользователь
Аватара пользователя
 
Сообщения: 132
Зарегистрирован: 17.02.2014 (Пн) 14:31
Откуда: Казахстан, Костанай

Re: 3D елка на рабочий стол.

Сообщение Jack Ferre » 08.01.2015 (Чт) 16:59

<offtopic>Блин, по работе отвлекли :? </offtopic>

За неимением под рукой ничего кроме блокнота заменил <trustInfo> на <trustInfo xmlns="urn:schemas-microsoft-com:asm.v2">, компенсировал количество символов комментарием <!-- UAC privileges -->
Работает.

BV
Thinker
Thinker
Аватара пользователя
 
Сообщения: 3977
Зарегистрирован: 12.09.2004 (Вс) 0:55
Откуда: Молдавия, г. Кишинёв

Re: 3D елка на рабочий стол.

Сообщение BV » 15.01.2015 (Чт) 15:03

Здорово. Но не хватает MSAA -> D3DMULTISAMPLE_8_SAMPLES
char *out = "|*0>78-,+<|"; size_t cc = char_traits<char>::length(out);
for (size_t i=0;i<cc;i++)??<cout<<static_cast<char>((out??(i??)??'89));??>cout<<endl;


Изображение


Вернуться в Мультимедиа

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1

    TopList