مرحبا بكم فى موقعكم التعليمى مفيدا ومستفيدا

تعلم معى بالتمرين خطوة خطوة -2

استعرض الموضوع السابق استعرض الموضوع التالي اذهب الى الأسفل

تعلم معى بالتمرين خطوة خطوة -2

مُساهمة من طرف sayed في الخميس أكتوبر 20, 2011 12:08 am

تحويل اي حرف إلى حرف ASCII
*كود برمجي*


--------------------------------------------------------------------------------
كود:
Dim temp as String
temp=asc(text1.text)
MsgBox temp
--------------------------------------------------------------------------------


تحيه حسب الوقت
*كود برمجي*


--------------------------------------------------------------------------------


كود:
Private Sub Form_Load()


If Time <= "11:30 AM" Then
MsgBox ("Good Morning YourNameHere!")
End
End If


If Time > "11:30 AM" And Time < "5:00 PM" Then
MsgBox ("Good Afternoon YourNameHere!")
End
End If


If Time > "5:00 PM" Then
MsgBox ("Good Evening YourNameHere!")
End
End If


If Time >= "12:01 AM" Then
MsgBox ("Good Morning YourNameHere!")
End
End If
End Sub
--------------------------------------------------------------------------------


نوعية القرص (قرص مرن،سي دي،.....)
*كود برمجي*


--------------------------------------------------------------------------------
كود:
'التصاريح
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Const DRIVE_CDROM = 5
Public Const DRIVE_FIXED = 3
Public Const DRIVE_RAMDISK = 6
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_REMOVABLE = 2


'الكود
Dim strDrive As String
Dim strMessage As String
Dim intCnt As Integer


For intCnt = 65 To 86
strDrive = Chr(intCnt)


Select Case GetDriveType(strDrive + ":")
Case DRIVE_REMOVABLE
rtn = "Floppy Drive"
Case DRIVE_FIXED
rtn = "Hard Drive"
Case DRIVE_REMOTE
rtn = "Network Drive"
Case DRIVE_CDROM
rtn = "CD-ROM Drive"
Case DRIVE_RAMDISK
rtn = "RAM Disk"
Case Else
rtn = ""
End Select


If rtn <> "" Then
strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn
End If
Next intCnt
MsgBox (strMessage)
--------------------------------------------------------------------------------


مؤثر على الفورم
*كود برمجي*


--------------------------------------------------------------------------------
كود:
Public Sub Pause(Duration As Long)
'//i didn't write this so i can't docume
' nt it
Dim Current As Long
Current = Timer


Do Until Timer - Current >= Duration


DoEvents
Loop
End Sub


Public Sub SlideRight(FirstForm As Form, SecondForm As Form)
'//the second form is the one that does
' the transition
SecondForm.Show '//show the form
SecondForm.Top = FirstForm.Top '//make the .Top equal for both form
SecondForm.Height = FirstForm.Height '//make the .Height equal
SecondForm.Width = FirstForm.Width '//make the .Width equal
SecondForm.Left = SecondForm.Width * -1 '//make .Left negative


Do Until SecondForm.Left = 0
'//do the loop until the form is all the
' way to the right
SecondForm.Left = SecondForm.Left + 15 '//add 15 (duh)
Pause 0.3 '//pause
Loop
End Sub


Public Sub SlideDown(FirstForm As Form, SecondForm As Form)
'//the second form is the one that does
' the transition
SecondForm.Show '//show the form
SecondForm.Top = FirstForm.Height * -1 'make .Top negative
SecondForm.Height = FirstForm.Height '//make the .Height equal
SecondForm.Width = FirstForm.Width '//make the .Width equal
SecondForm.Left = FirstForm.Left '//make the .Left equal


Do Until SecondForm.Top = 0
'//do the loop until the form is all the
' way to the bottom
SecondForm.Top = SecondForm.Top + 15
Pause 0.3
Loop
End Sub


Public Sub SlideLeft(FirstForm As Form, SecondForm As Form)
'//the second form is the one that does
' the transition
SecondForm.Show
SecondForm.Top = FirstForm.Top
SecondForm.Height = FirstForm.Height
SecondForm.Width = FirstForm.Width
SecondForm.Left = FirstForm.Width '//put on right side of screen


Do Until SecondForm.Left = 0
SecondForm.Left = SecondForm.Left - 15
Pause 0.3
Loop
End Sub


Public Sub SlideUp(FirstForm As Form, SecondForm As Form)
'//the second form is the one that does
' the transition
SecondForm.Show
SecondForm.Top = FirstForm.Height '//put form to bottom of screen
SecondForm.Height = FirstForm.Height
SecondForm.Width = FirstForm.Width
SecondForm.Left = FirstForm.Left


Do Until SecondForm.Top = 0
SecondForm.Top = SecondForm.Top - 15
Pause 0.3
Loop
End Sub
--------------------------------------------------------------------------------


فورم دائري
*كود برمجي*


--------------------------------------------------------------------------------
كود:
Sub formcircle (frm As Form, Size As Integer)


For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left - e%
frm.Top = frm.Top + (Size% - e%)
Next e%


For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left + (Size% - e%)
frm.Top = frm.Top + e%
Next e%


For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left + e%
frm.Top = frm.Top - (Size% - e%)
Next e%


For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left - (Size% - e%)
frm.Top = frm.Top - e%
Next e%
End Sub
--------------------------------------------------------------------------------


تنزيل ملف من الانترنت
*كود برمجي*


--------------------------------------------------------------------------------
كود:
'التصاريح
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long


