****** كود فورم النار 2011 بركان ******

السلام عليكم


اليوم جبتلكم اكواد لجعل الفورم تشتعل فيه النار

في الجينيرال :

كود:



Option Explicit

Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long

Dim lToken As Long
Dim CPalRGB(255) As Long
Dim lngWidth As Long
Dim lngHeight As Long
Dim graphics As Long
Dim bitmap As Long
Dim bmpData As BitmapData
Dim rctL As RECTL
Public strCap As String
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Private Const lWidth As Long = 440
Private Const lHeight As Long = 200
Private Type GraphicLine
PixelX(lWidth) As Integer
End Type
Dim PixelY(lHeight) As GraphicLine

Dim Finished As Boolean
Dim CurrentTick, PreviousTick As Long
Dim x As Long, y As Long
Dim tempPixel As Long
Dim memPtr As Long

كود

Private Sub Form_KeyPress(KeyAscii As Integer)
Finished = True
End Sub

كود:


Private Sub Form_Load()
With Me
.ScaleMode = vbPixels
.ScaleWidth = lWidth
.ScaleHeight = lHeight
End With
Dim GPInput As GdiplusStartupInput
GPInput.GdiplusVersion = 1
If GdiplusStartup(lToken, GPInput) <> Ok Then
MsgBox "Error loading GDI+!", vbCritical
Unload Me
End If
Call GdipCreateFromHDC(Me.hDC, graphics)
Call GdipCreateBitmapFromGraphics(Me.ScaleWidth, Me.ScaleHeight, graphics, bitmap)
Call GdipGetImageHeight(bitmap, lngHeight)
Call GdipGetImageWidth(bitmap, lngWidth)
rctL.Right = 0
rctL.Top = 0
rctL.Right = lngWidth
rctL.Bottom = lngHeight
For x = 0 To 10
CPalRGB(x) = 65536 * x * 8
CPalRGB(x + 10) = 65536 * 80 - 65536 * x * 8
Next
For x = 10 To 41
CPalRGB(x) = CPalRGB(x) + (x - 10) * 8
Next
For x = 42 To 73
CPalRGB(x) = (x - 42) * 8 * 256 + 255
Next
For x = 74 To 105
CPalRGB(x) = (x - 74) * 8 * 65536 + 65280 + 255
Next
For x = 106 To 255
CPalRGB(x) = vbWhite
Next
For x = 0 To 255
CPalRGB(x) = GetRGB_VB2GDIP(CPalRGB(x))
Next
Me.Show
Finished = False
PreviousTick = GetTickCount
Do
CurrentTick = GetTickCount
If CurrentTick - PreviousTick < 20 Then
DoEvents
Else
PreviousTick = CurrentTick
For x = 0 To lngWidth - 1
PixelY(lngHeight - 3).PixelX(x) = 25 * Rnd() + 80
PixelY(lngHeight - 2).PixelX(x) = 25 * Rnd() + 80
PixelY(lngHeight - 1).PixelX(x) = 25 * Rnd() + 80
Next
For x = 0 To 40 * Rnd()
y = (lngWidth - 2) * Rnd() + 1
PixelY(lngHeight - 3).PixelX(y - 1) = 255
PixelY(lngHeight - 3).PixelX(y) = 255
PixelY(lngHeight - 3).PixelX(y + 1) = 255
PixelY(lngHeight - 2).PixelX(y - 1) = 255
PixelY(lngHeight - 2).PixelX(y) = 255
PixelY(lngHeight - 2).PixelX(y + 1) = 255
PixelY(lngHeight - 1).PixelX(y - 1) = 255
PixelY(lngHeight - 1).PixelX(y) = 255
PixelY(lngHeight - 1).PixelX(y + 1) = 255
Next
Call GdipBitmapLockBits(bitmap, rctL, ImageLockModeWrite, PixelFormat32bppARGB, bmpData)
For x = 1 To bmpData.Width - 2
For y = 90 To bmpData.Height - 3
tempPixel = (PixelY(y + 2).PixelX(x - 1) + PixelY(y + 2).PixelX(x) + PixelY(y + 2).PixelX(x + 1) + PixelY(y + 1).PixelX(x - 1) + PixelY(y + 1).PixelX(x) + PixelY(y + 1).PixelX(x + 1) + PixelY(y).PixelX(x - 1) + PixelY(y).PixelX(x + 1)) \ 8
If tempPixel > 0 Then tempPixel = tempPixel - 1
PixelY(y).PixelX(x) = tempPixel
memPtr = bmpData.scan0 + (y * bmpData.stride) + (x * 4)
PutMem4 memPtr, CPalRGB(tempPixel)
Next y
DoEvents
Next x
Call GdipBitmapUnlockBits(bitmap, bmpData)
Call GdipDrawImageRect(graphics, bitmap, 0, 0, lngWidth, lngHeight)
End If
Loop Until Finished
Unload Me
End Sub

كود:

Private Sub Form_Unload(Cancel As Integer)
Call GdipDisposeImage(bitmap)
Call GdipDeleteGraphics(graphics)
Call GdiplusShutdown(lToken)
Unload Me
Set frmFire = Nothing
End Sub