برنامج "عين القطة" Cat eye
الأحد ديسمبر 25, 2011 3:50 pm
البرنامج عبارة عن عين و تضع خلفها اي صورة و في المثال يوجد شكل قطة بالخلف
لتبدو كأنها عين لهذه القطة
و هذه الصورة قبل تصميم الكود
و هنا ترون إلي ماذا نحتاج من أدوات و هي :-
Form1
Timer1
و هذا البرنامج هو توضيح لإمكانيات الماوس و كيف نستطيع أن نتحكم في أي برنامج أو جهاز بالماوس
من خلال برنامج الفيجوال بيسك
و هذه الصورة بعد عمل البرنامج و صنعه و تبين كيف أن العين تأتي علي شكل القطة تماماً
سنحتاج في هذا المشروع بجانب الفورمة 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
__________
و لتدرس المشروع أفضل يمكنك تحميله من هـنــــــــــــــــــــــــا
__________
الصفحة الرئيسية لهذا الموضوع
__________
لتبدو كأنها عين لهذه القطة
و هذه الصورة قبل تصميم الكود
و هنا ترون إلي ماذا نحتاج من أدوات و هي :-
Form1
Timer1
و هذا البرنامج هو توضيح لإمكانيات الماوس و كيف نستطيع أن نتحكم في أي برنامج أو جهاز بالماوس
من خلال برنامج الفيجوال بيسك
و هذه الصورة بعد عمل البرنامج و صنعه و تبين كيف أن العين تأتي علي شكل القطة تماماً
سنحتاج في هذا المشروع بجانب الفورمة 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
__________
و لتدرس المشروع أفضل يمكنك تحميله من هـنــــــــــــــــــــــــا
__________
الصفحة الرئيسية لهذا الموضوع
__________
صلاحيات هذا المنتدى:
لاتستطيع الرد على المواضيع في هذا المنتدى