آموزش ویژوال بیسیک و برنامه نویسی
سورس,ویژوال بیسیک,نرم افزار,باشگاه,بدنسازی,فوتبال,آنالیز,پیش بینی,کد,برنامه نویسیآموزش ویژوال بیسیک و برنامه نویسی
سورس,ویژوال بیسیک,نرم افزار,باشگاه,بدنسازی,فوتبال,آنالیز,پیش بینی,کد,برنامه نویسیافکت روی عکس
خب ببینم امروز چی داریم یه برنامه برای ایجاد افکت روی عکس یعنی وقتی یه عکس داره تبدیل می شه به عکس دومی به شکل
زیبایی محو بشه.خب برای هر چیز قشنگی باید زحمت کشید
پس با جدیت شروع کنید تو کادر عکسPictureبه فرم اضافه کنید سپس
خاصیتAutoReDrawعکس اولیه روTrueودومیه رو Falseکنید تا تصویر بعد از طراحی باقی بمونه
ویک دکمه که باید بازدن اون افکت اجرا بشه.یه ماژول اضافه کنید و کد زیر رو براش بنویسید
دو تا عکس به سلیقه خودتون داخل کادر عکس ها بندازید سعی کنید هم اندازه باشند
در خط اول کد های فرم کد های زیر رو بنویسید
Option Explicit
Dim hBrush As Variant
Dim PixelSetSequence(64) As Integer
Dim DissolveStep As Long
Const NumberOfSteps = 8'--------------------------------------
Private Function CreateDissolveBrush(DissolveStep As Long) As Long
Dim hCompBitmap As Long
Dim BrushBitmapInfo As BITMAPINFO
Dim Counter As Integer
Dim PixelData As String * 32
Dim Dummy As Long
Dim Row As Integer
Dim Column As Integer
With BrushBitmapInfo.bmiHeader
.biSize = 40
.biWidth = 8
.biHeight = 8
.biPlanes = 1
.biBitCount = 1
.biCompression = 0
.biSizeImage = 0
.biXPelsPerMeter = 0
.biYPelsPerMeter = 0
.biClrUsed = 0
.biClrImportant = 0
End With
' Set the color table values for
' the brush to black and white.
With BrushBitmapInfo.bmiColors(0)
.rgbBlue = 0
.rgbGreen = 0
.rgbRed = 0
.rgbReserved = 0
End With
With BrushBitmapInfo.bmiColors(1)
.rgbBlue = 255
.rgbGreen = 255
.rgbRed = 255
.rgbReserved = 0
End With
' Initialize brush bitmap pixel data to all white.
For Counter = 0 To 7
Mid$(PixelData, Counter * 4 + 1, 1) = Chr$(&HFF)
Next Counter
' Set the bits representing the black pixels to 0.
For Counter = 1 To DissolveStep * (64 / NumberOfSteps)
Row = (PixelSetSequence(Counter) - 1) 8
Column = (PixelSetSequence(Counter) - 1) Mod 8
Mid$(PixelData, Row * 4 + 1, 1) = Chr$(Asc(Mid$(PixelData, Row * 4 + 1, 1)) And (Not (2 ^ Column)))
Next Counter
' Convert the DIB into a DDB and create the pattern brush.
hCompBitmap = CreateDIBitmap(Disolve1.hDC, BrushBitmapInfo.bmiHeader, CBM_INIT, PixelData, BrushBitmapInfo, DIB_RGB_COLORS)
CreateDissolveBrush = CreatePatternBrush(hCompBitmap)
Dummy = DeleteObject(hCompBitmap)
End Function'------------------------------------------------
Private Sub Picture2_Paint()
Dim hRgn As Long
Dim Dummy As Long
Dim hOldBrush As Long
hBrush = CreateDissolveBrush(DissolveStep)
hOldBrush = SelectObject(Picture2.hDC, hBrush)
Dummy = BitBlt(Picture2.hDC, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, Picture1.hDC, 0, 0, &HAC0744)
'Dummy = StretchBlt%(Picture2.hDC, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, Picture1.hDC, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, &HAC0744)
Dummy = SelectObject(Picture2.hDC, hOldBrush)
Dummy = DeleteObject(hBrush)
End Sub'-----------------------------------
Private Sub CreatePixelSetSequence()
Dim Counter As Integer
Dim PixelNumberString As String * 5
Const PixelListFile = 1
Open App.Path & "PixelLst.TXT" For Input As #PixelListFile
For Counter = 1 To 64
Input #PixelListFile, PixelNumberString
PixelSetSequence(Counter) = Val(PixelNumberString)
Next Counter
End Sub'------------------------
حالا یه تایمر به فرم اضافه کنید و خاصیتIntervalآن را به56وEnabledآن را به Falseتغییر دهید
وبه ترتیب برای دکمه ها کد های زیر را بنویسید
رویداد کلیک دکمه
Command1.Enabled = False
Timer1.Enabled = True
رویداد لواد فرم
CreatePixelSetSequence
DissolveStep = 0
رویداد کلیک عکس دومی
If DissolveStep < NumberOfSteps Then
DissolveStep = DissolveStep + 1
Picture2_Paint
End If
روداد تایمر کنترل تایمر
If DissolveStep < NumberOfSteps Then
DissolveStep = DissolveStep + 1
Picture2_Paint
Else
Timer1.Enabled = False
End If
End Sub
