اكواد فيجوال بيسك رائعة

تم تحميل الصفحة في 1,1531455 ثانية
اكواد فيجوال بيسك رائعة
الحالة
مغلق و غير مفتوح للمزيد من الردود.
إنضم
15 مارس 2011
المشاركات
73
الإعجابات
3
النقاط
0
استخدام كود في البرنامج CMD

Call s h e l l("cmd.exe /c shutdown -l", vbNormalFocus)
حذف الفراغات بين كلمة s h e l l
===================================================
جعل البرنامج شفاف
في عام :

Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long , ByValcrKey As Long , ByVal bAlpha As Byte , ByVal dwFlags As Long) As Boolean
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long , ByVal nIndex As Long , ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long , ByVal nIndex As Long) As Long
Const LWA_ALPHA = 2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000

في كود تحميل الفورم :

Private Sub Form_Load()
SetWindowLong hwnd , GWL_EXSTYLE , GetWindowLong(hwnd , GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd , 0 , 128 , LWA_ALPHA
End Sub

====================================================
الاخفاء من التاسك :

Private Const RSP_SIMPLE_SERVICE = 1
Private Const RSP_UNREGISTER_SERVICE = 0
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" _
(ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Sub HideApp(Hide As Boolean)
Dim ProcessID As Long
ProcessID = GetCurrentProcessId()
If Hide Then
retval = RegisterServiceProcess(ProcessID, RSP_SIMPLE_SERVICE)
Else
retval = RegisterServiceProcess(ProcessID, RSP_UNREGISTER_SERVICE)
End If
End Sub

====================================================

البرنامج فوق الكل :
عام:

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private Const WM_SETHOTKEY = &H32
Private Const VK_F5 = &H74

الفورم :

Call SendMessage(Me.hwnd, WM_SETHOTKEY, VK_F5, 0)

=====================================================

عدم القدرة على اغلاق الرنامج :

Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, ByVal bRevert As Long) As Long
Declare Function GetMenuItemCount Lib "user32" _
(ByVal hMenu As Long) As Long
Declare Function DrawMenuBar Lib "user32" _
(ByVal hwnd As Long) As Long
Declare Function RemoveMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Public Const MF_BYPOSITION = &H400&
Public Const MF_REMOVE = &H1000&

الفورم :

Dim hSysMenu As Long
Dim nCnt As Long
'First, show the form
Me.Show
'Get handle to our form's system menu
'(Restore, Maximize, Move, close etc.)
hSysMenu = GetSystemMenu(Me.hwnd, False)

If hSysMenu Then
'Get System menu's menu count
nCnt = GetMenuItemCount(hSysMenu)

If nCnt Then

'Menu count is based on 0 (0, 1, 2, 3...)

RemoveMenu hSysMenu, nCnt - 1, MF_BYPOSITION Or MF_REMOVE

RemoveMenu hSysMenu, nCnt - 2, _
MF_BYPOSITION Or MF_REMOVE

DrawMenuBar Me.hwnd
'Force caption bar's ****************************. Disabling X button

Me.Caption = "Try to close me!"
End If
End If

=================================================

رسم كرة تتبع الفأرة

Me.Cls
Circle (X, Y), 100, vbRed

=================================================

غلق الفورم بشكل انزلاق لليمين ثم الاسفل

Sub SlideWindow(frmSlide As Form, iSpeed As Integer)

While frmSlide.Left + frmSlide.Width < Screen.Width

DoEvents

frmSlide.Left = frmSlide.Left + iSpeed

Wend
While frmSlide.Top - frmSlide.Height < Screen.Height

DoEvents

frmSlide.Top = frmSlide.Top + iSpeed

Wend
Unload frmSlide

End Sub


ومن ثم نضع الكود التالي للزر وطبعا تخلي اسمه إغلاق لانه راح يغلق البرنامج

Call SlideWindow(Form1, 250)

===========================================

لجعل النموذج ثلاثي الأبعاد:


Sub ThreeDForm(frmForm As Form)
Const cPi = 3.1415926
Dim intLineWidth As Integer
intLineWidth = 5
' 'save scale mode
Dim intSaveScaleMode As Integer
intSaveScaleMode = frmForm.ScaleMode
frmForm.ScaleMode = 3
Dim intScaleWidth As Integer
Dim intScaleHeight As Integer
intScaleWidth = frmForm.ScaleWidth
intScaleHeight = frmForm.ScaleHeight
' 'clear form
frmForm.Cls
' 'draw white lines
frmForm.Line (0, intScaleHeight)-(intLineWidth, 0), &HFFFFFF, BF
frmForm.Line (0, intLineWidth)-(intScaleWidth, 0), &HFFFFFF, BF
' 'draw grey lines
frmForm.Line (intScaleWidth, 0)-(intScaleWidth - intLineWidth, intScaleHeight), &H808080, BF
frmForm.Line (intScaleWidth, intScaleHeight - intLineWidth)-(0, intScaleHeight), &H808080, BF
' 'draw triangles(actually circles) at corners
Dim intCircleWidth As Integer
intCircleWidth = Sqr(intLineWidth * intLineWidth + intLineWidth * intLineWidth)
frmForm.FillStyle = 0
frmForm.FillColor = QBColor(15)
frmForm.Circle (intLineWidth, intScaleHeight - intLineWidth), intCircleWidth, QBColor(15), _
-3.1415926, -3.90953745777778 '-180 * cPi / 180, -224 * cPi / 180
frmForm.Circle (intScaleWidth - intLineWidth, intLineWidth), intCircleWidth, QBColor(15), _
-0.78539815, -1.5707963 ' -45 * cPi / 180, -90 * cPi / 180
' 'draw black frame
frmForm.Line (0, intScaleHeight)-(0, 0), 0
frmForm.Line (0, 0)-(intScaleWidth - 1, 0), 0
frmForm.Line (intScaleWidth - 1, 0)-(intScaleWidth - 1, intScaleHeight - 1), 0
frmForm.Line (0, intScaleHeight - 1)-(intScaleWidth - 1, intScaleHeight - 1), 0
frmForm.ScaleMode = intSaveScaleMode
End Sub

Private Sub Form_Paint()
ThreeDForm Me

End Sub

================================

خلفية متدرجة للفورم مثل برنامج الاعداد


Sub Fade(vForm As Form)
Dim intLoop As Integer
vForm.DrawStyle = vbInsideSolid
vForm.DrawMode = vbCopyPen
vForm.ScaleMode = vbPixels
vForm.DrawWidth = 2
vForm.ScaleHeight = 256
For intLoop = 0 To 255
'&Icirc;&aacute;&Yacute;&iacute;&Eacute; &atilde;&Ecirc;&Iuml;&Ntilde;&Igrave;&Eacute; &Egrave;&Ccedil;&aacute;&aacute;&aelig;&auml; &Ccedil;&aacute;&Atilde;&Ograve;&Ntilde;&THORN;
vForm.Line (0, intLoop)-(Screen.Width, intLoop - 1), RGB(0, 0, 255 - intLoop), B
Next intLoop
End Sub
Private Sub Form_Activate()
Fade Me
End Sub

خلفية النموذج بألوان قوس قزح :

Option Explicit


Private Sub Form_Load()
Me.AutoRedraw = True
Me.ScaleMode = vbTwips
Me.Caption = "Rainbow Generator by " & _
"K. O. Thaha Hussain"
MsgBox "Resize the window To resize the Rainbow", , _
"Thaha Hussain's Rainbow Generator"
End Sub


Private Sub Form_Resize()
Call Rainbow
End Sub


Private Sub Rainbow()
On Error Resume Next
Dim Position As Integer, Red As Integer, Green As _
Integer, Blue As Integer
Dim ScaleFactor As Double, Length As Integer
ScaleFactor = Me.ScaleWidth / (255 * 6)
Length = Int(ScaleFactor * 255)
Position = 0
Red = 255
Blue = 1
'Purposfully avoided nested loops
'------------- 1


For Green = 1 To Length
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red, Green \ ScaleFactor, Blue)
Position = Position + 1
Next Green
'--------------- 2