Public Function DownloadFile(URL As String, _
LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function


'الكود
G = DownloadFile("UrlOfTheFileToDownload", "c:\windows\desktop\FileName.htm")
--------------------------------------------------------------------------------


أسماء المجلدات الرئيسية والفرعية في قائمة
*كود برمجي*


--------------------------------------------------------------------------------
كود:
'التصاريح
Sub Listdir(path)
Dim d(1000)
Dir1.path = path


For lop = 0 To Dir1.ListCount - 1
d(cnt) = Dir1.List(lop)
cnt = cnt + 1
Next lop


For lop = 0 To cnt - 1
List1.AddItem d(lop)
cur_depth = cur_depth + 1
listdir d(lop)
Next lop
cur_depth = curr_depth - 1
End Sub

'الكود
Listdir(اسم المجلد)
--------------------------------------------------------------------------------


كلام متحرك في TITLEBAR
*كود برمجي*


--------------------------------------------------------------------------------
كود:
Private Sub Timer1_Timer()
On Error Resume Next
If Val(Timer1.Tag) < Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
Me.Caption = Right(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag))
Timer1.Tag = Val(Timer1.Tag) + 1


If Me.Caption = "" Then
If Val(Timer1.Tag) > Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
Me.Caption = Left(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag))
Timer1.Tag = Val(Timer1.Tag) + 1
End If
End Sub


Private Sub Form_Load()
Timer1.Enabled = True
End Sub
--------------------------------------------------------------------------------


فتح وغلق سواقة الأقراص
*كود برمجي*


--------------------------------------------------------------------------------
كود:
Private Declare Function mciSendString Lib "winmm.dll" _
Alias "mciSendStringA" _
(ByVal lpstrCommand As String, _
ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long



Public Sub EjectCD()
Call mciSendString("set CDAudio Door Open Wait", 0&, 0&, 0&)
bopen = True
End Sub


Public Sub CloseCD()
Call mciSendString("set CDAudio Door Closed Wait", 0&, 0&, 0&)
bopen = False
End Sub

'لفتح السواقة EjectCD
'لغلق السواقة CloseCD
--------------------------------------------------------------------------------


مؤثر حلو على الفورم
*كود برمجي*


--------------------------------------------------------------------------------
كود:
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
--------------------------------------------------------------------------------
اجعل برنامجك فوق الجميع always on top
*كود برمجي*


--------------------------------------------------------------------------------
كود:
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_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean)
Dim lR As Long
If bSetOnTop Then
lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End If
End Sub

Private Sub Form_Load()
SetOnTop Form1.hwnd, True
End Sub

--------------------------------------------------------------------------------


هذا الكود لمنع تشغيل أكثر من نسخة من برنامجك
*كود برمجي*


--------------------------------------------------------------------------------
كود:
Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
Unload Me
Exit Sub
End If
End Sub
--------------------------------------------------------------------------------


بمجرد الكتابة في مربع النص يتم تحديد العنصر المطابق في صندوق القائمة Autocomplete
*كود برمجي*


--------------------------------------------------------------------------------
كود:
'أضف مربعي نص وقائمة(لست بوكس)

Const LB_FINDSTRING = &H18F
Private Declare Function SendMessage Lib "User32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Integer, _
ByVal wParam As Integer, lParam As Any) As Long
Private Sub Form_Load()
List1.Clear
List1.AddItem "abcd": List1.AddItem "acbd"
List1.AddItem "bcde": List1.AddItem "bdef"
List1.AddItem "cdef": List1.AddItem "cfde"
Text1.Text = ""
End Sub
Private Sub Text1_Change()
List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal Text1.Text)
End Sub
--------------------------------------------------------------------------------


أيضا يمكنك باستخدام الكود التالي معرفة عدد الكلمات في مربع النص
*كود برمجي*


--------------------------------------------------------------------------------


كود:
Public Function GetWordCount(ByVal Text As String) As Long
Text = Trim(Replace(Text, "-" & vbNewLine, ""))
'Replace new lines with a single space
Text = Trim(Replace(Text, vbNewLine, " "))
'Collapse multiple spaces into one single space
Do While Text Like "* *"
Text = Replace(Text, " ", " ")
Loop
'Split the string and return counted words
GetWordCount = 1 + UBound(Split(Text, " "))
End Function
--------------------------------------------------------------------------------


تعتبر هذه الدالة مهمة جدا وسهلة الاستخدام لمعرفة الفرق بيت توقيتين محددين ( تاريخ أو وقت)
*كود برمجي*


--------------------------------------------------------------------------------
كود:
diff= DateDiff("d", "22/1/2001", "22/1/2002")
--------------------------------------------------------------------------------


تأجيل تنفيذ الكود لفترة معينة
*كود برمجي*


--------------------------------------------------------------------------------
كود:
Public Sub Delay(HowLong As Date)
TempTime = DateAdd("s", HowLong, Now)
While TempTime > Now
DoEvents
Wend
End Sub

Private Sub Command1_Click()
Delay 5
MsgBox "test"
End Sub
avatar
sayed
Admin

عدد المساهمات : 190
تاريخ التسجيل : 10/10/2011
العمر : 62
الموقع : computer.hooxs.com

http://computer.hooxs.com

الرجوع الى أعلى الصفحة اذهب الى الأسفل

استعرض الموضوع السابق استعرض الموضوع التالي الرجوع الى أعلى الصفحة


 
صلاحيات هذا المنتدى:
لاتستطيع الرد على المواضيع في هذا المنتدى