Option Explicit
' Многопоточность на примере фрактала Julia (Z^2+C)
' © Кривоус Анатолий Анатольевич (The trick), 2013
' Работает только в скомпилированном виде
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenFilename As OPENFILENAME) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Enum Sliders
YOffset
XOffset
Scaling
RealPart
ImaginaryPart
End Enum
Private Enum Colors
cBackground = 0
cBorders = &H303030
cSlider = &H202020
cSelect = &H30FFFF
End Enum
Private Type Slider
Orientation As Boolean ' True = Вертикально
Value As Double
Scl As Double ' Величина изменения
Pos As Double
End Type
Private Const SliderSize As Long = 10
Private Const STILL_ACTIVE = &H103&
Private Const INFINITE = &HFFFFFFFF
Private Const x_MaxBuffer = 32768
Private Const OFN_ENABLESIZING = &H800000
Private Const OFN_EXPLORER = &H80000
Dim Slider(4) As Slider, IsAction As Boolean, Active As Long
Dim hFont As Long
Dim EnableUpdate As Boolean
Dim hThread As Long
Dim C As Canvas
Private Sub Form_Load()
Dim i As Long
Slider(Sliders.YOffset).Orientation = True
Slider(Sliders.Scaling).Value = 1
For i = 0 To UBound(Slider)
Slider(i).Scl = 0.1
Active = i
DrawSlider i
Next
hFont = CreateFont((Me.FontSize * -20) / Screen.TwipsPerPixelY, 0, 2700, 0, Me.Font.Weight, 0, 0, 0, 204, 0, 0, 2, 0, Me.FontName)
i = SelectObject(Me.hdc, hFont)
Me.CurrentX = 530: Me.CurrentY = 150: Me.Print "Offset Y:"
SelectObject Me.hdc, i
Active = Sliders.Scaling: SliderEvent
Active = Sliders.YOffset: SliderEvent
EnableUpdate = True
For i = 0 To 99
modJulia.Palette(i) = RGB(i, i, i)
Next
End Sub
Private Sub Form_Unload(cancel As Integer)
ExitThread
DeleteObject hFont
End Sub
Private Function ShowOpen() As String
Dim N As Long
Dim FileStruct As OPENFILENAME
With FileStruct
.hWndOwner = Me.hwnd
.lpstrFile = String(x_MaxBuffer, 0)
.nMaxFile = x_MaxBuffer - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = x_MaxBuffer - 1
.Flags = OFN_ENABLESIZING Or OFN_EXPLORER
.lStructSize = Len(FileStruct)
.lpstrFilter = "All supported image" & vbNullChar & "*.bmp;*.jpg;*.jpeg"
If GetOpenFileName(FileStruct) Then
N = InStr(1, .lpstrFile, vbNullChar)
ShowOpen = Left$(.lpstrFile, N - 1)
End If
End With
End Function
Private Sub ExitThread()
Dim Ret As Long
If modJulia.Process Then
modJulia.Process = False
GetExitCodeThread hThread, Ret
If Ret = STILL_ACTIVE Then
WaitForSingleObject hThread, INFINITE
End If
End If
End Sub
Private Sub Update()
Dim TID As Long
ExitThread
modJulia.iLeft = Slider(Sliders.XOffset).Value - 1 / Slider(Sliders.Scaling).Value
modJulia.iRight = Slider(Sliders.XOffset).Value + 1 / Slider(Sliders.Scaling).Value
modJulia.iTop = -Slider(Sliders.YOffset).Value - 1 / Slider(Sliders.Scaling).Value
modJulia.iBottom = -Slider(Sliders.YOffset).Value + 1 / Slider(Sliders.Scaling).Value
modJulia.Real = Slider(Sliders.RealPart).Value
modJulia.Imaginary = Slider(Sliders.ImaginaryPart).Value
C.hdc = picDisp.hdc
C.Width = picDisp.ScaleWidth
C.Height = picDisp.ScaleHeight
If EnableUpdate Then
hThread = CreateThread(ByVal 0, 0, AddressOf DrawJulia, C, 0, TID)
End If
End Sub
Private Sub DrawSlider(ByVal Index As Sliders)
Dim p As Long
picSlider(Index).FillColor = Colors.cBackground
picSlider(Index).Line (0, 0)-Step(picSlider(Index).ScaleWidth - 1, picSlider(Index).ScaleHeight - 1), Colors.cBorders, B
If Slider(Index).Orientation Then
p = Slider(Index).Pos * (picSlider(Index).ScaleHeight - SliderSize) \ 2 + picSlider(Index).ScaleHeight \ 2 - SliderSize \ 2
picSlider(Index).FillColor = Colors.cSlider
picSlider(Index).Line (3, p)-Step(picSlider(Index).ScaleWidth - 7, SliderSize), Colors.cBorders, B
Else
p = Slider(Index).Pos * (picSlider(Index).ScaleWidth - SliderSize) \ 2 + picSlider(Index).ScaleWidth \ 2 - SliderSize \ 2
picSlider(Index).FillColor = Colors.cSlider
picSlider(Index).Line (p, 3)-Step(SliderSize, picSlider(Index).ScaleHeight - 7), Colors.cBorders, B
End If
End Sub
Private Sub lbLoadPalette_DblClick()
Dim File As String, Img As StdPicture, DC As Long, obmp As Long, W As Long, X As Long, D As Single, i As Long, p As Long
lbLoadPalette.ForeColor = cSelect
File = ShowOpen()
lbLoadPalette.ForeColor = Me.ForeColor
If Len(File) Then
On Error GoTo ErrorLoading
Set Img = LoadPicture(File)
On Error GoTo 0
W = ScaleX(Img.Width, vbHimetric, vbPixels)
DC = CreateCompatibleDC(Me.hdc)
obmp = SelectObject(DC, Img.Handle)
D = W / 100
For i = 0 To 100
X = i * D
p = GetPixel(DC, X, 0)
modJulia.Palette(i) = ((p \ &H10000) And &HFF&) Or (p And &HFF00&) Or ((p And &HFF) * &H10000)
Next
SelectObject DC, obmp
DeleteDC DC
Set Img = Nothing
Update
End If
Exit Sub
ErrorLoading:
MsgBox "Error loading image"
End Sub
Private Sub picDisp_Paint()
Update
End Sub
Private Sub picSlider_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
Dim p As Double
IsAction = True
tmrSlider.Enabled = True
Active = Index
If Slider(Index).Orientation Then
Slider(Index).Pos = y / (picSlider(Index).ScaleHeight - SliderSize) * 2 - 1
Else
Slider(Index).Pos = X / (picSlider(Index).ScaleWidth - SliderSize) * 2 - 1
End If
If Abs(Slider(Index).Pos) > 1 Then Slider(Index).Pos = Sgn(Slider(Index).Pos)
Slider(Index).Value = Slider(Index).Value + Slider(Index).Pos * Slider(Index).Scl
SliderEvent
DrawSlider Index
End Sub
Private Sub picSlider_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
If Not IsAction Then Exit Sub
If Slider(Index).Orientation Then
Slider(Index).Pos = y / (picSlider(Index).ScaleHeight - SliderSize) * 2 - 1
Else
Slider(Index).Pos = X / (picSlider(Index).ScaleWidth - SliderSize) * 2 - 1
End If
If Abs(Slider(Index).Pos) > 1 Then Slider(Index).Pos = Sgn(Slider(Index).Pos)
Slider(Index).Value = Slider(Index).Value + Slider(Index).Pos * Slider(Index).Scl
SliderEvent
DrawSlider Index
End Sub
Private Sub picSlider_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, y As Single)
If IsAction Then
IsAction = False
tmrSlider.Enabled = False
Slider(Index).Pos = 0
DrawSlider Index
SliderEvent
End If
End Sub
Private Sub SliderEvent()
Dim i As Long
Select Case Active
Case Sliders.YOffset
i = SelectObject(Me.hdc, hFont)
Me.Line (530, 350)-Step(-40, 120), Me.BackColor, BF
Me.CurrentX = 530: Me.CurrentY = 350: Me.Print Format(Slider(Active).Value, "#0.00000")
SelectObject Me.hdc, i
Case Sliders.Scaling
If Slider(Scaling).Value <= 0 Then Slider(Scaling).Value = 0.00000000000001
For i = 0 To UBound(Slider)
Select Case i
Case Sliders.XOffset, Sliders.YOffset
Slider(i).Scl = 1 / Slider(Scaling).Value * 0.1
Case Sliders.RealPart, Sliders.ImaginaryPart
Slider(i).Scl = 1 / Slider(Scaling).Value * 0.02
End Select
Next
lblValue(Active).Caption = Format(Slider(Active).Value, "#0.00000")
Case Sliders.XOffset To Sliders.ImaginaryPart
lblValue(Active).Caption = Format(Slider(Active).Value, "#0.00000")
End Select
Update
End Sub
Private Sub tmrSlider_Timer()
Slider(Active).Value = Slider(Active).Value + Slider(Active).Pos * Slider(Active).Scl
SliderEvent
End SubOption Explicit
' Генерация фрактала Julia (отдельный поток)
' © Кривоус Анатолий Анатольевич (The trick), 2013
Public Type Canvas
hdc As Long
Width As Long
Height As Long
End Type
Public Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Public 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
Public Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Public Palette(99) As Long
Public Process As Boolean
Public iLeft As Double, iTop As Double, iRight As Double, iBottom As Double, Real As Double, Imaginary As Double
Public Function DrawJulia(C As Canvas) As Long
Dim X As Double, y As Double, Sx As Double, Sy As Double
Dim pt As Long, Bits() As Long, bi As BITMAPINFO
Dim lx As Long, ly As Long
Process = True
ReDim Bits(C.Width * C.Height - 1)
With bi.bmiHeader
.biBitCount = 32
.biHeight = -C.Height
.biWidth = C.Width
.biPlanes = 1
.biSize = Len(bi.bmiHeader)
.biSizeImage = C.Width * C.Height * 4
End With
Sx = (iRight - iLeft) / (C.Width - 1)
Sy = (iRight - iLeft) / (C.Height - 1)
X = iLeft: y = iTop
Process = Not Not Process
For ly = 0 To C.Height - 1: For lx = 0 To C.Width - 1
X = X + Sx
Bits(pt) = Palette(Julia(X, y))
pt = pt + 1
If Not Process Then GoTo cancel
Next: y = y + Sy: X = iLeft: Next
cancel:
SetDIBitsToDevice C.hdc, 0, 0, C.Width, ly, 0, 0, 0, ly, VarPtr(Bits(0)), VarPtr(bi), 0
Process = False
End Function
Private Function Julia(X As Double, y As Double) As Single
Dim Zr As Double, Zi As Double
Dim Cr As Double, Ci As Double
Dim tZr As Double
Dim Count As Long
Dim r As Single
Count = 0
Zr = X: Zi = y
Cr = Real: Ci = Imaginary
Do While Count < 99 And r < 10
tZr = Zr
Zr = Zr * Zr - Zi * Zi
Zi = tZr * Zi + Zi * tZr
Zr = Zr + Cr
Zi = Zi + Ci
r = Sqr(Zr * Zr + Zi * Zi)
Count = Count + 1
Loop
Julia = Count
End Function
Option Explicit
' Гиперкуб (тессеракт), просмотр проекции 4-хмерного гиперкуба на 2-х мерное пространство экрана.
' Автор: Кривоус Анатолий Анатольевич (The trick) 2013
' Возможность вращения по 6-ти осям (в 6-ти плоскостях), 3-х обычных трехмерных и 3-комбинированных (XT,YT,ZT) (T-ось четвертого измерения)
' Регулировка дистанции по оси Z (по оси T фиксированно 2), угла обзора для 3D
' Гиперкуб имеет размеры (0.5,0.5,0.5,0.5), центр в точке (0,0,0,2)
' Для проекции 4D->3D, имеется возможность переключать тип проекции с параллельной в перспективную
' Темные и малые вершины, находяться "глубже" по оси T, чем светлые
' Кнопками Z-зануляется скорость вращения по оси, кнопкам R сбрасывается поворот на 0 грудусов.
Private Type Vector4D ' Четырехмерный вектор
X As Single
Y As Single
Z As Single
t As Single
w As Single
End Type
Private Type Quad
P(3) As Vector4D ' Квадрат
End Type
Private Type Cube
P(3) As Quad ' Куб
End Type
Private Const PI2 = 6.28318530717959 ' 2 * PI
Dim XY As Single, ZX As Single, ZY As Single, _
ZT As Single, XT As Single, YT As Single ' Углы поворота
Dim Tesseract(3) As Cube ' 4 куба граней тессеракта
Private Function Vec4(ByVal X As Single, ByVal Y As Single, ByVal Z As Single, ByVal t As Single) As Vector4D ' Создание вектора
Vec4.X = X: Vec4.Y = Y: Vec4.Z = Z: Vec4.t = t: Vec4.w = 1
End Function
Private Function Vec4Add(Vec1 As Vector4D, Vec2 As Vector4D) As Vector4D ' Сложение векторов
With Vec4Add
.X = Vec1.X + Vec2.X: .Y = Vec1.Y + Vec2.Y: .Z = Vec1.Z + Vec2.Z: .t = Vec1.t + Vec2.t: .w = 1
End With
End Function
Private Function Vec4Sub(Vec1 As Vector4D, Vec2 As Vector4D) As Vector4D ' Разность векторов
With Vec4Sub
.X = Vec1.X - Vec2.X: .Y = Vec1.Y - Vec2.Y: .Z = Vec1.Z - Vec2.Z: .t = Vec1.t - Vec2.t: .w = 1
End With
End Function
Private Sub Translation4D(ByVal X As Single, ByVal Y As Single, ByVal Z As Single, ByVal t As Single, Out() As Single) ' Перенос
Identity4d Out(): Out(4, 0) = X: Out(4, 1) = Y: Out(4, 2) = Z: Out(4, 3) = t
End Sub
Private Sub Rotation4DXY(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости XY
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(0, 0) = C: Out(1, 0) = S: Out(0, 1) = -S: Out(1, 1) = C
End Sub
Private Sub Rotation4DZY(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости ZY
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(1, 1) = C: Out(2, 1) = S: Out(1, 2) = -S: Out(2, 2) = C
End Sub
Private Sub Rotation4DZX(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости ZX
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(0, 0) = C: Out(0, 2) = S: Out(2, 0) = -S: Out(2, 2) = C
End Sub
Private Sub Rotation4DXT(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости XT
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(0, 0) = C: Out(0, 3) = S: Out(3, 0) = -S: Out(3, 3) = C
End Sub
Private Sub Rotation4DYT(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости YT
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(1, 1) = C: Out(3, 1) = -S: Out(1, 3) = S: Out(3, 3) = C
End Sub
Private Sub Rotation4DZT(ByVal Angle As Double, Out() As Single) ' Вращение в плоскости ZT
Dim C As Single, S As Single
C = Cos(Angle): S = Sin(Angle): Identity4d Out()
Out(2, 2) = C: Out(3, 2) = -S: Out(3, 3) = S: Out(3, 3) = C
End Sub
Private Sub Projection(FOV As Single, w As Single, h As Single, F As Single, N As Single, Out() As Single) ' Матрица проекции
Dim h_ As Single, w_ As Single, a_ As Single, b_ As Single
ReDim Out(4, 4)
h_ = 1 / Tan(FOV / 2): w_ = h_ / (w / h)
a_ = F / (F - N)
b_ = -N * F / (F - N)
Out(0, 0) = h_: Out(1, 1) = w_: Out(2, 2) = a_: Out(2, 3) = b_: Out(3, 2) = 1
End Sub
Private Sub Identity4d(Out() As Single) ' Единичная матрица 5х5
Dim i As Long
ReDim Out(4, 4): For i = 0 To 4: Out(i, i) = 1: Next
End Sub
Private Sub MultiplyTransform(Out() As Single, Op1() As Single, Op2() As Single) ' Умножение 2-х матриц
Dim Tmp() As Single, i As Long, j As Long, k As Long
If UBound(Op1, 1) <> UBound(Op2, 2) Then Exit Sub ' Умножение может быть только если число столбцов первого
ReDim Tmp(UBound(Op2, 1), UBound(Op1, 2)) ' равно числу строк второго
For j = 0 To UBound(Op1, 2): For i = 0 To UBound(Op2, 1)
For k = 0 To UBound(Op1, 1)
Tmp(i, j) = Tmp(i, j) + Op1(k, j) * Op2(i, k)
Next
Next: Next
Out = Tmp
End Sub
Private Function TransformVec4D(V As Vector4D, Transform() As Single) As Vector4D ' Трансформация вектора
With TransformVec4D
.X = V.X * Transform(0, 0) + V.Y * Transform(1, 0) + V.Z * Transform(2, 0) + V.t * Transform(3, 0) + V.w * Transform(4, 0)
.Y = V.X * Transform(0, 1) + V.Y * Transform(1, 1) + V.Z * Transform(2, 1) + V.t * Transform(3, 1) + V.w * Transform(4, 1)
.Z = V.X * Transform(0, 2) + V.Y * Transform(1, 2) + V.Z * Transform(2, 2) + V.t * Transform(3, 2) + V.w * Transform(4, 2)
.t = V.X * Transform(0, 3) + V.Y * Transform(1, 3) + V.Z * Transform(2, 3) + V.t * Transform(3, 3) + V.w * Transform(4, 3)
.w = V.X * Transform(0, 4) + V.Y * Transform(1, 4) + V.Z * Transform(2, 4) + V.t * Transform(3, 4) + V.w * Transform(4, 4)
End With
End Function
' Создание куба по 3-м граням верняя левая в глубину точка Pos, Dir - направления от этой точки
Private Function CreateCube(Pos As Vector4D, Dir1 As Vector4D, Dir2 As Vector4D, Dir3 As Vector4D) As Cube
With CreateCube
.P(0) = CreateQuad(Pos, Vec4Add(Pos, Dir1), Vec4Add(Pos, Dir2))
.P(1) = CreateQuad(.P(0).P(1), Vec4Add(.P(0).P(1), Dir3), .P(0).P(2))
.P(2) = CreateQuad(.P(1).P(1), Vec4Sub(.P(1).P(1), Dir1), .P(1).P(2))
.P(3) = CreateQuad(.P(2).P(1), Pos, Vec4Add(.P(2).P(1), Dir2))
End With
End Function
' Создание квадрата по трем точкам
Private Function CreateQuad(Pos1 As Vector4D, Pos2 As Vector4D, Pos3 As Vector4D) As Quad
CreateQuad.P(0) = Pos1
CreateQuad.P(1) = Pos2
CreateQuad.P(3) = Pos3
CreateQuad.P(2) = Vec4(Pos2.X + Pos3.X - Pos1.X, Pos2.Y + Pos3.Y - Pos1.Y, _
Pos2.Z + Pos3.Z - Pos1.Z, Pos2.t + Pos3.t - Pos1.t)
End Function
Private Sub cmdReset_Click(Index As Integer) ' Сброс трансформаций
Select Case Index
Case 0: XY = 0
Case 1: ZX = 0
Case 2: ZY = 0
Case 3: ZT = 0
Case 4: XT = 0
Case 5: YT = 0
End Select
End Sub
Private Sub cmdResetAll_Click() ' Сброс всех трансформаций
XY = 0: ZX = 0: ZY = 0: ZT = 0: XT = 0: YT = 0
End Sub
Private Sub cmdZero_Click(Index As Integer) ' Обнулить скорость
sldRotateSpd(Index).Value = 0
End Sub
Private Sub Form_Load()
' Создаем тессеракт
Tesseract(0) = CreateCube(Vec4(-0.5, 0.5, 0.5, -0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, -1, 0, 0))
Tesseract(1) = CreateCube(Vec4(-0.5, 0.5, 0.5, 0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, -1, 0, 0))
Tesseract(2) = CreateCube(Vec4(-0.5, 0.5, 0.5, -0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, 0, 0, 1))
Tesseract(3) = CreateCube(Vec4(-0.5, -0.5, 0.5, 0.5), Vec4(1, 0, 0, 0), Vec4(0, 0, -1, 0), Vec4(0, 0, 0, -1))
End Sub
Private Sub sldRotateSpd_Scroll(Index As Integer) ' Регулятор скорости
sldRotateSpd(Index).ToolTipText = sldRotateSpd(Index).Value
End Sub
Private Sub tmrRefresh_Timer()
Dim Wrld() As Single, Tmp() As Single ' Матрицы преобразований
Dim C As Long, Q As Long, V As Long ' Кубы, квадраты, векторы
Dim Out4D As Vector4D ' Результирующий вектор
Dim X As Single, Y As Single, _
Sx As Single, Sy As Single, t As Single
XY = XY + sldRotateSpd(0).Value / 1000 ' Прибавляем приращение к каждому углу
ZX = ZX + sldRotateSpd(1).Value / 1000 ' ///
ZY = ZY + sldRotateSpd(2).Value / 1000 ' ///
ZT = ZT + sldRotateSpd(3).Value / 1000 ' ///
XT = XT + sldRotateSpd(4).Value / 1000 ' ///
YT = YT + sldRotateSpd(5).Value / 1000 ' ///
Translation4D 0, 0, sldDist.Value / 100, 2, Wrld() ' Сдвигаем от камеры на величину Distance
Rotation4DXY XY, Tmp() ' Вычисляем матрицу поворота
MultiplyTransform Wrld, Wrld, Tmp ' Комбинируем трансформации
Rotation4DZX ZX, Tmp()
MultiplyTransform Wrld, Wrld, Tmp
Rotation4DZY ZY, Tmp()
MultiplyTransform Wrld, Wrld, Tmp
Rotation4DZT ZT, Tmp()
MultiplyTransform Wrld, Wrld, Tmp
Rotation4DXT XT, Tmp()
MultiplyTransform Wrld, Wrld, Tmp
Rotation4DYT YT, Tmp()
MultiplyTransform Wrld, Wrld, Tmp
If Abs(XY) > PI2 Then XY = XY - Sgn(XY) * PI2 ' Ограничиваем промежутком 0..2Pi
If Abs(ZX) > PI2 Then ZX = ZX - Sgn(ZX) * PI2
If Abs(ZY) > PI2 Then ZY = ZY - Sgn(ZY) * PI2
If Abs(ZT) > PI2 Then ZT = ZT - Sgn(ZT) * PI2
If Abs(XT) > PI2 Then XT = XT - Sgn(XT) * PI2
If Abs(YT) > PI2 Then YT = YT - Sgn(YT) * PI2
Projection sldFOV.Value / 100, 1, 1, 0.1, 3.5, Tmp() ' Вычисляем матрицу проекции 3D -> 2D
picDisp.Cls
For C = 0 To UBound(Tesseract): For Q = 0 To 3: For V = 0 To 3 ' Проход по всем вершинам
Out4D = TransformVec4D(Tesseract(C).P(Q).P(V), Wrld()) ' Трансформируем в мировые координаты
t = Out4D.t ' Для цвета сохраняем
If optProjection(0).Value Then ' Перспективная проекция 4D -> 3D
Out4D = Vec4(Out4D.X / (Out4D.t * 15), Out4D.Y / (Out4D.t * 15), Out4D.Z, 1)
Else ' Параллельная проекция 4D -> 3D
Out4D = Vec4(Out4D.X / 37.5, Out4D.Y / 37.5, Out4D.Z, 1)
End If
Out4D = TransformVec4D(Out4D, Tmp()) ' Проецируем на плоскость
If Out4D.Z > 0 And Out4D.Z < 1 Then ' Если глубина в пределах 0.1-3.5 то отрисовываем
X = picDisp.ScaleWidth * (1 + Out4D.X / Out4D.t) / 2 ' Перевод в координаты PictureBox'а
Y = picDisp.ScaleHeight * (1 - Out4D.Y / Out4D.t) / 2
If V Then ' Если не первая точка квадрата то рисуем линиию и круг
picDisp.Line -(X, Y)
picDisp.FillColor = RGB(64 + (3 - t) * 192, 0, 0) ' Цвет в зависимости от глубины по координате T
picDisp.Circle (X, Y), (4 - t) * 3
Else ' Иначе переносим текущие координаты, для начала отрисовки
picDisp.CurrentX = X: Sx = X
picDisp.CurrentY = Y: Sy = Y
End If
End If
Next
picDisp.Line -(Sx, Sy) ' Замыкаем квадрат
Next: Next
lblInfo.Caption = "XY: " & Format$(XY / PI2 * 360, "##0.0°") & vbNewLine & _
"ZX: " & Format$(ZX / PI2 * 360, "##0.0°") & vbNewLine & _
"ZY: " & Format$(ZY / PI2 * 360, "##0.0°") & vbNewLine & _
"ZT: " & Format$(ZT / PI2 * 360, "##0.0°") & vbNewLine & _
"XT: " & Format$(XT / PI2 * 360, "##0.0°") & vbNewLine & _
"YT: " & Format$(YT / PI2 * 360, "##0.0°")
End SubPrivate Function PutString( _
ByRef StringData As String, _
ByVal Connection As ADODB.Connection, _
ByVal TableName As String, _
ByVal ColumnIds As Variant, _
Optional ByVal ColumnDelimiter As String = vbTab, _
Optional ByVal RowDelimiter As String = vbCr, _
Optional ByVal NullExpr As Variant = vbNullString) As Long
'A sort of "inverse analog" of the ADO Recordset's GetString() method.
'
'Returns count of rows added.
Dim SaveCursorLocation As CursorLocationEnum
Dim RS As ADODB.Recordset
Dim ColumnStart As Long
Dim ColumnLength As Long
Dim ColumnValues() As Variant
Dim Pos As Long
Dim NewPos As Long
Dim RowLimit As Long
Dim I As Long
Dim AtRowEnd As Boolean
If (VarType(ColumnIds) And vbArray) = 0 Then Err.Raise 5 'Invalid procedure call or argument.
SaveCursorLocation = Connection.CursorLocation
Connection.CursorLocation = adUseServer 'Required to create this fast-append Recordset:
With New ADODB.Command
Set .ActiveConnection = Connection
.CommandType = adCmdTable
.CommandText = TableName
.Properties![Append-Only Rowset] = True
.Properties![Own Changes Visible] = False 'Doesn't matter when using exclusive access.
.Properties![Others' Changes Visible] = False 'Doesn't matter when using exclusive access.
Set RS = .Execute()
End With
Connection.CursorLocation = SaveCursorLocation
ReDim ColumnValues(UBound(ColumnIds))
Pos = 1
Do
RowLimit = InStr(Pos, StringData, RowDelimiter)
If RowLimit = 0 Then RowLimit = Len(StringData) + 1
I = 0
AtRowEnd = False
Do
ColumnStart = Pos
NewPos = InStr(Pos, StringData, ColumnDelimiter)
If NewPos = 0 Or NewPos > RowLimit Then
Pos = InStr(Pos, StringData, RowDelimiter)
ColumnLength = RowLimit - ColumnStart
If Pos <> 0 Then
Pos = Pos + Len(RowDelimiter)
'Auto-handle CrLf when RowDelimiter is vbCr. GetString()
'itself defaults to vbCr as the RowDelimiter. Some software
'strangely enough will use a mix of vbCr and vbCrLf:
If RowDelimiter = vbCr Then
If Mid$(StringData, Pos, 1) = vbLf Then Pos = Pos + 1
End If
End If
AtRowEnd = True
Else
Pos = NewPos
ColumnLength = Pos - ColumnStart
Pos = Pos + Len(ColumnDelimiter)
End If
ColumnValues(I) = Trim$(Mid$(StringData, ColumnStart, ColumnLength))
If Not IsMissing(NullExpr) Then
If ColumnValues(I) = NullExpr Then ColumnValues(I) = Null
End If
I = I + 1
Loop Until AtRowEnd
RS.AddNew ColumnIds, ColumnValues
PutString = PutString + 1
Loop Until Pos = 0 Or Pos > Len(StringData)
End Function
[BITS 32]
QueryInterface:
mov eax,[esp+4] ; ObjPtr
inc dword [eax+4] ; Counter++
mov ecx, [esp+0xc]
mov [ecx],eax ; ppvObject = ObjPtr
xor eax,eax ; Success
ret 0xc
AddRef:
mov eax,[esp+4] ; ObjPtr
inc dword [eax+4] ; Counter++
mov eax, [eax+4] ; Counter return
ret 0x4
Release:
mov eax,[esp+4] ; ObjPtr
dec dword [eax+4] ; Counter--
jz RemoveObject ; if (Counter == 0)
mov eax, [eax+4] ; Counter return
ret 0x4
RemoveObject:
push eax ; lpMem
push 0x00000001 ; HEAP_NO_SERIALIZE
call 0x12345678 ; GetProcessHeap
push eax ; hHeap
call 0x12345678 ; HeapFree
xor eax,eax ; Counter = 0
ret 0x4
IEnumVariant_Next:
push ebx
push edi
push esi
mov esi, [esp+0x10] ; ObjPtr
mov ebx, [esp+0x14] ; ebx = celt
mov edi, [esp+0x18] ; rgVar
NextItem:
movsx eax, word [esi+0x8] ; Pointer.Hash
inc eax
jz ExitCycle ; if (Pointer.Hash == -1)
dec eax
mov ecx, [esi+0xc] ; DataPtr
mov ecx, [ecx+eax*8+4] ; ecx = tItem.tElement
movzx eax, word [esi+0xA] ; Pointer.Index
imul ax, ax, 0x28 ;
movzx eax, ax ; eax = Pointer.Index * sizeof(tElement)
mov ecx, [ecx+0xc] ; ecx = *tElement(0)
lea ecx, [ecx+eax] ; *tElement(Pointer.Index)
mov eax, [ecx+0x20]
add ecx, [esi+0x14] ; ecx += OffsetVarinat
mov [esi+0x8], eax ; Pointer = tElement(Pointer.Index).Next
push ecx ; pvargSrc
push edi ; pvargDest == rgVar
call 0x12345678 ; VariantCopy
add edi, 0x10
dec ebx
jne NextItem
ExitCycle:
test ebx, ebx
setne dl ; if (ebx = 0) dl = 0 else dl = 1
movzx esi, dl ; edx = dl
mov edi, [esp+0x1c] ; pCeltFetched
test edi, edi
je ExitFunction
mov eax, [esp+0x14] ; eax = celt
sub eax, ebx
mov [edi], eax ; pCeltFetched = count
ExitFunction:
mov eax, esi
pop esi
pop edi
pop ebx
ret 0x10
IEnumVariant_Skip:
mov edx, [esp+0x04] ; ObjPtr
mov eax, [edx+0x8] ; Pointer.Hash
mov edx, [edx+0xc] ; DataPtr
NextItem_2:
inc ax
jz ExitCycle_2 ; if (Pointer.Hash == -1)
dec ax
movzx ecx, ax ; ecx = Pointer.Hash
mov ecx, [edx+ecx*8+4] ; ecx = tItem.tElement
shr eax, 0x10 ; eax = Pointer.Index
imul ax, ax, 0x28 ;
mov ecx, [ecx+0xc] ; ecx = *tElement(0)
mov eax, [ecx+eax+0x20] ; eax = tElement(Pointer.Index).Next
dec dword [esp+0x08] ; celt--
jne NextItem_2
xor edx, edx
ExitCycle_2:
test edx, edx
setne dl ; if (edx = 0) dl = 0 else dl = 1
mov eax, edx
ret 0x08
IEnumVariant_Reset:
mov eax, [esp+0x04] ; ObjPtr
mov edx, [eax+0x10] ; First
mov [eax+0x08], edx ; Pointer = First
xor eax, eax
ret 0x4' Класс MultithreadDownloader - класс загрузчика
' © Кривоус Анатолий Анатольевич (The trick), 2014
Option Explicit
Public Enum ErrorCodes
OK
NOT_INITIALIZE
ERROR_CREATING_DST_FILE
End Enum
Private Declare Function InternetCloseHandle Lib "wininet" (ByRef hInternet As Long) As Boolean
Private Declare Function InternetOpen Lib "wininet" Alias "InternetOpenW" (ByVal lpszAgent As Long, ByVal dwAccessType As Long, ByVal lpszProxy As Long, ByVal lpszProxyBypass As Long, ByVal dwFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlW" (ByVal hInternet As Long, ByVal lpszUrl As Long, ByVal lpszHeaders As Long, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByRef dwContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, lpBuffer As Any, ByVal dwNumberOfBytesToRead As Long, ByRef lpdwNumberOfBytesRead As Long) As Integer
Private Declare Function HttpQueryInfo Lib "wininet" Alias "HttpQueryInfoW" (ByVal hRequest As Long, ByVal dwInfoLevel As Long, lpBuffer As Any, ByRef lpdwBufferLength As Long, ByRef lpdwIndex As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Const HTTP_QUERY_CONTENT_LENGTH As Long = 5
Private Const HTTP_QUERY_FLAG_NUMBER As Long = &H20000000
Private Const CREATE_ALWAYS As Long = 2
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const GENERIC_WRITE As Long = &H40000000
Public Event Complete()
Public Event Error(ByVal Code As Long)
Public Event Progress(ByVal Size As Currency, ByVal TotalSize As Currency, cancel As Boolean)
Private mBufferSize As Long
Private mError As ErrorCodes
Dim hInternet As Long
Public Property Get ErrorCode() As ErrorCodes
ErrorCode = mError
End Property
Public Property Get BufferSize() As Long
BufferSize = mBufferSize
End Property
Public Property Let BufferSize(ByVal Value As Long)
If Value > &H1000000 Or Value < &H400 Then Err.Raise vbObjectError, "MultithreadDownloader", "Wrong buffer size": Exit Property
mBufferSize = Value
End Property
Public Sub Download(URL As String, Filename As String)
Dim hFile As Long
Dim hDst As Long
Dim fSize As Currency
Dim total As Long
Dim prgSize As Currency
Dim cancel As Boolean
Dim buf() As Byte
If hInternet = 0 Then mError = NOT_INITIALIZE: RaiseEvent Error(mError): Exit Sub
hFile = InternetOpenUrl(hInternet, StrPtr(URL), 0, 0, INTERNET_FLAG_RELOAD, 0)
If hFile = 0 Then mError = Err.LastDllError: RaiseEvent Error(mError): Exit Sub
If HttpQueryInfo(hFile, HTTP_QUERY_CONTENT_LENGTH Or HTTP_QUERY_FLAG_NUMBER, fSize, 8, 0) Then
hDst = CreateFile(StrPtr(Filename), GENERIC_WRITE, 0, ByVal 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
If hDst = INVALID_HANDLE_VALUE Then mError = ERROR_CREATING_DST_FILE: RaiseEvent Error(mError): Exit Sub
ReDim buf(mBufferSize - 1)
Do
If InternetReadFile(hFile, buf(0), mBufferSize, total) = 0 Then
mError = Err.LastDllError
RaiseEvent Error(mError)
InternetCloseHandle hFile
Exit Sub
End If
WriteFile hDst, buf(0), total, 0, ByVal 0&
prgSize = prgSize + CCur(total) / 10000@
RaiseEvent Progress(prgSize, fSize, cancel)
Loop While (total = mBufferSize) And Not cancel
CloseHandle hDst
RaiseEvent Complete
Else
mError = Err.LastDllError
RaiseEvent Error(mError)
End If
InternetCloseHandle hFile
mError = OK
End Sub
Private Sub Class_Initialize()
' Инициализация WinInet
hInternet = InternetOpen(StrPtr(App.ProductName), INTERNET_OPEN_TYPE_PRECONFIG, 0, 0, 0)
mBufferSize = &H10000
End Sub
Private Sub Class_Terminate()
' Деинициализация
If hInternet Then InternetCloseHandle hInternet
End Sub' modEffects.bas - функции для обработки изображений
' © Кривоус Анатолий Анатольевич (The trick), 2014
Option Explicit
' Передаем эту структуру в поток
Private Type ThreadData
pix() As Byte ' Двухмерный массив пикселей рисунка (w-1,h-1)
value As Single ' Значение эффекта
percent As Single ' Процент выполнения 0..1
End Type
' // Функция изменения яркости
Public Function Brightness(dat As ThreadData) As Long
Dim col() As Byte
Dim x As Long
Dim y As Long
Dim tmp As Long
Dim value As Single
On Error GoTo ERRORLABEL
value = dat.value
If value < -1 Then value = -1
If value > 1 Then value = 1
ReDim col(255)
For x = 0 To 255
tmp = x + value * 255
If tmp > 255 Then tmp = 255 Else If tmp < 0 Then tmp = 0
col(x) = tmp
Next
For y = 0 To UBound(dat.pix, 2)
For x = 0 To UBound(dat.pix, 1)
dat.pix(x, y) = col(dat.pix(x, y))
Next
dat.percent = y / UBound(dat.pix, 2)
Next
dat.percent = 1
Brightness = 1
ERRORLABEL:
End Function
' // Функция изменения контрастности
Public Function Contrast(dat As ThreadData) As Long
Dim col() As Byte
Dim x As Long
Dim y As Long
Dim tmp As Long
Dim value As Single
On Error GoTo ERRORLABEL
value = dat.value
If value < 0 Then value = 0
If value > 100 Then value = 100
ReDim col(255)
For x = 0 To 255
tmp = 128 + (value ^ 3) * (x - 128)
If tmp > 255 Then tmp = 255 Else If tmp < 0 Then tmp = 0
col(x) = tmp
Next
For y = 0 To UBound(dat.pix, 2)
For x = 0 To UBound(dat.pix, 1)
dat.pix(x, y) = col(dat.pix(x, y))
Next
dat.percent = y / UBound(dat.pix, 2)
Next
dat.percent = 1
Contrast = 1
ERRORLABEL:
End Function
' // Функция изменения насыщенности
Public Function Saturation(dat As ThreadData) As Long
Dim x As Long
Dim y As Long
Dim w As Long
Dim h As Long
Dim tmp As Long
Dim r As Long
Dim g As Long
Dim b As Long
Dim br As Long
Dim value As Single
On Error GoTo ERRORLABEL
value = dat.value
If value > 1 Then value = 1
If value < 0 Then value = 0
w = UBound(dat.pix, 1) \ 4
h = UBound(dat.pix, 2)
For y = 0 To h
For x = 0 To w
b = dat.pix(x * 4, y)
g = dat.pix(x * 4 + 1, y)
r = dat.pix(x * 4 + 2, y)
br = 0.3 * r + 0.59 * g + 0.11 * b
r = r * value + br * (1 - value)
g = g * value + br * (1 - value)
b = b * value + br * (1 - value)
dat.pix(x * 4, y) = b
dat.pix(x * 4 + 1, y) = g
dat.pix(x * 4 + 2, y) = r
Next
dat.percent = y / h
Next
dat.percent = 1
Saturation = 1
ERRORLABEL:
End Function
' // Функция размытия по Гауссу
Public Function GaussianBlur(dat As ThreadData) As Long
Dim kernel() As Single
Dim size As Long
Dim half As Long
Dim weight As Long
Dim gx As Single
Dim tmp() As Byte
Dim x As Long
Dim y As Long
Dim w As Long
Dim h As Long
Dim index As Long
Dim acc As Long
Dim wFrom As Long
Dim wTo As Long
Dim norm() As Single
Dim lnorm As Single
Dim px As Long
Dim value As Single
On Error GoTo ERRORLABEL
value = dat.value
If value < 0 Then value = 0
If value > 255 Then value = 255
size = CLng(value) * 2
half = -Int(-size / 2)
ReDim kernel(size)
kernel(half) = 1
ReDim norm(half)
lnorm = 1
For weight = 1 To half
gx = 3 * weight / half
kernel(half - weight) = Exp(-gx * gx / 2)
kernel(half + weight) = kernel(half - weight)
lnorm = lnorm + kernel(half + weight) * 2
Next
For x = 0 To half
norm(x) = lnorm
lnorm = lnorm - kernel(x)
Next
w = UBound(dat.pix, 1) \ 4
h = UBound(dat.pix, 2)
ReDim tmp(w * 4, h)
For y = 0 To h
For x = 0 To w - 1
If x < half Then wFrom = x Else wFrom = half
If x > w - half Then wTo = w - x Else wTo = half
For px = 0 To 3
acc = 0
For index = -wFrom To wTo
acc = acc + dat.pix((x + index) * 4 + px, y) * kernel(index + half)
Next
acc = acc / norm(half * 2 - (wTo + wFrom))
If acc > 255 Then acc = 255
tmp(x * 4 + px, y) = acc
Next
Next
dat.percent = y / h / 2
Next
For x = 0 To w - 1
For y = 0 To h
If y < half Then wFrom = y Else wFrom = half
If y > h - half Then wTo = h - y Else wTo = half
For px = 0 To 4
acc = 0
For index = -wFrom To wTo
acc = acc + tmp(x * 4 + px, y + index) * kernel(index + half)
Next
acc = acc / norm(half * 2 - (wTo + wFrom))
If acc > 255 Then acc = 255
dat.pix(x * 4 + px, y) = acc
Next
Next
dat.percent = x / w / 2 + 0.5
Next
dat.percent = 1
GaussianBlur = 1
ERRORLABEL:
End Function
' // Минимум
Public Function Minimum(dat As ThreadData) As Long
Dim x As Long
Dim y As Long
Dim w As Long
Dim h As Long
Dim px As Long
Dim hlf As Long
Dim fx As Long
Dim fy As Long
Dim tx As Long
Dim ty As Long
Dim dx As Long
Dim dy As Long
Dim acc As Byte
Dim tmp() As Byte
Dim value As Single
On Error GoTo ERRORLABEL
value = dat.value
If value < 0 Then value = 0
If value > 255 Then value = 255
w = UBound(dat.pix, 1) \ 4
h = UBound(dat.pix, 2)
hlf = CLng(dat.value)
tmp = dat.pix
For y = 0 To h
If y < hlf Then fy = y Else fy = hlf
If y > h - hlf Then ty = h - y Else ty = hlf
For x = 0 To w
If x < hlf Then fx = x Else fx = hlf
If x > w - hlf Then tx = w - x Else tx = hlf
For px = 0 To 3
acc = 255
For dx = -fx To tx: For dy = -fy To ty
If tmp((x + dx) * 4 + px, y + dy) < acc Then acc = tmp((x + dx) * 4 + px, y + dy)
Next: Next
dat.pix(x * 4 + px, y) = acc
Next
Next
dat.percent = y / h
Next
dat.percent = 1
Minimum = 1
ERRORLABEL:
End Function
' // Максимум
Public Function Maximum(dat As ThreadData) As Long
Dim x As Long
Dim y As Long
Dim w As Long
Dim h As Long
Dim px As Long
Dim hlf As Long
Dim fx As Long
Dim fy As Long
Dim tx As Long
Dim ty As Long
Dim dx As Long
Dim dy As Long
Dim acc As Byte
Dim tmp() As Byte
Dim value As Single
On Error GoTo ERRORLABEL
value = dat.value
If value < 0 Then value = 0
If value > 255 Then value = 255
w = UBound(dat.pix, 1) \ 4
h = UBound(dat.pix, 2)
hlf = CLng(dat.value)
tmp = dat.pix
For y = 0 To h
If y < hlf Then fy = y Else fy = hlf
If y > h - hlf Then ty = h - y Else ty = hlf
For x = 0 To w
If x < hlf Then fx = x Else fx = hlf
If x > w - hlf Then tx = w - x Else tx = hlf
For px = 0 To 3
acc = 0
For dx = -fx To tx: For dy = -fy To ty
If tmp((x + dx) * 4 + px, y + dy) > acc Then acc = tmp((x + dx) * 4 + px, y + dy)
Next: Next
dat.pix(x * 4 + px, y) = acc
Next
Next
dat.percent = y / h
Next
dat.percent = 1
Maximum = 1
ERRORLABEL:
End Function
' // Тиснение
Public Function Emboss(dat As ThreadData) As Long
Dim kernel() As Single
Dim value As Single
value = dat.value
ReDim kernel(2, 2)
kernel(0, 0) = -value ^ 2: kernel(1, 0) = -value: kernel(2, 0) = 0
kernel(0, 1) = -value: kernel(1, 1) = 9: kernel(2, 1) = value
kernel(0, 2) = 0: kernel(1, 2) = value: kernel(2, 2) = value ^ 2
Emboss = Convolution(dat, kernel)
End Function
' // Выделение краев
Public Function EdgeDetect(dat As ThreadData) As Long
Dim kernel() As Single
Dim value As Single
value = dat.value
ReDim kernel(2, 2)
kernel(0, 0) = 0: kernel(1, 0) = -value: kernel(2, 0) = 0
kernel(0, 1) = -value: kernel(1, 1) = value * 4: kernel(2, 1) = -value
kernel(0, 2) = 0: kernel(1, 2) = -value: kernel(2, 2) = 0
EdgeDetect = Convolution(dat, kernel)
End Function
' // Резкость
Public Function Sharpen(dat As ThreadData) As Long
Dim kernel() As Single
Dim value As Single
value = dat.value
ReDim kernel(2, 2)
kernel(0, 0) = 0: kernel(1, 0) = -value: kernel(2, 0) = 0
kernel(0, 1) = -value: kernel(1, 1) = value * 4 + 9: kernel(2, 1) = -value
kernel(0, 2) = 0: kernel(1, 2) = -value: kernel(2, 2) = 0
Sharpen = Convolution(dat, kernel)
End Function
' // Рыбий глаз
Public Function FishEye(dat As ThreadData) As Long
Dim x As Long
Dim y As Long
Dim cx As Single
Dim cy As Single
Dim nx As Long
Dim ny As Long
Dim r As Single
Dim tmp() As Byte
Dim w As Long
Dim h As Long
Dim value As Single
Dim px As Long
On Error GoTo ERRORLABEL
w = UBound(dat.pix, 1) \ 4 + 1
h = UBound(dat.pix, 2) + 1
value = dat.value
If value > 1 Then value = 1
If value < 0 Then value = 0
tmp = dat.pix
For y = 0 To h - 1
For x = 0 To w - 1
cx = x / w - 0.5: cy = y / h - 0.5
r = Sqr(cx * cx + cy * cy)
nx = (cx + 0.5 + value * cx * ((r - 1) / 0.5)) * (w - 1)
ny = (cy + 0.5 + value * cy * ((r - 1) / 0.5)) * (h - 1)
For px = 0 To 3
dat.pix(x * 4 + px, y) = tmp(nx * 4 + px, ny)
Next
Next
dat.percent = y / h
Next
dat.percent = 1
FishEye = 1
ERRORLABEL:
End Function
' // Фильтрация с помощью свертки
Private Function Convolution(dat As ThreadData, kernel() As Single) As Long
Dim x As Long
Dim y As Long
Dim w As Long
Dim h As Long
Dim dx As Long
Dim dy As Long
Dim tmp() As Byte
Dim valFx As Long
Dim valFy As Long
Dim valTx As Long
Dim valTy As Long
Dim acc As Long
Dim px As Long
Dim hlfSize As Long
On Error GoTo ERRORLABEL
w = UBound(dat.pix, 1)
h = UBound(dat.pix, 2)
hlfSize = UBound(kernel) \ 2
tmp = dat.pix
For y = 0 To h
If y < hlfSize Then valFy = y Else valFy = hlfSize
If y > h - hlfSize Then valTy = h - y Else valTy = hlfSize
For x = 0 To w
px = x \ 4
If px < hlfSize Then valFx = px Else valFx = hlfSize
If px > w \ 4 - hlfSize Then valTx = w \ 4 - px Else valTx = hlfSize
acc = 0
For dy = -valFy To valTy
For dx = -valFx To valTx
acc = acc + tmp(x + dx * 4, y + dy) * kernel(dx + hlfSize, dy + hlfSize)
Next
Next
acc = acc \ ((valFx + valTx + 1) * (valFy + valTy + 1))
If acc > 255 Then acc = 255 Else If acc < 0 Then acc = 0
dat.pix(x, y) = acc
Next
dat.percent = y / h
Next
Convolution = 1
dat.percent = 1
ERRORLABEL:
End Function 'clare Function GetMem4 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Integer, lParam As Any) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hWnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hWnd As Long, ByVal lpString As Long) As Long
Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomW" (ByVal lpString As Long) As Integer
Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageW" (ByVal lpString As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Const GWL_WNDPROC As Long = (-4)
Private Const INFINITE As Long = -1&
Private Const MUTEX_ALL_ACCESS As Long = &H1F0001
Private Const FILE_MAP_READ As Long = &H4
Private Const FILE_MAP_WRITE As Long = &H2
Private Const WAIT_FAILED As Long = -1&
Private WM_SENDMESSAGE As Long ' Наше сообщение для обмена с основной программой. Отсылая из текущего потока это сообщение
' в наше приложение (TestSubclassDLL), мы уведомляем приложение через SendMessage о том, что
' пришло новое сообщение, параметры которого записаны в файловое представление. Передавая из
' главного (TestSubclassDLL) приложения сюда это сообщение, мы уведомляем о том, что нужно
' снять сабклассинг и выполнить деинициализацию.
Dim hMutex As Long ' Описатель мьютекса для синхронизации чтения/записи общих данных
Dim hMap As Long ' Хендл файлового отображения
Dim lpShrdData As Long ' Адрес общих данных
Dim hWndServer As Long ' Хендл окна для приема и обработки сообщений
Dim hWndHook As Long ' Хендл сабклассируемого окна в этом процессе
Dim hHook As Long ' Хендл хука, для передачи в CallNextHookEx
Dim aPrevProc As Integer ' Атом имени свойства изначальной оконной процедуры
Dim init As Boolean ' Инициализирован ли сабклассинг
Dim disabled As Boolean ' Сабклассинг окончен.
' // Процедура хука
Public Function GetMsgProc(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim prevProc As Long
' Если не инициализирован сабклассинг - инициализируем
If Not (init Or disabled) Then
' Открываем проекцию
hMap = OpenFileMapping(FILE_MAP_WRITE, False, StrPtr("TrickSubclassFileMap"))
If hMap = 0 Then MsgBox "Невозможно открыть проекцию", vbCritical: Clear: Exit Function
' Проецируем
lpShrdData = MapViewOfFile(hMap, FILE_MAP_WRITE, 0, 0, 0)
CloseHandle hMap: hMap = 0
If lpShrdData = 0 Then MsgBox "Невозможно отобразить представление", vbCritical: Clear: Exit Function
' Открываем синхронизирующий мьютекс
hMutex = OpenMutex(MUTEX_ALL_ACCESS, False, StrPtr("TrickSubclassMutex"))
If hMutex = 0 Then MsgBox "Невозможно отрыть мьютекс", vbCritical: Clear: Exit Function
' Регистрация сообщения
WM_SENDMESSAGE = RegisterWindowMessage(StrPtr(WM_SENDMESSAGE))
If WM_SENDMESSAGE = 0 Then MsgBox "Невозможно Зарегистрировать сообщение", vbCritical: Clear: Exit Function
' Добавляем/получаем атом для сохранения предыдущей оконной процедуры
aPrevProc = GlobalAddAtom(StrPtr("prevProc"))
If aPrevProc = 0 Then MsgBox "Невозможно добавить атом", vbCritical: Clear: Exit Function
' Захватываем мьютекс. Если например в главном приложении еще не произошел выход из SetWindowsHookEx, то
' еще неизвестен хендл хука, а т.к. у нас там уже захвачен этот мьютекс, то этот поток будет ждать пока
' мьютекс не освободится, что произойдет только после записи хендля хука в общую память и остальных данных
If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
' Получаем хендл окна, которое будет принимать сообщения
GetMem4 ByVal lpShrdData, hWndServer
' Получаем хендл сабклассируемого окна
GetMem4 ByVal lpShrdData + 4, hWndHook
' Получаем хендл хука
GetMem4 ByVal lpShrdData + 8, hHook
' Освобождаем мьютекс
ReleaseMutex hMutex
' Получаем адрес оконной процедуры и задаем новый
prevProc = SetWindowLong(hWndHook, GWL_WNDPROC, AddressOf WndProc)
If prevProc = 0 Then MsgBox "Невозможно заменить оконную процедуру", vbCritical: Clear: Exit Function
' Установка свойства окна
SetProp hWndHook, CLng(aPrevProc) And &HFFFF&, prevProc
' Успех
init = True
End If
' Передаем на обработку другим процедурам
GetMsgProc = CallNextHookEx(hHook, code, wParam, lParam)
End Function
' // Деинициализация
Public Sub Clear()
If hMutex Then CloseHandle (hMutex): hMutex = 0
If lpShrdData Then UnmapViewOfFile (lpShrdData): lpShrdData = 0
If hWndHook Then RemoveProp hWndHook, CLng(aPrevProc) And &HFFFF&: hWndHook = 0
If aPrevProc Then GlobalDeleteAtom (aPrevProc): aPrevProc = 0
init = False
End Sub
' // Оконная процедура
Private Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim sendData As MsgData
Dim prevProc As Long
' Проверяем не снятие ли сабклассинга
If uMsg = WM_SENDMESSAGE Then
' Получаем предыдущий адрес процедуры
prevProc = GetProp(hWnd, CLng(aPrevProc) And &HFFFF&)
' Устанавливаем его оконной процедуре
SetWindowLong hWnd, GWL_WNDPROC, prevProc
' Очистка
Clear
' Отключаем сабклассинг
' Возможна ситуация когда будет вызвана GetMsgProc, до того, как будет снят хук в главно приложении
' этот флаг предотвращает повторную инициализацию данных.
disabled = True
Exit Function
' Теперь из главного приложения будет вызвана UnhookWindowsHookEx и наша DLL будет выгружена из памяти.
End If
' Формируем запрос
sendData.hWnd = hWnd
sendData.uMsg = uMsg
sendData.wParam = wParam
sendData.lParam = lParam
sendData.defCall = True
' Захватываем мьютекс
If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
CopyMemory ByVal lpShrdData + 12, sendData, Len(sendData)
' Освобождаем мьютекс
ReleaseMutex hMutex
' Отправляем сообщение главному окну
SendMessage hWndServer, WM_SENDMESSAGE, 0, ByVal 0
' Получаем результат обработки
If WaitForSingleObject(hMutex, INFINITE) = WAIT_FAILED Then MsgBox "Ошибка ожидания", vbCritical: Clear: Exit Function
CopyMemory sendData, ByVal lpShrdData + 12, Len(sendData)
' Освобождаем мьютекс
ReleaseMutex hMutex
' Следует ли обрабатывать его дальше
If sendData.defCall Then
prevProc = GetProp(hWnd, CLng(aPrevProc) And &HFFFF&)
WndProc = CallWindowProc(prevProc, sendData.hWnd, sendData.uMsg, sendData.wParam, sendData.lParam)
Else
WndProc = sendData.return
End If
End Function
; Thread procedure
Copy:
xor eax,eax ; eax <- 0
push eax ; local variable pbCancel
mov ecx,esp ; ecx <- *pbCancel
push eax ; dwCopyFlags
push ecx ; *pbCancel
push eax ; lpData
push 0x0 ; lpProgressRoutine
push 0x0 ; lpNewFileName
push 0x0 ; lpExitingFileName
call 0x0 ; callCopyFileEx
mov dword [0],eax ; Return value
xor eax,eax ; dwExitCode
call 0x0 ; call ExitThread
; callback function CopyProgressRoutine
CopyProgressRoutine:
fild qword [esp+12] ; LARGE_INTEGER to floating point - TotalBytesTransferred
fild qword [esp+4] ; LARGE_INTEGER to floating point - TotalFileSize
fdivp ; devide by TotalFileSize
fstp dword [0] ; Save to variable
mov eax, dword [0] ; Return value
ret 0x34' Класс для фонового копирования файла, с отображением прогресса копирования
' Автор: © Кривоус Анатолий Анатольевич (The trick) 2013
Option Explicit
Private Declare Function HeapCreate Lib "kernel32" (ByVal flOptions As Long, ByVal dwInitialSize As Long, ByVal dwMaximumSize As Long) As Long
Private Declare Function HeapDestroy Lib "kernel32" (ByVal hHeap As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function GetMem4 Lib "msvbvm60" (pSrc As Any, pDst As Any) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Function SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Enum StateOperation
COMPLETED ' Операция закончена успешно
ACTIVE ' Операция выполняется
FAILED ' Операция завершилась неудачей
End Enum
Private Const STILL_ACTIVE = &H103&
Private Const PROGRESS_CONTINUE = 0
Private Const PROGRESS_CANCEL = 1
Private Const COPY_FILE_FAIL_IF_EXISTS = &H1
Private Const HEAP_CREATE_ENABLE_EXECUTE = &H40000
Private Const HEAP_NO_SERIALIZE = &H1
Private Const INFINITE = &HFFFFFFFF
Private Const THREAD_BASE_PRIORITY_MIN = -2
Private Const THREAD_PRIORITY_LOWEST = THREAD_BASE_PRIORITY_MIN
Private Const AsmSize As Long = 64 ' Размер вставки в байтах
Private mSourceFileName As String ' Путь, откуда копируем
Private mDestinationFileName As String ' Путь, куда копируем
Private mProgress As Single ' Прогресс 0..1
Dim hHeap As Long ' Дескриптор кучи
Dim lpFunc As Long ' Адрес функции в ассемблерной вставке
Dim init As Boolean ' Инициализирован ли код потока
Dim Src() As Byte ' ASCII строка mSourceFileName
Dim Dst() As Byte ' ASCII строка mDestinationFileName
Dim ApiRet As Long ' Возвращаемое значение из API
Dim ProgressRet As Long ' Возвращаемое значение из CopyProgressRoutine
Dim hThread As Long ' Хендл потока
Public Property Get SourceFileName() As String ' Возвращает путь откуда копировать
SourceFileName = mSourceFileName
End Property
Public Property Let SourceFileName(FileName As String) '
mSourceFileName = FileName
End Property
Public Property Get DestinationFileName() As String ' Возвращает путь куда копировать
DestinationFileName = mDestinationFileName
End Property
Public Property Let DestinationFileName(FileName As String) '
mDestinationFileName = FileName
End Property
Public Property Get Progress() As Single ' Возвращает значение от 0 до 1 прогресса копирования
Progress = mProgress
End Property
Public Property Get State() As StateOperation ' Возвращает состояние выполнения операции
If Process Then State = ACTIVE: Exit Property
State = IIf(ApiRet, COMPLETED, FAILED)
End Property
Public Sub Copy() ' Запустить копирование
Dim IDThrd As Long
If Not init Or Process Then Exit Sub ' Если не инициализированы или уже идет процесс то выходим
ProgressRet = PROGRESS_CONTINUE ' Установка продолжения процесса
LoadDynamicValue
ApiRet = -1 ' Проверка возвращаемого значения CopyFileEx
hThread = CreateThread(ByVal 0, 0, lpFunc, ByVal 0, 0, IDThrd) ' Запуск нового потока
If hThread = 0 Then ApiRet = 0: Exit Sub ' Если не удалось создать поток, тогда устанавливаем ошибку
SetThreadPriority hThread, THREAD_PRIORITY_LOWEST ' Устанавливаем низкий приоритет потоку копирования
End Sub
Public Function Cancel(Optional Wait As Boolean = False) As Boolean ' Остановить текущий процесс, ждать завершения?
If Process Then ' Имеет смысл только если идет процесс
If Wait Then
Call StopAll: Cancel = True ' Если ждем
Else
ProgressRet = PROGRESS_CANCEL ' Устанавливаем возвращаемое значение в CPR
Cancel = True
End If
End If
End Function
Private Property Get Process() As Boolean ' Возвращает True если операция выполняется
Dim Ret As Long
If hThread = 0 Then Exit Property ' Если нет активного потока, тогда False
GetExitCodeThread hThread, Ret ' Запрашиваем, завершился ли поток
If Ret = STILL_ACTIVE Then Process = True ' Если он активен, то возвращаем True
End Property
Private Sub StopAll() ' Остановить все процессы
ProgressRet = PROGRESS_CANCEL ' Отменяем процессы
If hThread Then
WaitForSingleObject hThread, INFINITE ' Ждем завершения потока
End If
hThread = 0
End Sub
Private Sub CreateAsm(Asm() As Long) ' Создаем вставку
ReDim Asm(-Int(-AsmSize / 4) - 1) ' Вычисляем нужный размер массива
Asm(0) = &H8950C031: Asm(1) = &H505150E1: Asm(2) = &H68&
Asm(3) = &H6800&: Asm(4) = &H680000: Asm(5) = &HE8000000
Asm(6) = &H0&: Asm(7) = &HA3&: Asm(8) = &HE8C03100
Asm(9) = &H0&: Asm(10) = &HC246CDF: Asm(11) = &H4246CDF
Asm(12) = &H1DD9F9DE: Asm(13) = &H0&: Asm(14) = &HA1&
Asm(15) = &H34C200
End Sub
Private Sub LoadDynamicValue() ' Установка динамических значений в вставке
Src = StrConv(mSourceFileName & vbNullChar, vbFromUnicode) ' Переводим путь из Юникода в ANSI
Dst = StrConv(mDestinationFileName & vbNullChar, vbFromUnicode) ' ...
GetMem4 VarPtr(Src(0)), ByVal lpFunc + &H13& ' Установка указателя на Исходное размещение
GetMem4 VarPtr(Dst(0)), ByVal lpFunc + &HE& ' Установка указателя на "Результирующее" размещение
End Sub
Private Sub LoadStaticValue(lpFunc As Long) ' Установка статичных значений в вставке
Dim hKernel32 As Long ' Хендл модуля Kernel32
Dim lpCopyFileEx As Long ' Адрес функции CopyFileEx
Dim lpExitThread As Long ' Адрес функции ExitThread
hKernel32 = LoadLibrary("Kernel32.dll") ' Получаем хендл Kernel32.dll
lpCopyFileEx = GetProcAddress(hKernel32, "CopyFileExA") ' Получаем адреса функций ...
lpExitThread = GetProcAddress(hKernel32, "ExitThread") '
GetMem4 lpFunc + &H28&, ByVal lpFunc + &H9& ' Установка указателя на CopyProgressRoutine
GetMem4 lpCopyFileEx - (lpFunc + &H1C&), ByVal lpFunc + &H18& ' Установка перехода на CopyFileExA
GetMem4 lpExitThread - (lpFunc + &H28&), ByVal lpFunc + &H24& ' Установка перехода на ExitThread
GetMem4 VarPtr(ApiRet), ByVal lpFunc + &H1D& ' Установка указателя на возвращаемое значение CopyFileEx
GetMem4 VarPtr(mProgress), ByVal lpFunc + &H34& ' Установка указателя на mProgress
GetMem4 VarPtr(ProgressRet), ByVal lpFunc + &H39& ' Установка указателя на возвращаемое значение CPR
End Sub
Private Sub Class_Initialize()
Dim Asm() As Long ' Буфер с ассемблерной вставкой
CreateAsm Asm ' Создаем вставку
hHeap = HeapCreate(HEAP_CREATE_ENABLE_EXECUTE Or _
HEAP_NO_SERIALIZE, AsmSize, AsmSize) ' Создаем кучу, с разрешением для выполнения,
' размером с ассемблерную вставку
If hHeap = 0 Then MsgBox "Error creating heap", vbCritical: _
Exit Sub ' При ошибке выходим
lpFunc = HeapAlloc(hHeap, HEAP_NO_SERIALIZE, AsmSize) ' Выделяем память в куче
If lpFunc = 0 Then MsgBox "HeapAlloc return NULL", _
vbCritical: Call Class_Terminate: Exit Sub ' Не удалось выделить память
CopyMemory ByVal lpFunc, Asm(0), AsmSize ' Копируем вставку в выделенную память
LoadStaticValue lpFunc
ApiRet = -1 ' Чтобы отрабатывало свойство State
init = True ' Инициализация успешно
End Sub
Private Sub Class_Terminate()
If Process Then
StopAll ' Останавливаем
End If
If lpFunc Then
HeapFree hHeap, HEAP_NO_SERIALIZE, ByVal lpFunc ' Освобождаем выделенную память
End If
If hHeap Then
HeapDestroy hHeap ' Удаляем кучу
End If
End Sub
Option Explicit
Private Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Sub EbGetExecutingProj Lib "vba6" (hProject As Long)
Private Declare Function TipGetFunctionId Lib "vba6" (ByVal hProj As Long, ByVal bstrName As Long, ByRef bstrId As Long) As Long
Private Declare Function TipGetLpfnOfFunctionId Lib "vba6" (ByVal hProject As Long, ByVal bstrId As Long, ByRef lpAddress As Long) As Long
Private Declare Sub SysFreeString Lib "oleaut32" (ByVal lpbstr As Long)
Private Const PAGE_EXECUTE_READWRITE = &H40
' Вспомогательные функции
Public Sub PatchFunc(FuncName As String, ByVal Addr As Long)
Dim lpAddr As Long, hProj As Long, sId As Long, InIDE As Boolean
Debug.Assert MakeTrue(InIDE)
' Получаем адрес функции
If InIDE Then
EbGetExecutingProj hProj
TipGetFunctionId hProj, StrPtr(FuncName), sId
TipGetLpfnOfFunctionId hProj, sId, lpAddr
SysFreeString sId
Else
lpAddr = GetAddr(Addr)
VirtualProtect lpAddr, 8, PAGE_EXECUTE_READWRITE, 0
End If
' Записываем вставку
' Запускать только по Ctrl+F5!!
' pop eax
' pop ecx
' push eax
' jmp ecx
GetMem4 &HFF505958, ByVal lpAddr
GetMem4 &HE1, ByVal lpAddr + 4
End Sub
Private Function GetAddr(ByVal Addr As Long) As Long
GetAddr = Addr
End Function
Public Function MakeTrue(ByRef bvar As Boolean) As Boolean
bvar = True: MakeTrue = True
End Function' Пример вызова обычных функции по указателю
Public Sub Main()
' Пропатчиваем функции, перед первым вызовом
PatchFunc "Proto1", AddressOf Proto1
PatchFunc "Proto2", AddressOf Proto2
MsgBox Proto1(AddressOf Func1, 1, "Вызов")
MsgBox Proto1(AddressOf Func2, 2, "По указателю")
MsgBox Proto1(AddressOf Func3, 3, ";)")
Call Proto2(AddressOf Sub1)
Call Proto2(AddressOf Sub2)
End Sub
' Прототип функций
Private Function Proto1(ByVal Addr As Long, ByVal x As Long, y As String) As String
End Function
Private Sub Proto2(ByVal Addr As Long)
End Sub
' Функции
Private Function Func1(ByVal x As Long, y As String) As String
Func1 = "Func1_" & y
End Function
Private Function Func2(ByVal x As Long, y As String) As String
Func2 = "Func2_" & y
End Function
Private Function Func3(ByVal x As Long, y As String) As String
Func3 = "Func3_" & y
End Function
Private Sub Sub1()
MsgBox "Sub1"
End Sub
Private Sub Sub2()
MsgBox "Sub2"
End SubPrivate Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
' Пример вызова WinApi функций по указателю
Public Sub Main()
Dim hUser As Long, hGDI As Long
Dim DC As Long
hUser = LoadLibrary("user32")
hGDI = LoadLibrary("gdi32")
PatchFunc "GetDC", AddressOf GetDC
PatchFunc "ReleaseDC", AddressOf ReleaseDC
PatchFunc "Ellipse", AddressOf Ellipse
DC = GetDC(GetProcAddress(hUser, "GetDC"), 0)
Ellipse GetProcAddress(hGDI, "Ellipse"), DC, 0, 0, 500, 500
ReleaseDC GetProcAddress(hUser, "ReleaseDC"), 0, DC
End Sub
' Прототип функций
Private Function GetDC(ByVal Addr As Long, ByVal hWnd As Long) As Long
End Function
Private Function ReleaseDC(ByVal Addr As Long, ByVal hWnd As Long, ByVal hdc As Long) As Long
End Function
Private Function Ellipse(ByVal Addr As Long, ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
End FunctionPrivate Declare Function GetMem4 Lib "msvbvm60" (src As Any, dst As Any) As Long
' Пример вызова методов объекта по указателю
Public Sub Main()
Dim IUnk As Long
Dim lpProp As Long
Dim lpView As Long
Dim Obj1 As clsTest
Dim Obj2 As clsTest
Dim ret As Long
Set Obj1 = New clsTest
Set Obj2 = New clsTest
GetMem4 ByVal ObjPtr(Obj1), IUnk
GetMem4 ByVal IUnk + &H1C, lpProp
GetMem4 ByVal IUnk + &H20, lpView
PatchFunc "clsTest_PropLet", AddressOf clsTest_PropLet
PatchFunc "clsTest_View", AddressOf clsTest_View
clsTest_PropLet lpProp, Obj1, 1234
clsTest_PropLet lpProp, Obj2, 9876
clsTest_View lpView, Obj1, ret
Debug.Print ret
clsTest_View lpView, Obj2, ret
Debug.Print ret
End Sub
' Прототип функций
Private Function clsTest_PropLet(ByVal Addr As Long, ByVal Obj As clsTest, ByVal Value As Long) As Long
End Function
Private Function clsTest_View(ByVal Addr As Long, ByVal Obj As clsTest, ret As Long) As Long
End FunctionOption Explicit
Dim mValue As Long
Public Property Let Prop(ByVal Value As Long)
mValue = Value
End Property
Public Function View() As Long
View = MsgBox(mValue, vbYesNoCancel)
End FunctionDeclaration - see source.
...
' Локальные переменные уровня модуля
Dim mHwnd As Long, Init As Boolean, token As Long, img As Long, frames As Long, gr As Long, prevwndproc As Long
Dim tInit As Boolean, frame() As Long, loops As Long, index As Long, cycle As Long, isplay As Boolean
' Хендл окна в котором будем рисовать анимацию
Public Property Get hwnd() As Long
hwnd = mHwnd
End Property
Public Property Let hwnd(ByVal value As Long)
StopAnim ' Останавливаем анимацию
If hwnd Then UnHook ' Если до этого сабклассили, то отключаем сабклассинг
mHwnd = value
Hook ' Сабклассим новое окно
End Property
' Ширина кадра анимации
Public Property Get Width() As Long
GdipGetImageWidth img, Width
End Property
' Высота кадра анимации
Public Property Get Height() As Long
GdipGetImageHeight img, Height
End Property
' Текущий кадр
Public Property Get CurrentFrame() As Long
CurrentFrame = index
End Property
' Количество кадров
Public Property Get FramesCount() As Long
FramesCount = frames
End Property
' Сколько циклов анимации
Public Property Get LoopCount() As Long
LoopCount = loops
End Property
' Проигрывается ли анимация
Public Property Get IsPlaying() As Boolean
IsPlaying = isplay
End Property
' Загрузка файла анимации
Public Function LoadAnimation(ByVal FileName As String) As Boolean
Dim GpInput As GdiplusStartupInput ' Для инициализации GDI+
Dim pc As Long, sz As Long, pi As PropertyItem
Dim buf() As Byte ' Буффер для свойств
If Not Init Then ' Если не инициализирован GDI+
GpInput.GdiplusVersion = 1
If GdiplusStartup(token, GpInput) Then Exit Function Else Init = True ' Инициализируем, при неудаче выходим
End If
Clear ' Очистка, если до этого что-то загружали
If GdipLoadImageFromFile(StrConv(FileName, vbUnicode), img) Then Exit Function ' Загружаем картинку
If GdipImageGetFrameCount(img, DEFINE_GUID(FrameDimensionTime), frames) Then ' Проверяем кол-во кадров
GdipDisposeImage img ' При неудаче удаляем картинку и выходим (возможно что не GIF)
Exit Function
End If
' Узнаем время каждого кадра
GdipGetPropertyItemSize img, PropertyTagFrameDelay, sz ' Получаем размер свойства в байтах
If sz > 0 And frames > 1 Then ' Имеет смысл только если кадров>1
ReDim buf(sz - 1) ' Выделяем буфер
GdipGetPropertyItem img, PropertyTagFrameDelay, sz, buf(0) ' Копируем свойство в буфер
CopyMemory pi, buf(0), Len(pi) ' Копируем в описатель
ReDim frame(frames - 1) ' Выделяем кадровый буфер (длительности)
CopyMemory frame(0), buf(Len(pi)), pi.Length ' Копируем значения длительностей
End If
' Узнаем зациклена ли анимация
GdipGetPropertyItemSize img, PropertyTagLoopCount, sz
If sz > 0 And frames > 1 Then
ReDim buf(sz - 1)
GdipGetPropertyItem img, PropertyTagLoopCount, sz, buf(0)
CopyMemory pi, buf(0), Len(pi)
GetMem2 buf(Len(pi)), loops
End If
index = 0: cycle = 0 ' Очистка счетчиков
LoadAnimation = True ' Успешно
End Function
' Проигрыш анимации
Public Function PlayAnim() As Boolean
If Init And hwnd <> 0 And img <> 0 And Not isplay Then
If frames > 1 Then ' Смысл запускать таймер если кадров > 1
If SetTimer(mHwnd, 1, frame(index) * 10, AddressOf TimerProc) = 0 Then _
Exit Function ' Не удалось запустить таймер
End If
tInit = True ' Таймер инициализирован
isplay = True ' Включен проигрыш
PlayAnim = True ' Возвращаем успешное значение
RedrawWindow mHwnd, ByVal 0, 0, RDW_INVALIDATE ' Перерисовываем
End If
End Function
' Пауза
Public Function Pause() As Boolean
If isplay Then ' Если играем
isplay = False ' то останавливаем
Pause = True ' Возвращаем успешное значение
StopTimer ' Останавливаем таймер
End If
End Function
' Остановка анимации
Public Sub StopAnim()
isplay = False ' Останавливаем проигрывание
index = 0 ' Обнуляем текущий кадр
cycle = 0 ' Обнуляем счетчик циклов
StopTimer ' Останавливаем таймер
RedrawWindow mHwnd, ByVal 0, 0, RDW_INVALIDATE ' Перерисовываем
End Sub
' Завершение работы
Public Sub ShutDown()
Clear ' Очистка ресурсов
If mHwnd Then UnHook ' Если сабклассили то выключаем сабклассинг
GdiplusShutdown token ' Выключаем GDI+
End Sub
' Очистка ресурсов
Private Sub Clear()
frames = 0 ' Обнуляем количество кадров
Erase frame() ' Удаляем массив длительностей кадров
If img Then GdipDisposeImage img ' Удаляем картинку
StopAnim ' Останавливаем анимацию
End Sub
' Остановка таймера
Private Sub StopTimer()
If tInit Then ' Если таймер инициализирован
KillTimer mHwnd, 1 ' Удаляем его
tInit = False ' Таймер не инициализирован
End If
End Sub
' Из строки в GUID
Private Function DEFINE_GUID(ByVal sGuid As String) As CLSID
Call CLSIDFromString(StrPtr(sGuid), DEFINE_GUID) ' GUID из строкового параметра
End Function
' Сабклассинг
Private Sub Hook()
prevwndproc = SetWindowLong(mHwnd, GWL_WNDPROC, AddressOf WndProc) ' Назначаем свою оконную процедуру
End Sub
Private Sub UnHook()
SetWindowLong mHwnd, GWL_WNDPROC, prevwndproc ' Возвращаем оконную процедуру
End Sub
' Оконная процедура
Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim ps As PAINTSTRUCT, tdc As Long, tbmp As Long, obmp As Long, rc As RECT
Select Case Msg
Case WM_PAINT ' Отрисовка
If index = -1 Or Not Init Then
WndProc = CallWindowProc(prevwndproc, hwnd, Msg, wParam, lParam) ' Если нет активной анимации рисуем как было
Else
' Для предотвращения мерцания, например анимаций с черным фоном, я решилл использовать двойную буфферизацию
GetClientRect hwnd, rc ' Узнаем размер ко контрола
BeginPaint hwnd, ps
tdc = CreateCompatibleDC(ps.hdc) ' Буфферный DC
tbmp = CreateCompatibleBitmap(ps.hdc, rc.iRight, rc.iBottom) ' Буфферная картинка
obmp = SelectObject(tdc, tbmp)
GdipCreateFromHDC tdc, gr ' Создаем Graphics
GdipGraphicsClear gr, &HFFFFFFFF ' Заливаем белым цветом
GdipImageSelectActiveFrame img, DEFINE_GUID(FrameDimensionTime), index ' Выбираем текущий кадр
GdipDrawImage gr, img, 0, 0 ' Рисуем его
GdipDeleteGraphics gr ' Удаляем Graphics
BitBlt ps.hdc, 0, 0, rc.iRight - rc.iLeft, _
rc.iBottom - rc.iTop, tdc, 0, 0, vbSrcCopy ' Отрисовка из буфера
SelectObject tdc, obmp ' Восстанавливаем и удаляем ....
DeleteObject tbmp
DeleteDC tdc
EndPaint hwnd, ps
End If
Case Else
WndProc = CallWindowProc(prevwndproc, hwnd, Msg, wParam, lParam) ' Остальное нас не интересует
End Select
End Function
' Процедура таймера
Private Sub TimerProc(ByVal hwnd As Long, ByVal Msg As Long, idEvent As Long, ByVal dwTime As Long)
index = index + 1 ' Кадр увеличился
If index >= frames Then ' Если переаолнение кадров
index = 0 ' В начало
cycle = cycle + 1 ' Увеличиваем циклы
If cycle > loops And CBool(loops) Then StopAnim: Exit Sub ' Если переполнение циклов то выключаем анимацию
End If
RedrawWindow mHwnd, ByVal 0, 0, RDW_INVALIDATE ' Перерисовываем
If SetTimer(mHwnd, 1, frame(index) * 10, AddressOf TimerProc) = 0 Then ' Устанавливаем новую задержку
StopAnim ' Не удалось запустить таймер
End If
End SubOption Explicit
Private Declare Function GetMem2 Lib "msvbvm60" (Src As Any, Dst As Any) As Long
Private Sub Form_Load()
Dim Value() As Byte, Res As String
StrToUI "1234567891011121314151617181920", Value
Res = UIToStr(Value)
End Sub
' Convert unsigned integer from byte array to string (decimal system)
Private Function UIToStr(bValue() As Byte) As String
Dim i As Long, f As Boolean, loc() As Byte
loc = bValue
Do
i = Div10UI(loc)
UIToStr = CStr(i) & UIToStr
f = False
For i = UBound(loc) To 0 Step -1
If loc(i) Then f = True: Exit For
Next
Loop While f
End Function
' Convert unsigned integer (decimal system) from string to byte array.
Private Sub StrToUI(sValue As String, Out() As Byte)
Dim i As Long, lpStr As Long, v As Integer, b(0) As Byte
ReDim Out(0)
If Len(sValue) Then
lpStr = StrPtr(sValue)
For i = 0 To Len(sValue) - 1
GetMem2 ByVal lpStr, v
v = v - &H30
If v < 0 Or v > 9 Then Err.Raise 13: Exit Sub
b(0) = v
If i Then Mul10UI Out
AddUI Out, b()
lpStr = lpStr + 2
Next
Else: Err.Raise 5
End If
End Sub
Private Sub AddUI(Op1() As Byte, Op2() As Byte)
Dim i As Long, p As Long, o As Long, q As Long
If UBound(Op1) < UBound(Op2) Then ReDim Preserve Op1(UBound(Op2))
Do
If i <= UBound(Op2) Then o = Op2(i) Else o = 0
q = CLng(Op1(i)) + o + p
p = (q And &H100&) \ &H100
Op1(i) = q And &HFF
i = i + 1
Loop While CBool(o Or p) And i <= UBound(Op1)
If p Then ReDim Preserve Op1(i): Op1(i) = p
End Sub
Private Function Div10UI(Value() As Byte) As Long
Dim i1 As Long, i2 As Long, acc() As Byte, loc() As Byte, q As Long, p As Long
For i1 = 0 To (UBound(Value) + 1) * 8
Div10UI = (Div10UI * 2) Or p
If Div10UI < 10 Then p = 0 Else p = 1: Div10UI = Div10UI - 10
For i2 = 0 To UBound(Value)
q = (CLng(Value(i2)) * 2) Or p
p = (q And &H100) \ &H100
Value(i2) = q And &HFF&
Next
Next
End Function
Private Sub Mul10UI(Value() As Byte)
Dim i As Long, p As Long, q As Long
For i = 0 To UBound(Value)
q = (CLng(Value(i)) * 4 + Value(i)) * 2 + p
p = (q And &HFF00&) \ &H100
Value(i) = q And &HFF
Next
If p Then ReDim Preserve Value(i): Value(i) = p
End SubType VbHeader
szVbMagic As String * 4
wRuntimeBuild As Integer
szLangDll As String * 14
szSecLangDll As String * 14
wRuntimeRevision As Integer
dwLCID As Long
dwSecLCID As Long
lpSubMain As Long
lpProjectInfo As Long
fMdlIntCtls As Long
fMdlIntCtls2 As Long
dwThreadFlags As Long
dwThreadCount As Long
wFormCount As Integer
wExternalCount As Integer
dwThunkCount As Long
lpGuiTable As Long
lpExternalCompTable As Long
lpComRegisterData As Long
bszProjectDescription As Long
bszProjectExeName As Long
bszProjectHelpFile As Long
bszProjectName As Long
End TypePUSH xxxxxxxx
CALL MSVBVM60.ThunRTMain' // Get VBHeader structure
Private Function GetVBHeader() As Long
Dim ptr As Long
' Get e_lfanew
GetMem4 ByVal hModule + &H3C, ptr
' Get AddressOfEntryPoint
GetMem4 ByVal ptr + &H28 + hModule, ptr
' Get VBHeader
GetMem4 ByVal ptr + hModule + 1, GetVBHeader
End FunctionType tGuiTable
lStructSize As Long
uuidObjectGUI As uuid
Unknown1 As Long
Unknown2 As Long
Unknown3 As Long
Unknown4 As Long
lObjectID As Long
Unknown5 As Long
fOLEMisc As Long
uuidObject As uuid
Unknown6 As Long
Unknown7 As Long
aFormPointer As Long
Unknown8 As Long
End Type
' // Modify VBHeader to replace Sub Main
Private Sub ModifyVBHeader(ByVal newAddress As Long)
Dim ptr As Long
Dim old As Long
Dim flag As Long
Dim count As Long
Dim size As Long
ptr = lpVBHeader + &H2C
' Are allowed to write in the page
VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
' Set a new address of Sub Main
GetMem4 newAddress, ByVal ptr
VirtualProtect ByVal ptr, 4, old, 0
' Remove startup form
GetMem4 ByVal lpVBHeader + &H4C, ptr
' Get forms count
GetMem4 ByVal lpVBHeader + &H44, count
Do While count > 0
' Get structure size
GetMem4 ByVal ptr, size
' Get flag (unknown5) from current form
GetMem4 ByVal ptr + &H28, flag
' When set, bit 5,
If flag And &H10 Then
' Unset bit 5
flag = flag And &HFFFFFFEF
' Are allowed to write in the page
VirtualProtect ByVal ptr, 4, PAGE_READWRITE, old
' Write changet flag
GetMem4 flag, ByVal ptr + &H28
' Restoring the memory attributes
VirtualProtect ByVal ptr, 4, old, 0
End If
count = count - 1
ptr = ptr + size
Loop
End SubOption Explicit
' Ёлка VB6
' © Кривоус Анатолий Анатольевич (The trick), 2013
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type Vector
x As Single
y As Single
End Type
Private Type COLORBYTES
BlueByte As Byte
GreenByte As Byte
RedByte As Byte
AlphaByte As Byte
End Type
Private Type COLORLONG
longval As Long
End Type
Private Type RECT
iLeft As Long
iTop As Long
iRight As Long
iBottom As Long
End Type
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, Graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreatePen1 Lib "gdiplus" (ByVal color As Long, ByVal Width As Single, ByVal unit As Long, Pen As Long) As Long
Private Declare Function GdipDeletePen Lib "gdiplus" (ByVal Pen As Long) As Long
Private Declare Function GdipSetPenColor Lib "gdiplus" (ByVal Pen As Long, ByVal ARGB As Long) As Long
Private Declare Function GdipSetPenWidth Lib "gdiplus" (ByVal Pen As Long, ByVal Width As Single) As Long
Private Declare Function GdipDrawLine Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, ByVal X1 As Single, ByVal Y1 As Single, ByVal X2 As Single, ByVal Y2 As Single) As Long
Private Declare Function GdipFillPolygon2 Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, Points As Vector, ByVal Count As Long) As Long
Private Declare Function GdipDrawPolygon Lib "gdiplus" (ByVal Graphics As Long, ByVal Pen As Long, Points As Vector, ByVal Count As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "gdiplus" (ByVal ARGB As Long, Brush As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "gdiplus" (ByVal Graphics As Long, ByVal SmoothingMd As Long) As Long
Private Declare Function GdipDeleteBrush Lib "gdiplus" (ByVal Brush As Long) As Long
Private Declare Function GdipSetSolidFillColor Lib "gdiplus" (ByVal Brush As Long, ByVal ARGB As Long) As Long
Private Declare Function GdipFillEllipse Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipSetPathGradientCenterColor Lib "gdiplus" (ByVal Brush As Long, ByVal lColors As Long) As Long
Private Declare Function GdipSetPathGradientSurroundColorsWithCount Lib "gdiplus" (ByVal Brush As Long, ARGB As Long, Count As Long) As Long
Private Declare Function GdipSetPathGradientCenterPoint Lib "gdiplus" (ByVal Brush As Long, Points As Vector) As Long
Private Declare Function GdipCreatePathGradientFromPath Lib "gdiplus" (ByVal Path As Long, polyGradient As Long) As Long
Private Declare Function GdipDeletePath Lib "gdiplus" (ByVal Path As Long) As Long
Private Declare Function GdipCreatePath Lib "gdiplus" (ByVal brushmode As Long, Path As Long) As Long
Private Declare Function GdipAddPathEllipse Lib "gdiplus" (ByVal Path As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipFillPath Lib "gdiplus" (ByVal Graphics As Long, ByVal Brush As Long, ByVal Path As Long) As Long
Private Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal Graphics As Long, Bitmap As Long) As Long
Private Declare Function GdipDrawImage Lib "gdiplus" (ByVal Graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal Graphics As Long, ByVal lColor As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, stride As Long, ByVal PixelFormat As Long, scan0 As Any, Bitmap As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, Graphics As Long) As Long
Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, ByVal crKey As Long, pblend As Long, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST As Long = -1
Private Const HTCAPTION As Long = 2
Private Const WM_NCLBUTTONDOWN As Long = &HA1
Private Const SPI_GETWORKAREA = 48
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE As Long = -20
Private Const ULW_ALPHA = &H2
Private Const AB_32Bpp255 = 33488896
Private Const BranchCount = 25, Ratio = 2, Factor = 3
Private Const ScaleNeedles = 10, AngleNeedles = 0.45, MinBranch = 25, MaxWidth = 10, StarSize = 25, SphereSize = 10, LampSize = 8
Private Const UnitPixel = 2, SmoothingModeAntiAlias = 4, PixelFormat32bppARGB = &H26200A
Dim MaxLen As Single
Dim token As Long, GpInput As GdiplusStartupInput, gr As Long, gr2 As Long, pn As Long, br As Long, bg As Long
Dim Lamp() As Vector, pt() As Vector, sw As Single
Dim WithEvents Tmr As Timer
Private Function vec(x As Single, y As Single) As Vector: vec.x = x: vec.y = y: End Function
Private Function Lerp(x As Single, y As Single, t As Single) As Single: Lerp = x * (1 - t) + y * t: End Function
Private Sub Branch(Pos As Vector, dir As Vector, ByVal f As Long, v As Vector)
Dim nPos As Vector, nDir As Vector, l As Single, d As Single, q As Long, p As Single, z As Single, dr As Long
l = Sqr(dir.x * dir.x + dir.y * dir.y)
If Abs(Pos.x - sw + dir.x) > Abs(v.x) Then v = vec(Pos.x + dir.x - sw, Pos.y + dir.y)
GdipSetPenWidth pn, l / MaxLen * MaxWidth / 2: GdipSetPenColor pn, &H80562B00
GdipDrawLine gr2, pn, Pos.x, Pos.y, Pos.x + dir.x, Pos.y + dir.y
p = 1 / l * Factor
GdipSetPenWidth pn, 1: GdipSetPenColor pn, &H80200020 Or (CLng(l / MaxLen * 128 + 127) * &H100)
Do While d < 1
nPos = vec(Lerp(Pos.x, Pos.x + dir.x, d), Lerp(Pos.y, Pos.y + dir.y, d))
nDir = vec((Cos(AngleNeedles) * dir.x * d - Sin(AngleNeedles) * dir.y * d) / l * ScaleNeedles, _
(Sin(AngleNeedles) * dir.x * d + Cos(AngleNeedles) * dir.y * d) / l * ScaleNeedles)
GdipDrawLine gr2, pn, nPos.x, nPos.y, nPos.x + nDir.x, nPos.y + nDir.y
nDir = vec((Cos(-AngleNeedles) * dir.x * d - Sin(-AngleNeedles) * dir.y * d) / l * ScaleNeedles, _
(Sin(-AngleNeedles) * dir.x * d + Cos(-AngleNeedles) * dir.y * d) / l * ScaleNeedles)
GdipDrawLine gr2, pn, nPos.x, nPos.y, nPos.x + nDir.x, nPos.y + nDir.y
d = d + p
Loop
If l < MinBranch Or f > 3 Then Exit Sub
q = Rnd * 4 + 2: p = 1 / (q - 1): d = 0
Do While q > 0
nPos = vec(Lerp(Pos.x, Pos.x + dir.x, d), Lerp(Pos.y, Pos.y + dir.y, d))
z = z + p: d = Rnd * 0.35 + 0.275: dr = 2
Do While dr
nDir = vec((Cos(d) * dir.x - Sin(d) * dir.y) / Ratio, (Sin(d) * dir.x + Cos(d) * dir.y) / Ratio)
Branch nPos, nDir, f + 1, v: dr = dr - 1: d = -d
Loop
q = q - 1
Loop
End Sub
Private Sub Form_DblClick()
Unload Me
End Sub
Private Sub Form_Load()
Dim n As Long, dy As Single, dx As Single, oy As Single, br2 As Long
Dim Pth As Long, Col As Long, sp() As Vector, v As Vector, rc As RECT
If SystemParametersInfo(SPI_GETWORKAREA, 0, rc, 0) = 0 Then End
SetWindowPos Me.hWnd, HWND_TOPMOST, rc.iRight - 293, rc.iBottom - 336, 293, 336, 0
GpInput.GdiplusVersion = 1
If GdiplusStartup(token, GpInput) Then End
If GdipCreateFromHDC(Me.hdc, gr) Then Unload Me
If GdipCreateSolidFill(&HFF562B00, br) Then Unload Me
If GdipCreatePen1(&HFF562B00, 1, UnitPixel, pn) Then Unload Me
If GdipCreateBitmapFromScan0(Me.ScaleWidth, Me.ScaleHeight, Me.ScaleWidth * 4, PixelFormat32bppARGB, ByVal 0, bg) Then Unload Me
If GdipGetImageGraphicsContext(bg, gr2) Then Unload Me
If GdipSetSmoothingMode(gr, SmoothingModeAntiAlias) Then Unload Me
If GdipSetSmoothingMode(gr2, SmoothingModeAntiAlias) Then Unload Me
Set Tmr = Me.Controls.Add("VB.Timer", "Tmr")
ReDim pt(BranchCount * 2 - 1): ReDim Lamp(BranchCount \ 3 - 2): ReDim sp(BranchCount \ 4 - 1)
n = Me.ScaleWidth / 3: dy = Me.ScaleHeight / BranchCount / 1.4: sw = Me.ScaleWidth / 2
dx = n / BranchCount: oy = Me.ScaleHeight * 0.25: MaxLen = Sqr(n * n + 30 * 30)
pt(0) = vec(sw, oy): pt(1) = vec(Me.ScaleWidth / 2 - 8, Me.ScaleHeight): pt(2) = vec(sw + 8, pt(1).y)
GdipFillPolygon2 gr2, br, pt(0), 3
Branch vec(sw, oy + Me.ScaleHeight / 1.5), vec(0, -Me.ScaleHeight / 3), 0, vec(0, 0)
For n = 0 To BranchCount - 1
pt(n * 2) = vec(0, 0): pt(n * 2 + 1) = vec(0, 0)
Call Branch(vec(sw, n * dy + oy), vec(-dx * n, -30), 0, pt(n * 2)): pt(n * 2).x = pt(n * 2).x + sw
Call Branch(vec(sw, n * dy + oy), vec(dx * n, -30), 0, pt(n * 2 + 1)): pt(n * 2 + 1).x = pt(n * 2 + 1).x + sw
If n Mod 3 = 0 And n > 1 And n < BranchCount - 1 Then Lamp((n - 1) \ 3) = pt(n * 2)
If n Mod 4 = 0 And n > 1 Then sp((n - 1) \ 4) = pt(n * 2 + 1)
Next
For n = 0 To UBound(sp): dy = (sp(n).x - sw): For dx = 0 To dy Step 10
v = vec(Lerp(sp(n).x, sw - dy, dx / dy), Lerp(sp(n).y, sp(n).y + 10, Sin(dx / dy * 3.14) * (dy / MaxLen) * 2))
GdipCreatePath 0, Pth
GdipAddPathEllipse Pth, v.x - SphereSize, v.y - SphereSize / 2, SphereSize, SphereSize
GdipCreatePathGradientFromPath Pth, br2
GdipSetPathGradientCenterPoint br2, vec(v.x - SphereSize / 3, v.y - SphereSize / 3)
Col = QBColor(Rnd * 15)
GdipSetPathGradientCenterColor br2, ARGB(255, vbWhite)
GdipSetPathGradientSurroundColorsWithCount br2, ARGB(64, Col), 1
GdipFillPath gr2, br2, Pth: GdipDeleteBrush br2: GdipDeletePath Pth
Next: Next
dx = 2.199
For n = 0 To 9 Step 2
pt(n) = vec(Cos(dx) * StarSize + Me.ScaleWidth / 2, Sin(dx) * StarSize + oy - StarSize - 15): dx = dx + 0.628
pt(n + 1) = vec(Cos(dx) * StarSize / 2 + Me.ScaleWidth / 2, Sin(dx) * StarSize / 2 + oy - StarSize - 15): dx = dx + 0.628
Next
SetWindowLong Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED
Tmr.Enabled = True: Tmr.Interval = 32: Call Tmr_Timer
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
ReleaseCapture
SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
If pn Then GdipDeletePen (pn)
If br Then GdipDeleteBrush (br)
If gr Then GdipDeleteGraphics (gr)
If gr2 Then GdipDeleteGraphics (gr2)
If bg Then GdipDisposeImage (bg)
GdiplusShutdown (token)
End Sub
Private Sub Tmr_Timer()
Static n As Long, c As Long, d As Single, x As Long, y As Long, dx As Single, Pth As Long, br2 As Long, v As Vector, _
Col As Long, B As Single, s As Single, dir As Single, sz As Currency, pts As Currency
d = Sin(c / 10): c = (c + 1) Mod 31: dir = 1
GdipGraphicsClear gr, &HFF000000
GdipDrawImage gr, bg, 0, 0
GdipSetSolidFillColor br, ARGB(d * 128 + 127, vbBlue): GdipSetPenWidth pn, 1: GdipSetPenColor pn, &HFFFF5050
GdipFillPolygon2 gr, br, pt(0), 10
GdipDrawPolygon gr, pn, pt(0), 10
For n = 0 To 9
GdipDrawLine gr, pn, Me.ScaleWidth / 2, Me.ScaleHeight * 0.25 - StarSize - 15, pt(n).x, pt(n).y
Next
For n = 0 To UBound(Lamp): d = sw - Lamp(n).x: dir = -dir: For x = 0 To d Step 2
B = Abs(Sin(s))
v = vec(Lerp(Lamp(n).x, sw + d, x / d), Lerp(Lamp(n).y, Lamp(n).y + 10, Sin(x / d * 3.14) * (d / MaxLen) * 3))
GdipCreatePath 0, Pth
GdipAddPathEllipse Pth, v.x - LampSize / 2, v.y - LampSize / 2, LampSize, LampSize
GdipCreatePathGradientFromPath Pth, br2
GdipSetPathGradientCenterPoint br2, vec(v.x, v.y)
GdipSetPathGradientCenterColor br2, ARGB(B * 255, vbCyan)
GdipSetPathGradientSurroundColorsWithCount br2, 0, 1
GdipFillPath gr, br2, Pth: GdipDeleteBrush br2: GdipDeletePath Pth
s = s + 2 * dir
Next: Next
Me.Refresh
sz = (Me.ScaleWidth + CCur(Me.ScaleHeight) * 4294967296#) / 10000
UpdateLayeredWindow Me.hWnd, Me.hdc, ByVal 0, sz, Me.hdc, pts, 0, AB_32Bpp255, ULW_ALPHA
End Sub
Public Function ARGB(ByVal Alpha As Byte, Col As Long) As Long
Dim bytestruct As COLORBYTES
Dim result As COLORLONG
With bytestruct
.AlphaByte = Alpha
.RedByte = (Col And &HFF0000) \ &H10000
.GreenByte = (Col And &HFF00&) \ &H100
.BlueByte = (Col And &HFF)
End With
LSet result = bytestruct
ARGB = result.longval
End Function
Option Explicit
Private Type XFORM
eM11 As Single
eM12 As Single
eM21 As Single
eM22 As Single
eDx As Single
eDy As Single
End Type
Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
Private Declare Function SetWorldTransform Lib "gdi32" (ByVal hdc As Long, lpXform As XFORM) As Long
Private Declare Function ModifyWorldTransform Lib "gdi32" (ByVal hdc As Long, lpXform As XFORM, ByVal iMode As Long) As Long
Private Const MWT_IDENTITY = 1
Private Const MWT_LEFTMULTIPLY = 2
Private Const MWT_RIGHTMULTIPLY = 3
Private Const GM_ADVANCED = 2
Private Const GM_COMPATIBLE = 1
Private Sub Form_Load()
SetGraphicsMode Me.hdc, GM_ADVANCED
End Sub
Private Sub Form_Paint()
Dim mtx1 As XFORM, mtx2 As XFORM, c As Single, s As Single, p As IPicture
ModifyWorldTransform Me.hdc, mtx1, MWT_IDENTITY
Me.Line (0, 0)-(Me.ScaleWidth, Me.ScaleHeight), Me.BackColor, BF
c = Cos(hsbAngle.Value / 100)
s = Sin(hsbAngle.Value / 100)
mtx1.eM11 = c: mtx1.eM12 = s: mtx1.eM21 = -s: mtx1.eM22 = c: mtx1.eDx = Me.ScaleWidth / 2: mtx1.eDy = Me.ScaleHeight / 2
mtx2.eM11 = 1: mtx2.eM22 = 1: mtx2.eDx = -Me.ScaleWidth / 2: mtx2.eDy = -Me.ScaleHeight / 2
SetWorldTransform Me.hdc, mtx1
ModifyWorldTransform Me.hdc, mtx2, MWT_LEFTMULTIPLY
End Sub
Private Sub hsbAngle_Change()
Me.Refresh
End Sub