For Red = Length To 1 Step -1
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red \ ScaleFactor, Green, Blue)
Position = Position + 1
Next Red
'---------------- 3


For Blue = 0 To Length
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red, Green, Blue \ ScaleFactor)
Position = Position + 1
Next Blue

'----------------- 4


For Green = Length To 1 Step -1
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red, Green \ ScaleFactor, Blue)
Position = Position + 1
Next Green

'------------------ 5


For Red = 1 To Length
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red \ ScaleFactor, Green, Blue)
Position = Position + 1
Next Red
'------------------- 6


For Blue = Length To 1 Step -1
Me.Line (Position, 0)-(Position, Me.ScaleHeight), _
RGB(Red, Green, Blue \ ScaleFactor)
Position = Position + 1
Next Blue
End Sub

=====================================

لعمل النوذج رخامي

'&Ouml;&Uacute; &aring;&ETH;&Ccedil; &Ccedil;&aacute;&szlig;&aelig;&Iuml; &Yacute;&iacute; &THORN;&Oacute;&atilde; &Ccedil;&aacute;&Ecirc;&Otilde;&Ntilde;&iacute;&Ia cute;&Ccedil;&Ecirc; General
Private Sub GradientFill()
Dim i As Long
Dim c As Integer
Dim r As Double
r = ScaleHeight / 3.142
For i = 0 To ScaleHeight
c = Abs(220 * Sin(i / r))
Me.Line (0, i)-(ScaleWidth, i), RGB(c, c, c + 30) 'Notice the bias To blue. You can be more subtle by reducing this number (try 10). Try other colours too.
Next
End Sub
'&aelig;&aring;&ETH;&Ccedil; &Ccedil;&aacute;&szlig;&aelig;&Iuml; &Yacute;&iacute; &Iacute;&Iuml;&Euml; Resize &aacute;&aacute;&Yacute;&aelig;&Ntilde;&atilde;


