5 أكواد لجميع المبرمجبن

[Aboud Aboud]

:1
عرض صندوق حوار Open With لملف معين "C:\Abd.txt"

Private Sub Command1_Click()
Dim x As Long
x = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL C:\Abd.txt")
End Sub

-----------------------------------------
2
لإنهاء صلاحيات برنامجك التجريبي بعد 30 يوماً

Private Sub Form_Load()
Dim startdate As String
Dim differenceofdate
Dim TRACEDATE As String
Dim newdate
Dim chk

If GetSetting(App.Title, "Startup", "counter", "") = "" Then
SaveSetting App.Title, "Startup", "counter", 1
SaveSetting App.Title, "Startup", "Started", Format(Date, "mm dd yyyy")
SaveSetting App.Title, "Startup", "Last Used", Format(Date, "mm dd yyyy")
Label1.Caption = "1"
ElseIf GetSetting(App.Title, "Startup", "counter", "") = "31" Then
MsgBox "شكراً لاستخدامك هذا البرنامج " & Chr(10) + Chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vbCritical, "شكراً لك "
End
Else
TRACEDATE = GetSetting(App.Title, "Startup", "Last Used", "")
chk = DateDiff("d", CDate(TRACEDATE), Now)
If chk < 0 Then 'CHECK IF THE DATE WAS CHANGE which is lesser than the PREVIOUS DATE WHERE THE SYSTEM USED.
MsgBox "لم يتم العثور على تاريخ النظام لديك !! " & Chr(10) + Chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vbCritical, "تاريخ مفقود"
End
Else
startdate = GetSetting(App.Title, "Startup", "Started", "")
differenceofdate = DateDiff("d", startdate, Now)
If differenceofdate <> 0 Then
Label1.Caption = differenceofdate + 1
SaveSetting App.Title, "Startup", "Last Used", Format(Now, "MM DD YYYY")
SaveSetting App.Title, "Startup", "counter", differenceofdate + 1
End If
If differenceofdate = 0 Then
Label1.Caption = GetSetting(App.Title, "Startup", "Counter", "")
End If
End If
End If
End Sub

-----------------------------------------
3
تحيه حسب الوقت

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

-----------------------------------------
4
تشغيل الصوت

Private Sub Form_Load()
'فقط *.wav إظهار الملفات من النوع
CommonDialog1.Filter = "Wave Files|*.wav|"
'لإضهار مربع حوار فتح
CommonDialog1.ShowOpen
'لو لم يختار أي ملف فإنه يتم الخروج من هذا الإجراء دون فتح الملف
' FileName حيث أن اسم الملف يتواجد في الخاصية
If CommonDialog1.FileName = "" Then Exit Sub
'تحديد نوع الملف المطلوب تشغيله
MMControl1.DeviceType = "waveaudio"
'تحديد اسم ملف الصوت
MMControl1.FileName = CommonDialog1.FileName
'فتح ملف الصوت
MMControl1.Command = "open"
End Sub

-----------------------------------------
5
كود لهز الفورم

Option Explicit
Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long
Private mb_Flashing As Boolean

Private Sub Command1_Click()
mb_Flashing = Not mb_Flashing
Timer1.Enabled = mb_Flashing
If mb_Flashing = False Then
Call FlashWindow(Me.hwnd, 0)
End If
End Sub

Private Sub Timer1_Timer()
Call FlashWindow(Me.hwnd, 1)
End Sub


:smailes109: تعليقاتكم يا شباب :smailes109:

