قواعد المشاركة في المنتدى

(منتدى الأكسس) الموضوع:تمكين وعدم تمكين مربع نص خاص بالرقم بواسطة: (أبو بيبو) :: (منتدى مبرمجي Microsoft Visual C#.NET) الموضوع:تعلم كيفية فك ضغط ملف WinRAR بواسطة: (Abu Ehab) :: (منتدى الأكسس) الموضوع:بخصوص الشجرة TreeView بواسطة: (د.كاف يار) :: (منتدى ADO.NET العام) الموضوع:خدمات مجانية -تأجيرشقق و فيلات مفروشة وايجار سيارات في مصر 00201126266000 بواسطة: (جوجو عمل) :: (قسم الاعلانات) الموضوع:ساهم في مشروع تشجيع القراءة الان بواسطة: (korossama) :: (منتدى الأكسس) الموضوع:برنامج نادي صحي كمال اجسام بواسطة: (startnet) :: (قسم الاعلانات) الموضوع:سيارات ديهاتسو مستعملة للبيع بحالة الفابريكة بواسطة: (ديزاينر ديزاينر) :: (قسم الاعلانات) الموضوع:سيارات جاجور مستعملة للبيع بواسطة: (ديزاينر ديزاينر) :: (قسم الاعلانات) الموضوع:سيارات بنتلي مستعملة للبيع بواسطة: (ديزاينر ديزاينر) :: (قسم الاعلانات) الموضوع:بنامكس لأعمال الرخام الصناعي والمغاسل بواسطة: (حسن ابراهيم) :: (قسم الإنترنت) الموضوع:تصميم وبرمجة تطبيقات الهواتف الذكية بواسطة: (موشن جرافيك) :: (قسم الاعلانات) الموضوع:نصائح عامة بواسطة: (كوين) :: (منتدى الأكسس) الموضوع:الباركود بواسطة: (startnet) :: (منتدى ال Cisco) الموضوع:ccna 1 final examen بواسطة: (even2017) :: (منتدى الأكسس) الموضوع:طلب كود تشغيل عدة استعلامات بواسطة: (د.كاف يار) :: (قسم الاعلانات) الموضوع:رحلتي لزراعة الشعر في تركيا بواسطة: (فادي لبناني) :: (قسم الاعلانات) الموضوع:شقق مفروشة للايجار بأفضل المستويات والاسعار بالقاهرة الصور 00201227389733 بواسطة: (دنيامحمد) :: (قسم الاعلانات) الموضوع:طريقة تنظيف الموكيت بواسطة: (سجيات) :: (منتدى مبرمجي Microsoft Visual C#.NET) الموضوع:Abu Ehab Pie Chart Control بواسطة: (Abu Ehab) :: (قسم الخدمات) الموضوع:تصميم وبرمجة تطبيقات الهواتف الذكية بواسطة: (موشن جرافيك)


راديو القرآن

المواضيع المثبته: (منتدى التصميم والجرافيكس) الموضوع:سلسلة دروس الفلاش بواسطة: (مبرمجة فلسطينية) :: (منتدى برمجة الألعاب) الموضوع:اعلان هام بواسطة: (مصطفي البارودي) :: (قسم التعاميم والشكاوي) الموضوع:شروط المشاركة في المنتدى بواسطة: (عبدالله جابر شقليه) :: (قسم الدروس و الدورات) الموضوع:لتحميل مجموعة امثله على الفيجوال بيسيك دوت نت 2005 بواسطة: (HnHn) :: (منتدى تصميم صفحات الويب) الموضوع:الجافا سكريبت في كتاب بواسطة: (amricost) :: (منتدى الكتب الالكترونية) الموضوع:كتاب كامل من جزئين يشرح access وبالتفصيل وقواعد البيانات وبالتفصيل بواسطة: (m.i.a.r) :: (منتدى البرامج) الموضوع:برنامج رهيب انتا تتكلم والكمبيوتر يكتب بالعربى بواسطة: (مستشفى الكمبيوتر) :: (منتدى Microsoft Visual Basic) الموضوع:كيفية إنشاء نظام شؤون الموظفين من الصفر بواسطة: (zoubicom) :: (منتدى البرامج) الموضوع:7 اسطوانات لتعليم شهاده ICDL بالصوت والصوره بواسطة: (مستشفى الكمبيوتر) :: (منتدى Microsoft SQL Server) الموضوع:يومياً أسئلة sql server مجاناً بواسطة: (m.atassi) :: (منتدى التصميم والجرافيكس) الموضوع:دورة تصميم مواقع بواسطة: (aram) :: (منتدى مبرمجي Microsoft Visual VB.NET) الموضوع:المخازن المتطور الاصدار الثانى بواسطة: (alaa gomaa) :: (قسم التعاميم والشكاوي) الموضوع:هنيئا للشعب المصري بواسطة: (صهيب جاويش) :: (منتدى Microsoft Visual Basic) الموضوع:دروس صوت وصورة للربط بين اسكيوال سيرفر والفجوال بيسيك بواسطة: (wael abed) :: (منتدى أنظمة الشبكات وأمنها) الموضوع:أساسيات تصميم الشبكات بواسطة: (مرحبا الساع) :: (منتدى نظام تشغيل Linux) الموضوع:أوامر لينكس بواسطة: (khaled helal) :: (منتدى أنظمة الشبكات وأمنها) الموضوع:امن المعلومات وامن الشبكات بواسطة: (khaled helal) :: (القسم المفتوح) الموضوع:الى الاخوه الاعضاء مع التحيه والتقدير بخصوص العناوين للمشاركة بواسطة: (startnet) :: (Oracle قسم قواعد البيانات أوراكل) الموضوع:ADF بواسطة: (وليد القدسي) :: (منتدى الكتب الالكترونية) الموضوع:مجموعة كبيرة من السرفرات بواسطة: (يوسف)

عدد الصفحات : 10  1  2  3  4  5   > » إضافة رد إضافة موضوع جديد

> بنك اكواد المحيط العربي,بنك اكواد المحيط العربي
Bookmark and Share
تقييم الموضوع Label معدل التقيم:0
مشاركةالاثنين,11/شعبان/1427 هـ,10:24 صباحاً
المشاركة #1

عضو شرف
الرتبة في المنتدى:ملازم

أيقونة المجموعة

المجموعة: أعضاء الشرف
المشاركات: 174
سجل في:الجمعة,17/رجب/1427 هـ,08:10 صباحاً
الدولة:سوريا
رقم العضوية: 12598



هذا الكود تحويل درجة الحرارة
 كود
Prompt = "إدخل درجة حرارة فهرنهايتية."
Do
FTemp = InputBox(Prompt, "الدرجة الفهرنهايتية إلى مئوية")
If FTemp <> "" Then
Celsius = Int((FTemp + 40) * 5 / 9 - 40)
MsgBox (Celsius), , "درجة حرارة في مئوية"
End If
Loop While FTemp <> ""
End






وهذا كود اخر لرسم المعادلات
 كود
'مع العلم ان pic هي اداة Pictuer
Dim X As Integer
Dim Y As Single

' ----------------------------------------
' يمكن تغيير القيم التالية لتغيير ابعاد الرسم
Const Min = -30
Const Max = 30
' ----------------------------------------

Pic.Scale (Min, Min)-(Max, Max)
For X = Min To Max

'----------------------------
' هنا اكتب معادلتك التي تريدها
Y = X ^ 2
'----------------------------

If X = Min Then
Pic.Cls
Pic.Line (Min, 0)-(Max, 0), vbBlack
Pic.Line (0, Min)-(0, Max), vbBlack
Pic.CurrentX = -100
Pic.CurrentY = -Y
Else
Pic.Line -(X, -Y), vbRed
End If
Next



وهذا كود اخر لعمل نص ثلاثي البعد
 كود
ForeColor = 0: x = CurrentX: y = CurrentY
For i = 1 To 100
Print "GeNeRaL"
x = x + 1: y = y + 1: CurrentX = x: CurrentY = y
Next
ForeColor = &HFFFF&
Print "GeNeRaL"



وهذا كود اخرتجعل النص يظهر بشكل عمودي في الأداة Label

يمكن عمل ذلك باستخدام الرمز vbCrLf ، حيث يوضع بعد كل حرف في محتوى الأداة Label كما يلي :
 كود
Private Sub Form_Activate()
Dim s As String
For i = 1 To Len(Label1)
s = s & Mid$(Label1, i, 1) & vbCrLf
Next
Label1 = s
End Sub


والشكر لجميع اعضاء المنتدى
وارجو من كل اعضاء المنتدى اضافة مثل هذه الاكواد البسيطة
GeNeRaL


--------------------
للأعلىأبلغ المشرف عن هذه المشاركة
لتعقيب على هذه المشاركة مباشرة
مشاركةالاثنين,11/شعبان/1427 هـ,04:03 مساءً
المشاركة #2

الرتبة في المنتدى:نقيب

أيقونة المجموعة

المجموعة: أعضاء فعالين
المشاركات: 438
سجل في:الاثنين,01/رمضان/1426 هـ,04:28 مساءً
الدولة:سوريا
رقم العضوية: 5702



هذا كود مرح لفتح و غلق cdroom
 كود
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 OpenCDDriveDoor(ByVal State As Boolean)
If State = True Then
Call mciSendString("Set CDAudio Door Open", 0&, 0&, 0&)
Else
Call mciSendString("Set CDAudio Door Closed", 0&, 0&, 0&)
End If
End Sub

Private Sub Command1_Click()
OpenCDDriveDoor (True)
End Sub

Private Sub Command2_Click()
OpenCDDriveDoor (False)
End Sub


للأعلىأبلغ المشرف عن هذه المشاركة
لتعقيب على هذه المشاركة مباشرة
مشاركةالاثنين,18/شعبان/1427 هـ,09:27 صباحاً
المشاركة #3

عضو شرف
الرتبة في المنتدى:ملازم

أيقونة المجموعة

المجموعة: أعضاء الشرف
المشاركات: 174
سجل في:الجمعة,17/رجب/1427 هـ,08:10 صباحاً
الدولة:سوريا
رقم العضوية: 12598



وهذا كود لفتح واغلاق السيدي
ضع هذا في الفورم

'Option Explicit

Private Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uId As Long
uFlags As Long
ucallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type

Private Const NIM_ADD = &H0
Private Const NIM_MODIFY = &H1
Private Const NIM_DELETE = &H2
Private Const WM_MOUSEMOVE = &H200
Private Const NIF_MESSAGE = &H1
Private Const NIF_ICON = &H2
Private Const NIF_TIP = &H4

Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Dim t As NOTIFYICONDATA

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
'Dim returnstring As String
'Dim retvalue As Long

Private Sub Form_Load()
t.cbSize = Len(t)
t.hWnd = Picture1.hWnd
t.uId = 1&
t.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
t.ucallbackMessage = WM_MOUSEMOVE
t.hIcon = Picture1.Picture
t.szTip = "CD Open/Close by Rinolds Kaòeps" & Chr$(0)
Shell_NotifyIcon NIM_ADD, t
Me.Hide
App.TaskVisible = False
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
t.cbSize = Len(t)
t.hWnd = Picture1.hWnd
t.uId = 1&
Shell_NotifyIcon NIM_DELETE, t
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'If Hex(X) = "1E3C" Then
' Me.PopupMenu mnuFile

'End If

Dim lMsg As Long
Static bInHere As Boolean
lMsg = X / Screen.TwipsPerPixelX
Select Case lMsg
' Case WM_LBUTTONDBLCLK:
'
' On Mouse DoubleClick - Restore the window

'On Error Resume Next
'Me.Show
' retvalue = mciSendString("set CDAudio door open", returnstring, 127, 0)

'If Me.WindowState = vbMinimized Then
' Me.WindowState = vbDefault
'End If
'Me.ZOrder
Case WM_LBUTTONDOWN:
retvalue = mciSendString("set CDAudio door open", returnstring, 127, 0)
Case WM_RBUTTONDOWN:
retvalue = mciSendString("set CDAudio door closed", returnstring, 127, 0)

End Select


End Sub


وضع هذا في Module

'Public Const WM_LBUTTONDBLCLK As Long = &H203
Public Const WM_LBUTTONDOWN As Long = &H201
Public Const WM_RBUTTONDOWN As Long = &H204




الملفات المرفقة
 cd_open_close.rar ( 2.92ك ) عدد مرات التنزيل: 1440


--------------------
للأعلىأبلغ المشرف عن هذه المشاركة
لتعقيب على هذه المشاركة مباشرة
مشاركةالاثنين,18/شعبان/1427 هـ,09:34 صباحاً
المشاركة #4

عضو شرف
الرتبة في المنتدى:ملازم

أيقونة المجموعة

المجموعة: أعضاء الشرف
المشاركات: 174
سجل في:الجمعة,17/رجب/1427 هـ,08:10 صباحاً
الدولة:سوريا
رقم العضوية: 12598



وهذا كود لاخفاء اي قرص من جهاز الكمبيوتر


Option Explicit
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function PaintDesktop Lib "user32" (ByVal hdc As Long) As Long

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_REGISTRY_RECOVERED = 1014&
Const ERROR_REGISTRY_CORRUPT = 1015&
Const ERROR_REGISTRY_IO_FAILED = 1016&
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const REG_SZ = 1
Private Sub Command1_Click()
Dim retvalue As Long, result As Long
Dim KeyID As Long, keyvalue As Long
Dim subKey As String
Dim bufSize As Long
Dim regkey As String
Dim abc As Long
Dim a1 As Long
Dim hCurKey As Long
Dim lRegResult As Long
Dim s As String
Dim a As String
If Check1.Value = 1 Then
Check1.Tag = 1
Else
Check1.Tag = 0
End If

If Check2.Value = 1 Then
Check2.Tag = 2
Else
Check2.Tag = 0
End If
If Check3.Value = 1 Then
Check3.Tag = 4
Else
Check3.Tag = 0
End If

If Check4.Value = 1 Then
Check4.Tag = 8
Else
Check4.Tag = 0
End If
If Check5.Value = 1 Then
Check5.Tag = 16
Else
Check5.Tag = 0
End If

If Check6.Value = 1 Then
Check6.Tag = 32
Else
Check6.Tag = 0
End If
If Check7.Value = 1 Then
Check7.Tag = 64
Else
Check7.Tag = 0
End If

If Check8.Value = 1 Then
Check8.Tag = 128
Else
Check8.Tag = 0
End If
If Check9.Value = 1 Then
Check9.Tag = 256
Else
Check9.Tag = 0
End If

If Check10.Value = 1 Then
Check10.Tag = 512
Else
Check10.Tag = 0
End If
If Check11.Value = 1 Then
Check11.Tag = 1024
Else
Check11.Tag = 0
End If

If Check12.Value = 1 Then
Check12.Tag = 2048
Else
Check12.Tag = 0
End If
If Check13.Value = 1 Then
Check13.Tag = 4096
Else
Check13.Tag = 0
End If

If Check14.Value = 1 Then
Check14.Tag = 8192
Else
Check14.Tag = 0
End If
If Check15.Value = 1 Then
Check15.Tag = 16384
Else
Check15.Tag = 0
End If

If Check16.Value = 1 Then
Check16.Tag = 32768
Else
Check16.Tag = 0
End If
If Check17.Value = 1 Then
Check17.Tag = 65536
Else
Check17.Tag = 0
End If

If Check18.Value = 1 Then
Check18.Tag = 131072
Else
Check18.Tag = 0
End If
If Check19.Value = 1 Then
Check19.Tag = 262144
Else
Check19.Tag = 0
End If '

If Check20.Value = 1 Then
Check20.Tag = 524288
Else
Check20.Tag = 0
End If
If Check21.Value = 1 Then
Check21.Tag = 1048576
Else
Check21.Tag = 0
End If

If Check22.Value = 1 Then
Check22.Tag = 2097152
Else
Check22.Tag = 0
End If
If Check23.Value = 1 Then
Check23.Tag = 4194304
Else
Check23.Tag = 0
End If

If Check24.Value = 1 Then
Check24.Tag = 8388608
Else
Check24.Tag = 0
End If
If Check25.Value = 1 Then
Check25.Tag = 16777216
Else
Check25.Tag = 0
End If

If Check26.Value = 1 Then
Check26.Tag = 33554432
Else
Check26.Tag = 0
End If

a1 = CLng(Check1.Tag) + CLng(Check2.Tag) + CLng(Check3.Tag) _
+ CLng(Check4.Tag) + CLng(Check5.Tag) + CLng(Check6.Tag) + _
CLng(Check7.Tag) + CLng(Check8.Tag) + CLng(Check9.Tag) + _
CLng(Check10.Tag) + CLng(Check11.Tag) + CLng(Check12.Tag) _
+ CLng(Check13.Tag) + CLng(Check14.Tag) + CLng(Check15.Tag) + _
CLng(Check16.Tag) + CLng(Check17.Tag) + CLng(Check18.Tag) _
+ CLng(Check19.Tag) + CLng(Check20.Tag) + CLng(Check21.Tag) _
+ CLng(Check22.Tag) + CLng(Check23.Tag) + CLng(Check24.Tag) _
+ CLng(Check25.Tag) + CLng(Check26.Tag)
If a1 = 0 Then
s = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
a = "NoDrives"
lRegResult = RegOpenKey(HKEY_CURRENT_USER, s, hCurKey)
lRegResult = RegDeleteValue(hCurKey, a)
lRegResult = RegCloseKey(hCurKey)
Else
If a1 <> 0 Then
regkey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
retvalue = RegCreateKey(HKEY_CURRENT_USER, regkey, KeyID)
subKey = "NoDrives"
keyvalue = a1
retvalue = RegSetValueEx(KeyID, subKey, 0&, 4, keyvalue, 4)
End If
End If
End Sub




Private Sub Command2_Click()
Dim retvalue As Long, result As Long
Dim KeyID As Long, keyvalue As Long
Dim subKey As String
Dim bufSize As Long
Dim regkey As String
Dim abc As Long
Dim a1 As Long
Dim hCurKey As Long
Dim lRegResult As Long
Dim s As String
Dim a As String
s = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
a = "NoDrives"
lRegResult = RegOpenKey(HKEY_CURRENT_USER, s, hCurKey)
lRegResult = RegDeleteValue(hCurKey, a)
lRegResult = RegCloseKey(hCurKey)
End Sub

Private Sub Form_Load()

End Sub




الملفات المرفقة
 اخفاء اي قرص.rar ( 3.35ك ) عدد مرات التنزيل: 1224


--------------------
للأعلىأبلغ المشرف عن هذه المشاركة
لتعقيب على هذه المشاركة مباشرة
مشاركةالاثنين,18/شعبان/1427 هـ,09:37 صباحاً
المشاركة #5

عضو شرف
الرتبة في المنتدى:ملازم

أيقونة المجموعة

المجموعة: أعضاء الشرف
المشاركات: 174
سجل في:الجمعة,17/رجب/1427 هـ,08:10 صباحاً
الدولة:سوريا
رقم العضوية: 12598



هذه كود تحريك الصور بوساطة BitBlt


Option Explicit
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function PaintDesktop Lib "user32" (ByVal hdc As Long) As Long

Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1009&
Const ERROR_BADKEY = 1010&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_REGISTRY_RECOVERED = 1014&
Const ERROR_REGISTRY_CORRUPT = 1015&
Const ERROR_REGISTRY_IO_FAILED = 1016&
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const REG_SZ = 1
Private Sub Command1_Click()
Dim retvalue As Long, result As Long
Dim KeyID As Long, keyvalue As Long
Dim subKey As String
Dim bufSize As Long
Dim regkey As String
Dim abc As Long
Dim a1 As Long
Dim hCurKey As Long
Dim lRegResult As Long
Dim s As String
Dim a As String
If Check1.Value = 1 Then
Check1.Tag = 1
Else
Check1.Tag = 0
End If

If Check2.Value = 1 Then
Check2.Tag = 2
Else
Check2.Tag = 0
End If
If Check3.Value = 1 Then
Check3.Tag = 4
Else
Check3.Tag = 0
End If

If Check4.Value = 1 Then
Check4.Tag = 8
Else
Check4.Tag = 0
End If
If Check5.Value = 1 Then
Check5.Tag = 16
Else
Check5.Tag = 0
End If

If Check6.Value = 1 Then
Check6.Tag = 32
Else
Check6.Tag = 0
End If
If Check7.Value = 1 Then
Check7.Tag = 64
Else
Check7.Tag = 0
End If

If Check8.Value = 1 Then
Check8.Tag = 128
Else
Check8.Tag = 0
End If
If Check9.Value = 1 Then
Check9.Tag = 256
Else
Check9.Tag = 0
End If

If Check10.Value = 1 Then
Check10.Tag = 512
Else
Check10.Tag = 0
End If
If Check11.Value = 1 Then
Check11.Tag = 1024
Else
Check11.Tag = 0
End If

If Check12.Value = 1 Then
Check12.Tag = 2048
Else
Check12.Tag = 0
End If
If Check13.Value = 1 Then
Check13.Tag = 4096
Else
Check13.Tag = 0
End If

If Check14.Value = 1 Then
Check14.Tag = 8192
Else
Check14.Tag = 0
End If
If Check15.Value = 1 Then
Check15.Tag = 16384
Else
Check15.Tag = 0
End If

If Check16.Value = 1 Then
Check16.Tag = 32768
Else
Check16.Tag = 0
End If
If Check17.Value = 1 Then
Check17.Tag = 65536
Else
Check17.Tag = 0
End If

If Check18.Value = 1 Then
Check18.Tag = 131072
Else
Check18.Tag = 0
End If
If Check19.Value = 1 Then
Check19.Tag = 262144
Else
Check19.Tag = 0
End If '

If Check20.Value = 1 Then
Check20.Tag = 524288
Else
Check20.Tag = 0
End If
If Check21.Value = 1 Then
Check21.Tag = 1048576
Else
Check21.Tag = 0
End If

If Check22.Value = 1 Then
Check22.Tag = 2097152
Else
Check22.Tag = 0
End If
If Check23.Value = 1 Then
Check23.Tag = 4194304
Else
Check23.Tag = 0
End If

If Check24.Value = 1 Then
Check24.Tag = 8388608
Else
Check24.Tag = 0
End If
If Check25.Value = 1 Then
Check25.Tag = 16777216
Else
Check25.Tag = 0
End If

If Check26.Value = 1 Then
Check26.Tag = 33554432
Else
Check26.Tag = 0
End If

a1 = CLng(Check1.Tag) + CLng(Check2.Tag) + CLng(Check3.Tag) _
+ CLng(Check4.Tag) + CLng(Check5.Tag) + CLng(Check6.Tag) + _
CLng(Check7.Tag) + CLng(Check8.Tag) + CLng(Check9.Tag) + _
CLng(Check10.Tag) + CLng(Check11.Tag) + CLng(Check12.Tag) _
+ CLng(Check13.Tag) + CLng(Check14.Tag) + CLng(Check15.Tag) + _
CLng(Check16.Tag) + CLng(Check17.Tag) + CLng(Check18.Tag) _
+ CLng(Check19.Tag) + CLng(Check20.Tag) + CLng(Check21.Tag) _
+ CLng(Check22.Tag) + CLng(Check23.Tag) + CLng(Check24.Tag) _
+ CLng(Check25.Tag) + CLng(Check26.Tag)
If a1 = 0 Then
s = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
a = "NoDrives"
lRegResult = RegOpenKey(HKEY_CURRENT_USER, s, hCurKey)
lRegResult = RegDeleteValue(hCurKey, a)
lRegResult = RegCloseKey(hCurKey)
Else
If a1 <> 0 Then
regkey = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
retvalue = RegCreateKey(HKEY_CURRENT_USER, regkey, KeyID)
subKey = "NoDrives"
keyvalue = a1
retvalue = RegSetValueEx(KeyID, subKey, 0&, 4, keyvalue, 4)
End If
End If
End Sub




Private Sub Command2_Click()
Dim retvalue As Long, result As Long
Dim KeyID As Long, keyvalue As Long
Dim subKey As String
Dim bufSize As Long
Dim regkey As String
Dim abc As Long
Dim a1 As Long
Dim hCurKey As Long
Dim lRegResult As Long
Dim s As String
Dim a As String
s = "Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
a = "NoDrives"
lRegResult = RegOpenKey(HKEY_CURRENT_USER, s, hCurKey)
lRegResult = RegDeleteValue(hCurKey, a)
lRegResult = RegCloseKey(hCurKey)
End Sub

Private Sub Form_Load()

End Sub




الملفات المرفقة
 تحريك الصور بوساطة BitBlt.rar ( 52.22ك ) عدد مرات التنزيل: 1448


--------------------
للأعلىأبلغ المشرف عن هذه المشاركة
لتعقيب على هذه المشاركة مباشرة
مشاركةالاثنين,18/شعبان/1427 هـ,09:41 صباحاً
المشاركة #6

عضو شرف
الرتبة في المنتدى:ملازم

أيقونة المجموعة

المجموعة: أعضاء الشرف
المشاركات: 174
سجل في:الجمعة,17/رجب/1427 هـ,08:10 صباحاً
الدولة:سوريا
رقم العضوية: 12598



كود معرفة هذه الاحقة مع اي برنامج تعمل على النظام

هذا في الفورم

Private Declare Function FindExecutableA Lib "shell32.dll" (ByVal lpFile As String, ByVal lpdirectory As String, ByVal lpResult As String) As Long
Private Const MAX_FILENAME_LEN = 256

Public Function FindExecutable(s As String) As String
Dim i As Integer
Dim s2 As String

s2 = String(MAX_FILENAME_LEN, 32) & Chr$(0)

i = FindExecutableA(s & Chr$(0), vbNullString, s2)

If i > 32 Then
FindExecutable = Left$(s2, InStr(s2, Chr$(0)) - 1)
Else
FindExecutable = ""
End If

End Function

Private Sub Image1_Click()
CM.ShowOpen
Text1 = CM.FileName
Text2 = FindExecutable(Text1)

End Sub


وهذا في Module




الملفات المرفقة
 FindSuoerProgramForFile.rar ( 227.48ك ) عدد مرات التنزيل: 1515


--------------------
للأعلىأبلغ المشرف عن هذه المشاركة
لتعقيب على هذه المشاركة مباشرة
مشاركةالاثنين,18/شعبان/1427 هـ,09:41 صباحاً
المشاركة #7

عضو شرف
الرتبة في المنتدى:ملازم

أيقونة المجموعة

المجموعة: أعضاء الشرف
المشاركات: 174
سجل في:الجمعة,17/رجب/1427 هـ,08:10 صباحاً
الدولة:سوريا
رقم العضوية: 12598



معومات حول النوافذ المفتوحة


الملفات المرفقة
 معومات حول النوافذ المفتوحة.rar ( 33.33ك ) عدد مرات التنزيل: 1445


--------------------
للأعلىأبلغ المشرف عن هذه المشاركة
لتعقيب على هذه المشاركة مباشرة
مشاركةالاثنين,18/شعبان/1427 هـ,09:42 صباحاً
المشاركة #8

عضو شرف
الرتبة في المنتدى:ملازم

أيقونة المجموعة

المجموعة: أعضاء الشرف
المشاركات: 174
سجل في:الجمعة,17/رجب/1427 هـ,08:10 صباحاً
الدولة:سوريا
رقم العضوية: 12598



معلومات حول الايقونات الموجودة على سطح المكتب


الملفات المرفقة
 معلومات حول الايقونات الموجودة على سطح المكتب.rar ( 27.69ك ) عدد مرات التنزيل: 1130


--------------------
للأعلىأبلغ المشرف عن هذه المشاركة
لتعقيب على هذه المشاركة مباشرة
مشاركةالاثنين,18/شعبان/1427 هـ,09:44 صباحاً
المشاركة #9

عضو شرف
الرتبة في المنتدى:ملازم

أيقونة المجموعة

المجموعة: أعضاء الشرف
المشاركات: 174
سجل في:الجمعة,17/رجب/1427 هـ,08:10 صباحاً
الدولة:سوريا
رقم العضوية: 12598



كود مهم جدا عن shell32


Dim SH As New Shell 'reference to shell32.dll class
Dim ShBFF As Folder 'Shell Browse For Folder

Private Sub Command1_Click() 'Show BFF Dialog
On Error Resume Next
'set object
Set ShBFF = SH.BrowseForFolder(hWnd, "Hey this is a sample, " & _
"please choose a folder and click OK!", 1)
With ShBFF.Items.Item
'get folder props
Text1 = .Path
Text2 = "Name: " & .Name & vbCrLf & _
"Type: " & .Type & vbCrLf & _
"Last Modified: " & .ModifyDate & vbCrLf & _
"Parent: " & .Parent & vbCrLf
End With

End Sub

Private Sub Command10_Click() 'Show help
SH.Help
End Sub

Private Sub Command11_Click() 'Show compute find dialog
SH.FindComputer
End Sub

Private Sub Command12_Click() 'Show shut down dialog

If MsgBox("Are you sure you want to do this!?", _
vbQuestion + vbYesNo + vbDefaultButton2, _
"Confirm Action!") <> vbYes Then Exit Sub

SH.ShutdownWindows

End Sub

Private Sub Command13_Click() 'Open path
SH.Open Text3.Text
End Sub

Private Sub Command14_Click() 'Explore path
SH.Explore Text3.Text
End Sub

Private Sub Command15_Click() 'Open URL
SH.Open "http://www.geocities.com/bs20014/"
End Sub

Private Sub Command16_Click() 'Show Taskbar & Start Menu Properties
SH.TrayProperties
End Sub

Private Sub Command17_Click() 'Show clock dialog
SH.SetTime
End Sub

Private Sub Command2_Click() 'Cascade windows
SH.CascadeWindows
End Sub

Private Sub Command3_Click() 'Minimize all windows
SH.MinimizeAll
End Sub

Private Sub Command4_Click() 'Tile windows horizentally
SH.TileHorizontally
End Sub

Private Sub Command5_Click() 'Tile windows vertically
SH.TileVertically
End Sub

Private Sub Command6_Click() 'Undo minimizing windows
SH.UndoMinimizeALL
End Sub

Private Sub Command7_Click() 'Load something in Control Panel
SH.ControlPanelItem "sysdm.cpl" 'System Properties
'This can be easily changed
'Search for *.cpl in your system directory
'inetcpl.cpl ==> Internet Options
'appwiz.cpl ==> Add/Remove Programs
'and many more...
End Sub

Private Sub Command8_Click() 'Find files dialog
SH.FindFiles
End Sub

Private Sub Command9_Click() 'Run dialog
SH.FileRun
End Sub

Private Sub Form_Load() 'Form Load
Text3 = App.Path
End Sub




الملفات المرفقة
 shell32.rar ( 2.75ك ) عدد مرات التنزيل: 1155


--------------------
للأعلىأبلغ المشرف عن هذه المشاركة
لتعقيب على هذه المشاركة مباشرة
مشاركةالاثنين,18/شعبان/1427 هـ,09:48 صباحاً
المشاركة #10

عضو شرف
الرتبة في المنتدى:ملازم

أيقونة المجموعة

المجموعة: أعضاء الشرف
المشاركات: 174
سجل في:الجمعة,17/رجب/1427 هـ,08:10 صباحاً
الدولة:سوريا
رقم العضوية: 12598



كود معرفة دليل السواقة

Const DRIVE_REMOVABLE = 2
Const DRIVE_FIXED = 3
Const DRIVE_REMOTE = 4
Const DRIVE_CDROM = 5
Const DRIVE_RAMDISK = 6



Private Sub Command1_Click()
Dim r&, allDrives$, JustOneDrive$, pos%, DriveType&
Dim CDfound As Integer

'pad the string with spaces
allDrives$ = Space$(64)

'call the API to get the string containing all drives
r& = GetLogicalDriveStrings(Len(allDrives$), allDrives$)

'trim off trailing chr$(0)'s. AllDrives$
'now contains all the drive letters.
allDrives$ = Left$(allDrives$, r&)

'begin a loop
Do

'find the first separating chr$(0)
pos% = InStr(allDrives$, Chr$(0))

'if there's one, then...
If pos% Then

'extract the drive up to the chr$(0)
JustOneDrive$ = Left$(allDrives$, pos%)

'and remove that from the Alldrives string,
'so it won't be checked again
allDrives$ = Mid$(allDrives$, pos% + 1, Len(allDrives$))

'with the one drive, call the API to
'determine the drive type
DriveType& = GetDriveType(JustOneDrive$)

'check if it's what we want
If DriveType& = DRIVE_CDROM Then

'got it (or at least the first one,
'anyway, if more than one), so set
'the found flag...
CDfound% = True

'we're done, so get out
Exit Do

End If
End If

Loop Until allDrives$ = "" Or DriveType& = 6

'display the appropriate message
If CDfound% Then
Label1 = UCase$(JustOneDrive$)
Else: Label1 = "لم أجد أي سواقة ليزرية في نظامك..!!"
End If

End Sub


Private Sub Form_Load()

End Sub

Private Sub mnuExit_Click()
End
End Sub


في moudle


الملفات المرفقة
 معرفة دليل السواقة الليزرية.rar ( 5.88ك ) عدد مرات التنزيل: 934


--------------------
للأعلىأبلغ المشرف عن هذه المشاركة
لتعقيب على هذه المشاركة مباشرة

    

عدد المتصفحين لهذا المنتدى «1»: (الضيوف «1» - المتخفون «0»)
الأعضاء «0»: .

عدد الصفحات : 10  1  2  3  4  5   > » إضافة رد جديد إضافة موضوع جديد



 
الوقت الأن:اليوم,11:08 صباحاً بتوقيت القدس المحتلة

Powered By arabmoheet v3.1

منتديات المحيط العربي  -  راسلنا  -   أعلى
X   رسالة المنتدى
(سوف يتم اغلاق هذه النافذة بعد 2 ثانية)
X   رسالة المنتدى
(سوف يتم اغلاق هذه النافذة بعد 2 ثانية)