Private Sub Form_Activate()
GradientFill
End Sub

=====================================


مؤثر رائع عللى الفورم :

Function Dist(x1, y1, x2, y2) As Single
Dim A As Single, B As Single
A = (x2 - y1) * (x2 - x1)
B = (y2 - y1) * (y2 - y1)
Dist = Sqr(A + B)
End Function
Sub MoveIt(A, B, t)
A = (1 - t) * A + t * B
End Sub

Private Sub Form_Click()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub

Private Sub Form_Resize()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub


==========================================

نموذج دائري الأطراف :

Private Declare Function CreateRoundRectRgn Lib "gdi32.dll" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long 'MODULE 1152
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

'v is the size of the top corners and w is the size of the bottom corners...

Sub RoundRect(ByVal uObject As Object, ByVal v As Long, ByVal w As Long)
Dim lRight As Long
Dim lBottom As Long
Dim hRgn As Long
With uObject
lRight = .Width / Screen.TwipsPerPixelX
lBottom = .Height / Screen.TwipsPerPixelY
hRgn = CreateRoundRectRgn(0, 0, lRight, lBottom, v, w)
SetWindowRgn .hWnd, hRgn, True
End With
End Sub
Private Sub Form_Load()
RoundRect Me, 40, 40 'Leave it on 40.
End Sub

:32::32::32::32::32::32::32::32::32::32::32::32:

:8: الرجاء التقييييم :8:
 

iGlal

أبو إياد
rankrankrankrankrankrank
إنضم
31 ديسمبر 2007
المشاركات
3,431
الإعجابات
634
النقاط
113
الإقامة
مصر
رد: اكواد فيجوال بيسك رااااائعة

والله يااخى نفسى أتعلمه بطريقة سهلة ... بقالى أسبوع بنزل بأسطوانات لكن ملل :30:

شكرا لك وينقل لقسمه المناسب
 
إنضم
29 مايو 2009
المشاركات
5,238
الإعجابات
531
النقاط
0
العمر
32
رد: اكواد فيجوال بيسك رااااائعة

والله يااخى نفسى أتعلمه بطريقة سهلة ... بقالى أسبوع بنزل بأسطوانات لكن ملل :30:

شكرا لك وينقل لقسمه المناسب

" وْ آلله آنك صصآدق آنـآ عندي آسطوآنـآت لليل ~}ْ
لكن لو آششوف آلشرح يووهـ عـآد لو آلشرح فيه وْآحد يقرقر هههـ ْ~
آكوآد ممتـآزه خصوصآ آلشفآفيه
ششكرآ لك }~ْ


:32:
 

dimah

شبح المغرب
rankrankrankrank
إنضم
5 سبتمبر 2010
المشاركات
1,365
الإعجابات
247
النقاط
63
رد: اكواد فيجوال بيسك رائعة

:32:أكواد روعة يا بطل :8:
 
إنضم
2 فبراير 2010
المشاركات
1,813
الإعجابات
162
النقاط
63
رد: اكواد فيجوال بيسك رائعة

يع ـطيك الع ـآفيه ع الطرح

آكوآد رآئع ـه

:9:
 
إنضم
3 نوفمبر 2007
المشاركات
3,614
الإعجابات
683
النقاط
113
رد: اكواد فيجوال بيسك رائعة

يعطيك العافيه يابعدي

لاكن فيه مكتبة اكواد
تضف الاكواد فيها
بعد اذنك واذن الجميع ينقل ,

 
الحالة
مغلق و غير مفتوح للمزيد من الردود.

الأعضاء النشطين حاليآ الذين يشاهدون هذا الموضوع (1 عضو و 0 ضيف)

خيارات الاستايل

نوع الخط
مودك
اخفاء السايدر بار OFF
توسيط المنتدى OFF
فصل الأقسام OFF
الأقسام الفرعية OFF
عرض المشاركات
حجم الخط
معلومات العضو OFF
إخفاء التوقيع OFF

إرجاع خيارات الإستايل