/ در آموزش ویژوالبیسیک, اشتراک رایگان, ویژوالبیسیک / توسط
آخرین زمان ویرایش:

مجموعه سورس کدهای ویژوالبیسیک ۶ قسمت ۱۴

جهت مطالعه و دسترسی به سورس ها به ادامه مطلب مراجعه نمائید

افکت روی عکس

خب ببینم امروز چی داریم یه برنامه برای ایجاد افکت روی عکس یعنی وقتی یه عکس داره تبدیل می شه به عکس دومی به شکل
زیبایی محو بشه.خب برای هر چیز قشنگی باید زحمت کشید
پس با جدیت شروع کنید تو کادر عکس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آن را به۵۶و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

نوشته های مشابه

مجموعه سورس کدهای ویژوالبیسیک ۶ قسمت ۱۳

جهت مطالعه و دسترسی به سورس ها به ادامه مطلب مراجعه نمائید (بیشتر…)

مجموعه سورس کدهای ویژوالبیسیک ۶ قسمت ۱۵

جهت مطالعه و دسترسی به سورس ها به ادامه مطلب مراجعه نمائید (بیشتر…)

 کانال تلگرام داده باران شارژ آنلاین

نظری بدهید

نشانی ایمیل شما منتشر نخواهد شد. بخش‌های موردنیاز علامت‌گذاری شده‌اند *