یک پروژه ی گرافیکی-اسکرین سیور
سلام
تا حالا دلتون خاسته يه اسكرين سيور بسازين
من يه برنامه بسيار جالب از اقاي 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 بزنيد .
نظر ندادنتون منو كشته