برنامج "عين القطة" Cat eye

الأحد ديسمبر 25, 2011 3:50 pm

البرنامج عبارة عن عين و تضع خلفها اي صورة و في المثال يوجد شكل قطة بالخلف
لتبدو كأنها عين لهذه القطة

برنامج "عين القطة" Cat eye Test2

و هذه الصورة قبل تصميم الكود
و هنا ترون إلي ماذا نحتاج من أدوات و هي :-
Form1
Timer1

و هذا البرنامج هو توضيح لإمكانيات الماوس و كيف نستطيع أن نتحكم في أي برنامج أو جهاز بالماوس
من خلال برنامج الفيجوال بيسك

برنامج "عين القطة" Cat eye Test

و هذه الصورة بعد عمل البرنامج و صنعه و تبين كيف أن العين تأتي علي شكل القطة تماماً
سنحتاج في هذا المشروع بجانب الفورمة ClassModules و سيتم تسميتها cTrimmer
و أيضاً الفورم سيتم تسميته fMouseWatch ، و سيتم تسمية التايمر tmr

و الأن مع الأكواد :-
ستنقل هذا الكود في الفورم :-

Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As tPOINT) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As tRECT) As Long
Private Declare Sub 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)
Private Const SWP_NOACTIVATE As Long = 16
Private Const SWP_NOSIZE As Long = 1
Private Const SWP_NOMOVE As Long = 2
Private Const SWP_COMBINED As Long = SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
Private Const SWP_TOPMOST As Long = -1

Private Type tPOINT
X As Long
Y As Long
End Type

Private Type tRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Trimmer As New cTrimmer

Private CursorPos As tPOINT
Private WindowRect As tRECT

Private LeftEye As tPOINT
Private RightEye As tPOINT
Private LeftDistance As Double
Private RightDistance As Double

Private LeftSin As Double
Private LeftCos As Double
Private RightSin As Double
Private RightCos As Double

'eye properties
Private Const LX As Long = 31
Private Const RX As Long = 55
Private Const BY As Long = 27
Private Const EyeBackColor As Long = &HFFF8F8
Private Const PupilColor As Long = vbBlue
Private Const PupilRad As Single = 3
Private Const MoveRad As Single = 3
Private Const EyeRad As Single = PupilRad + MoveRad + 1
Private Sub Form_DblClick()
Unload Me
End Sub

Private Sub Form_Load()

Trimmer.TrimForm Me
SetWindowPos hWnd, SWP_TOPMOST, 0, 0, 0, 0, SWP_COMBINED

End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = vbLeftButton Then
Trimmer.GrabForm Me
End If

End Sub

Private Sub tmr_Timer()

GetWindowRect hWnd, WindowRect

With WindowRect
LeftEye.X = .Left + LX
LeftEye.Y = .Top + BY
RightEye.X = .Left + RX
RightEye.Y = .Top + BY
End With

GetCursorPos CursorPos

With CursorPos
LeftDistance = Sqr((LeftEye.X - .X) ^ 2 + (LeftEye.Y - .Y) ^ 2)
RightDistance = Sqr((RightEye.X - .X) ^ 2 + (RightEye.Y - .Y) ^ 2)
If LeftDistance = 0 Then
LeftDistance = 1
End If
If RightDistance = 0 Then
RightDistance = 1
End If
LeftSin = (LeftEye.Y - .Y) / LeftDistance
LeftCos = (LeftEye.X - .X) / LeftDistance
RightSin = (RightEye.Y - .Y) / RightDistance
RightCos = (RightEye.X - .X) / RightDistance
End With 'CURSORPOS

'draw eyes
FillColor = EyeBackColor
Circle (LX, BY), EyeRad, vbBlack
Circle (RX, BY), EyeRad, vbBlack
FillColor = vbBlack
Circle (LX - MoveRad * LeftCos, BY - MoveRad * LeftSin), PupilRad, PupilColor
Circle (RX - MoveRad * RightCos, BY - MoveRad * RightSin), PupilRad, PupilColor

End Sub
__________

و الأن ستنقل هذا الكود في الكلاس :-

Option Explicit

Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_NCLBUTTONDOWN As Long = &HA1
Private Const HTCAPTION As Long = 2

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_OR As Long = 2
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private TotalRegion As Long
Private PartRegion As Long

Private Sub AddRegion(ByRef Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long)

PartRegion = CreateRectRgn(Left, Top, Right, Bottom)
CombineRgn TotalRegion, TotalRegion, PartRegion, RGN_OR
DeleteObject PartRegion
Left = -1

End Sub

Public Sub GrabForm(Frm As Form)

ReleaseCapture
SendMessage Frm.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&

End Sub

Public Sub TrimForm(Frm As Form)

Dim X As Long
Dim SavedX As Long
Dim Y As Long
Dim TransparentColor As Long
Dim BackgroundColor As Long
Dim SavedSM As Long
Dim SavedAR As Boolean

With Frm
If .Picture Then

SavedSM = .ScaleMode
SavedAR = .AutoRedraw
.AutoRedraw = True
.ScaleMode = vbPixels

TransparentColor = .Point(0, 0)
BackgroundColor = .BackColor
If BackgroundColor < 0 Then
BackgroundColor = GetSysColor(BackgroundColor And &H7FFFFFFF)
End If

TotalRegion = CreateRectRgn(0, 0, 0, 0)
SavedX = -1

For Y = 0 To .ScaleHeight - 1
For X = 0 To .ScaleWidth - 1
Select Case .Point(X, Y)
Case BackgroundColor
Exit For
Case TransparentColor
If SavedX > -1 Then
AddRegion SavedX, Y, X, Y + 1
End If
Case Else
If SavedX = -1 Then
SavedX = X
End If
End Select
Next X
If SavedX > -1 Then
AddRegion SavedX, Y, X, Y + 1
End If
Next Y

SetWindowRgn .hWnd, TotalRegion, True
DeleteObject TotalRegion

.ScaleMode = SavedSM
.AutoRedraw = SavedAR

End If
End With

End Sub
__________

و لتدرس المشروع أفضل يمكنك تحميله من هـنــــــــــــــــــــــــا
__________

الصفحة الرئيسية لهذا الموضوع
__________