سلام

تا حالا دلتون خاسته يه اسكرين سيور بسازين

من يه برنامه بسيار جالب از اقاي Alexander Anikin به آدرس http://www.poshuk.com/pegas/index.htm دارم كه در اون يه اسكرين سيور بسيار زيبا ايجاد مي شه حالا اگه حوصله كنيد براتون كدش رو توضيح مي دم

دو تا PictureBox با دو تا تايمر ايجاد كنيد .خاصيت Autoredraw دو تا عكس و فرم رو true كنيد

خاصيت Interval تايمر اولي رو1و دومي رو 1000كنيد

در خط اول كد فرم توابع زير ور تعريف كنيد

'Copyright © 2000 by Alexander Anikin

'e-mail: pegas@poshuk.com

'http://www.poshuk.com/pegas/index.htm

Option Explicit

Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long

Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function BitBlt _

Lib "gdi32" ( _

ByVal hDestDC As Long, _

ByVal x As Long, ByVal y As Long, _

ByVal nWidth As Long, _

ByVal nHeight As Long, _

ByVal hSrcDC As Long, _

ByVal XSrc As Long, ByVal YSrc As Long, _

ByVal dwRop 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 SWP_NOSIZE = &H1

Private Const SWP_NOMOVE = &H2

Private Const HWND_TOPMOST = -1

Dim a(47) As Integer

Dim b(47) As Integer

Dim xxx As Integer

Dim yyy As Integer

Dim e As Integer

Dim ScrW As Integer, ScrH As Integer

Private Sub TrueOnTop(myForm As Object)

SetWindowPos myForm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE

End Sub

براي اينكه كاربر هر كاري كرد برنامه سريع خارج بشه بايد در رويداد KeyDown-MouseDown بنويسيد

Unload Me

در كد فرم لواد بنويسيد

If App.PrevInstance = True Then Unload Me

Dim x

TrueOnTop Form1

With Picture1(48)

.BorderStyle = 1

.AutoRedraw = True

.Visible = False

End With

Me.AutoRedraw = True

Dim Bo As Boolean

Call BitBlt(hDC, 0, 0, Screen.Width, _

Screen.Height, GetDC(0&), 0, 0, vbSrcCopy)

Picture2.Width = Screen.Width

Picture2.Height = Screen.Height

Picture2 = Image

ScrW = Screen.Width \ 8

ScrH = Screen.Height \ 6

Picture1(48).Width = ScrW

Picture1(48).Height = ScrH

Dim l As Integer, t As Integer

l = 0

t = 0

For e = 0 To 47

Bo = Not Bo

If Bo = True Then

a(e) = 15

b(e) = 15

Else

a(e) = -15

b(e) = -15

End If

Load Picture1(e)

Picture1(e).Left = l

Picture1(e).Top = t

l = l + ScrW: If l > Screen.Width - ScrW Then l = 0: t = t + ScrH: Bo = Not Bo

Picture1(e).PaintPicture Picture2.Picture, 0, 0, ScrW, ScrH, ScrW * xxx, ScrH * yyy, ScrW, ScrH, vbSrcCopy

xxx = xxx + 1: If xxx = 8 Then xxx = 0: yyy = yyy + 1

DoEvents

Next e

For e = 0 To 47

Picture1(e).Visible = True

Next e

x = ShowCursor(False)

Cls

Timer1.Enabled = True

Timer2.Enabled = True

كد MouseMove فرم

Static X0 As Integer, Y0 As Integer '------------------------------

If ((X0 = 0) And (Y0 = 0)) Or _

((Abs(X0 - x) < 45) And (Abs(Y0 - y) < 45)) Then ' small mouse movement...

X0 = x ' Save current x coordinate

Y0 = y ' Save current y coordinate

Exit Sub ' Exit

End If

Unload Me ' Large mouse movement (terminate screensaver)

كد رويداد تايمر تايمر اولي

LockWindowUpdate Me.hwnd

For e = 0 To 47

Picture1(e).Move Picture1(e).Left + a(e), Picture1(e).Top + b(e)

If Picture1(e).Left > Screen.Width - ScrW Then a(e) = -a(e)

If Picture1(e).Left < 0 Then a(e) = -a(e)

If Picture1(e).Top > Screen.Height - ScrH Then b(e) = -b(e)

If Picture1(e).Top < 0 Then b(e) = -b(e)

DoEvents

Next e

LockWindowUpdate False

كد همون رويداد براي تايمر دومي

Enabled = True

Timer2.Enabled = False

و بلاخره كد Form_Unload

Dim x

x = ShowCursor(True)

End

شايد به محض اجرا شدن برنامه از برنامه خارج شويد .شما بايد يك نسخه اجرايي از برنامه روي دكستاپ ايجاد كنيد و بعد برنامه رو اجرا كنيد .اگه بازم به محض ورود از برنامه خارج شديد Unload Me ها رو پاك كنيد ولي يك دكمه براي خروج از فرم ايجاد كنيد.

نكته:براي ايجاد نسخه اجرايي از پروژه از منوي فايل گزينه Make Project1.exe بزنيد .

نظر ندادنتون منو كشته