الجزء الثاني (http://www.bramjnet.com/vb3/showthread.php?t=348413&page=4)

[thedove75]

جميل مشكور على الكودات

[abd1512]

مشكور اخى على الاكواد

[jockey4ever]

ترليون
ترليون ترليون ترليون ترليون
ترليون ترليون ترليون ترليون ترليون ترليون ترليون ترليون
ترليون ترليون ترليون ترليون ترليون ترليون ترليون
ترليون ترليون ترليون ترليون ترليون ترليون
ترليون ترليون ترليون ترليون ترليون
ترليون ترليون ترليون ترليون
ترليون ترليون ترليون
ترليون ترليون
ترليون


عافية..

[ahmed99alex]

ألف ألف ألف شكر يا غالى

[Aboud Aboud]

شكرا على الردود
:smailes40: :smailes23: :smailes23: :smailes23: :smailes40:

[محمد البراري]

مشكور على الاكواد الله يعطيك الصحة والعافية

[zine pef]

aboud شيء رائع يدخل في ميزان الحسنات

[karem00]

شكراااااااااااااااا جزيلااااااااااااااااااااااا

[rachidnet00]

مشكور أخي نحن في انتظار الجديد

[UniteD MoR]

لغة البرمجة دلفي

[sunSyria]

شكرا جزيلا

[Aboud Aboud]

مشكور على الردود

[قتيل العبرات]

مشكور اخوي الاكواد تجنن زي الروعة

[Aboud Aboud]

مشكور اخوي الاكواد تجنن زي الروعة

شكرا على الرد

[Aboud Aboud]

لغة البرمجة دلفي

:smailes61::smailes61: ماذا تقصد :smailes61::smailes61:

[Aboud Aboud]

1
اخفاء / اظهار شريط العنوان

'----This example allow you also to make A Resizeable form without titlebar.
'Add 2 Command Buttons to your Form. By clicking the first, you will hide the titlebar.
'By clicking the second, you will show it again. Warning: if you will click one of the
'buttons twice a row, For example pressing the hide titlebar button when the titlebar
'is already hidden, and vise versia, you will have errors.
'Insert the following code to your form:

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
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000

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 Enum ESetWindowPosStyles
SWP_SHOWWINDOW = &H40
SWP_HIDEWINDOW = &H80
SWP_FRAMECHANGED = &H20
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_DRAWFRAME = SWP_FRAMECHANGED
HWND_NOTOPMOST = -2
End Enum

Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long

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

Private Function ShowTitleBar(ByVal bState As Boolean)
Dim lStyle As Long
Dim tR As RECT

GetWindowRect Me.hwnd, tR

lStyle = GetWindowLong(Me.hwnd, GWL_STYLE)
If (bState) Then
Me.Caption = Me.Tag
If Me.ControlBox Then
lStyle = lStyle Or WS_SYSMENU
End If
If Me.MaxButton Then
lStyle = lStyle Or WS_MAXIMIZEBOX
End If
If Me.MinButton Then
lStyle = lStyle Or WS_MINIMIZEBOX
End If
If Me.Caption <> "" Then
lStyle = lStyle Or WS_CAPTION
End If
Else
Me.Tag = Me.Caption
Me.Caption = ""
lStyle = lStyle And Not WS_SYSMENU
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_CAPTION
End If
SetWindowLong Me.hwnd, GWL_STYLE, lStyle

SetWindowPos Me.hwnd, 0, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top, _
SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED
Me.Refresh
End Function

Private Sub Command1_Click()
ShowTitleBar False
End Sub

Private Sub Command2_Click()
ShowTitleBar True
End Sub
-----------------------------------------
2
ازالة ال X من النافذة

Private Declare Function DrawMenuBar& Lib "user32" (ByVal hwnd As Long)
Private Declare Function GetMenuItemCount& Lib "user32" (ByVal hMenu As Long)
Private Declare Function GetSystemMenu& Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long)
Private Declare Function RemoveMenu& Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long)

Private Const MF_BYPOSITION = &H400
Private Const MF_REMOVE = &H1000

Private Sub Form_Load()
Dim hMenu As Long
Dim lngMnuCount As Long
hMenu = GetSystemMenu(Form1.hwnd, 0)
lngMnuCount = GetMenuItemCount(hMenu)
RemoveMenu hMenu, lngMnuCount - 1, MF_REMOVE Or MF_BYPOSITION
RemoveMenu hMenu, lngMnuCount - 2, MF_REMOVE Or MF_BYPOSITION
DrawMenuBar Form1.hwnd
End Sub

-----------------------------------------
3
اضافة زر تصغير للنافذة

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const GWL_STYLE = (-16)
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000

Private Function AddMinimizeButton(po_Form As Form)
Dim ll_Style As Long
'Get window style
ll_Style = GetWindowLong(po_Form.hwnd, GWL_STYLE)
'Add the minimize button
Call SetWindowLong(po_Form.hwnd, GWL_STYLE, ll_Style Or WS_MINIMIZEBOX)
End Function

Private Sub Form_Load()
AddMinimizeButton Me
End Sub

-----------------------------------------
4
تحريك النص في العنوان و Text

Private strText As String
Private Sub Form_Load()
Timer1.Interval = 75
strText = "Guten Tag! Wie ght's Ihnen? Ich hoffe Ihnen alles Gutes!"
strText = Space(50) & strText
End Sub
Private Sub Timer1_Timer()
strText = Mid(strText, 2) & Left(strText, 1)
Text1.Text = strText
Me.Caption = strText
End Sub

-----------------------------------------
5
تحريك النافذة بواسطة Lable

Dim vX, vY
Dim vM As Boolean

Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
vX = X
vY = Y
vM = True
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim frmX, frmY
frmX = Form1.Left + (X - vX)
frmY = Form1.Top + (Y - vY)
If vM = True Then
Form1.Move frmX, frmY
End If
End Sub

Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
vM = False
End Sub