منتديات هندسة بلا حدود
مدير المنتدى م.نبيل الدم يرحب بكم ويتمنى لكم اجمل الاوقات
يرجى تسجيل دخولك أو التسجيل في المنتدى
عملية التسجيل سهلة جدا جدا ويمكنكم التسجيل دون الحاجة الى بريد الكتروني في حال لا يوجد لديكم,
فقط بعد التسجيل اذهب الى قسم تفعيل العضوية وطلب تفعيل حسابك مجانا, اهلا بالزوار
****************
ضع إعلانك معنا مجانا وبدون تسجيل (نحقق لك الاشهار والانتشار وزيادة الاعضاء والزوار) مجانا
****************
بسم الله . ماشاء الله..لاقوة الا بالله..اللهم صلى وسلم وبارك على سيدنا محمد
تسجيل دخول
اعلانات ادارية
  • ♥♥ ضع إعلانك معنا مجانا وبدون تسجيل (نحقق لك الاشهار والانتشار وزيادة الاعضاء والزوار) ♥♥

  • ♥♥ راسلنا لوضع اعلانك وستحصل على مميزات اعلانية خيالية ♥♥

أهلا وسهلا بك في منتديات هندسة بلا حدود .

css, html, java, games, cods, facebook, google, gmail, yahoo, hotmail, free ,للبيع, للشراء, للإيجار, عقارات, سيارات, اجهزة كهربائية , اثاث, خدمات, نقل عفش, بناء, كمبيوتر, صيانة, السياحة, وظائف, في الأردن , إعلانات, مبوبة, منتديات, ‏هندسة, اعلانات, مجاني


شاطر|


بيانات كاتب الموضوع
مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6
كاتب الموضوعرسالة
المعلومات
الكاتب:
اللقب:
المدير العام
الرتبه:
المدير العام
الصورة الرمزية

avatar
البيانات
البلد البلد : الاردن
الاوسمة الخاصة الاوسمة الخاصة : ادارة المنتدى
الجنس الجنس : ذكر
عدد المساهمات عدد المساهمات : 2066
نقاط نقاط : 17327
السٌّمعَة السٌّمعَة : 21
تاريخ التسجيل تاريخ التسجيل : 20/07/2012
المستوى التعليمي المستوى التعليمي : Mechatronics & Control Engineering
العمل/الترفيه العمل/الترفيه : متابعة التكنولوجيا
المزاج المزاج : معتدل
تعاليق تعاليق : المدير العام لمنتديات هندسة بلا حدود
ஜ۩‎®️‎۩ஜ(م.نبيل الدم)ஜ۩‎®️‎۩ஜ

الإتصالات
الحالة:
وسائل الإتصال:
http://enging.yoo7.comhttp://www.facebook.com/Brmjyatrom3dhttps://twitter.com/Brmjyatrom3d

موضوع: مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6 الإثنين 08 سبتمبر 2014, 5:20 am

اذا احتوت المشاركة صورا - قم بالضغط عليها لعرضها بحجمها الطبيعي




مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6




للأتصال بالأنترنت باستخدام الdailup connection 




*كود برمجي* 




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




Option Explicit 
Private Sub Command1_Click() 
Dim X 
Dim DialUpConnectName As String 
'قم بتحديد اسم الاتصال الذي تود الاتصال به 
DialUpConnectName = "Sts" 
X = Shell("rundll32.exe rnaui.dll,RnaDial " & DialUpConnectName, 1) 
DoEvents 
'في حال اردت ارسال كلمة السر ايضا قم باضافتها في النص التالي قبل القوس الاول مباشرة 
'"123(enter)" 
SendKeys "{enter}", True 
DoEvents 
End Sub 
كود خاص لمعرفة كلمة السر لملفات Access 97 
*كود برمجي* 




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




Option Explicit 
Private zChar As String 
Dim n As Long, s1 As String * 1, s2 As String * 1 
Dim lsClave As String 
Dim mask As String 




Private Sub Command1_Click() 
' يجب ان تضيف عنصر commonDialog الى برنامجك واسمه هنا DD 
DD.Filter = "Microsoft Access Database|*.mdb" 
DD.DefaultExt = "mdb" 
DD.ShowOpen 
zChar = DD.FileTitle 
mask = Chr(78) & Chr(134) & Chr(251) & Chr(236) & _ 
Chr(55) & Chr(93) & Chr(68) & Chr(156) & _ 
Chr(250) & Chr(198) & Chr(94) & Chr(40) & Chr(230) & Chr(19) 
Open zChar For Binary As #1 
Seek #1, &H42 
For n = 1 To 14 
s1 = Mid(mask, n, 1) 
s2 = Input(1, 1) 
If (Asc(s1) Xor Asc(s2)) <> 0 Then 
lsClave = lsClave & Chr(Asc(s1) Xor Asc(s2)) 
End If 
Next 
Close 1 
MsgBox lsClave & "كلمة السر هــي" 
End Sub 




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




معرفة الوقت الذي مضى على تشغيل الويندوز (الوقت هنا بالملي ثانية) 
*كود برمجي* 




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




Private Declare Function GetTickCount Lib "Kernel32" () As Long 
Private Sub Command1_Click() 
MsgBox Format(GetTickCount, "0") 
End Sub 




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




كود لمعرفة كلمات السر على هيئة نجوم ***** 
*كود برمجي* 




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




Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long 
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 
Private Type POINTAPI 
x As Long 
y As Long 
End Type 
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 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 




Private Sub Timer1_Timer() 
Const EM_SETPASSWORDCHAR = &HCC 
Dim coord As POINTAPI 
'نقوم هنا بمعرفة احداثى الفأرة 
s = GetCursorPos(coord) 
x = coord.x 
y = coord.y 
'المكتوب بها كلمة المرور(textbox)نقوم هنا بمعرفة مقبض آداة التحرير 
h = WindowFromPoint(x, y) 
'Char 0 الى (PasswordChar)فى هذه الخطوة نقوم بتعديل خاصية ال 
Dim NewChar As Integer 
NewChar = CLng(0) 
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0) 
End Sub 




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




كود لاضافة بيانات حقل معين في قاعدة البيانات الى عنصر list 
*كود برمجي* 




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




Private Sub Form_Activate() 
Dim a As String 
Do While Not Data1.Recordset.EOF = True 
a = Data1.Recordset.Fields("name").Value 
' هنا تمثل اسم الحقل في قاعدة البيانات name كلمة 
List1.AddItem a 
Data1.Recordset.MoveNext 
Loop 
End Sub 




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




كود يقوم بحماية برنامجك حيث يعمل عدد من المرات (تحددها بنفسك) ثم يتوقف نهائيا عن العمل ، وهو يشبه طريقة عمل الـ(register) في البرامج المشهورة 
*كود برمجي* 




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




Private Sub Form_Load() 
retvalue = GetSetting("A", "0", "Runcount") 
GD$ = Val(retvalue) + 1 
SaveSetting "A", "0", "RunCount", GD$ 
If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل 
MsgBox "انتهت مدة تشغيل البرنامج .. عليك بشراء النسخة الاصلية" 
Unload FRM ' 
End If 
End Sub 




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




يقوم بتحويل شكل التكست واليبل الى 3d 
*كود برمجي* 




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




'Set form's AutoRedraw property toTrue 
Sub PaintControl3D(frm As Form, Ctl As Control) 
' This Sub draws lines around controls to make them 3d 
' darkgrey, upper - horizontal 
frm.Line (Ctl.Left, Ctl.Top - 15)-(Ctl.Left + _ 
Ctl.Width, Ctl.Top - 15), &H808080, BF 
' darkgrey, left - vertical 
frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _ 
Ctl.Top + Ctl.Height), &H808080, BF 
' white, right - vertical 
frm.Line (Ctl.Left + Ctl.Width, Ctl.Top)- _ 
(Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF 
' white, lower - horizontal 
frm.Line (Ctl.Left, Ctl.Top + Ctl.Height)- _ 
(Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF 
End Sub 
Sub PaintForm3D(frm As Form) 
' This Sub draws lines around the Form to make it 3d 
' white, upper - horizontal 
frm.Line (0, 0)-(frm.ScaleWidth, 0), &HFFFFFF, BF 
' white, left - vertical 
frm.Line (0, 0)-(0, frm.ScaleHeight), &HFFFFFF, BF 
' darkgrey, right - vertical 
frm.Line (frm.ScaleWidth - 15, 0)-(frm.ScaleWidth - 15, _ 
frm.Height), &H808080, BF 
' darkgrey, lower - horizontal 
frm.Line (0, frm.ScaleHeight - 15)-(frm.ScaleWidth, _ 
frm.ScaleHeight - 15), &H808080, BF 
End Sub 
'DEMO USAGE 
'Add 1 label and 1 textbox 




Private Sub Form_Load() 
Me.AutoRedraw = True 
PaintForm3D Me 
PaintControl3D Me, Label1 'Label1 is name of label 
PaintControl3D Me, Text1 'Text1 is name of textbox 
End Sub 
ملاحظة في البداية لبد من انشاء تكست وليبل 




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




كود الاظهار النص بشكل عمودي 
*كود برمجي* 




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




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 




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




كود تستطيع من خلاله حذف اي ملف 
*كود برمجي* 




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




قم بوضع هذا الكود في قسم جنرال 
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long 
ومن ثم حدد سار الملف مثال 
Private Sub Command1_Click() 
dim x 
x = DeleteFile("C:\WINDOWS\system\LZEXPAND.DLL") 




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




كود لاستدعاء ملف من نوع mid 
*كود برمجي* 




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




قم بوضع اداة 
mmcontrol1 




m و 
اجعل نامي 
Private Sub Form_Load() 
m.DeviceType = "sequencer" 
m.FileName = ("e:\Holiday3.mid") 
m.Command = "open" 
m.Command = "play" 
END SUB 




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




كود لتحميل فلاش من نوع SWF 
*كود برمجي* 




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




Private Sub Form_Load() 
s.Movie = ("E:\Projects\Howl.swf") 
End Sub 




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




كود لوضع مقطع الفيديو في بكتشر 
*كود برمجي* 




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




Private Sub Command1_Click() 
MM.HWNDDISPLAY=PICTURE1.HWND 
End Sub 




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




الزر الأيمن للماوس 
*كود برمجي* 




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




Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 
IF BUTTON=2 THEN 
msgbox "الزر الأيمن للماوس" 
END IF 
End Sub 




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




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




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




Private Sub COMMAND1_CLICK() 
DIM SS AS STRING 
SS="123456789" 
IF INSTR(SS,CHR(KEYASCII)=0 THEN 
KEYASCII=0 
END IF 
End Sub 




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




عمل مسح ملفات للقرص المرن 
*كود برمجي* 




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




kill"A:\*.*" 




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




عرض صندوق حوار Open With 
*كود برمجي* 




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




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




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




حساب عدد سطور ملف نصى 
*كود برمجي* 




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




Private Sub Command1_Click() 
Open "c:\autoexec.bat" For Input As #1 
Count: 
n = n + 1 
Line Input #1, x 
If EOF(1) Then 
Label1.Caption = n 
Exit Sub 
Else 
GoTo Count: 
End If 
Close 
End Sub 




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




فحص المنافذ 
*كود برمجي* 




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




Private Sub Command1_Click() 
On Error GoTo opn: 
Winsock1.LocalPort = Text1.Text 
Winsock1.Listen 
Text2.Text = "المنفذ غير مفتوح" 
Winsock1.Close 
Exit Sub 
opn: 
If Err.Number = 10048 Then 
Text2.Text = "المنفذ مفتوح" 
Else 
Text2.Text = "يوجد مشكلة" 
End If 
Winsock1.Close 
End Sub 




-------------------------------------------------------------------------------- 
البرنامج يعمل على القرص المدمج (السيدي رووم) فقط 
*كود برمجي* 




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




Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" _ 
(ByVal nDrive As String) As Long 
Private Sub Form_Load() 
Dim driveType As Long 
driveType = GetDriveType(Mid(App.Path, 1, 3)) 
If driveType <> 5 Then 
'إنهاء البرنامج إذا كان لايشتغل من القرص المدمج 
End 
End If 
End Sub 




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




هذا كود لتشفير وفك تشفير نص 
*كود برمجي* 




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




Private Sub Command1_Click() 
For i = 1 To Len(Text1.Text) 
st1 = Mid(Text1.Text, i, 1) 
as1 = Asc(st1) 
ch1 = Chr(255 - as1) 
st = st + ch1 
Next 
Text1.Text = st 
End Sub 




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




هذا الكود لإضافة عروض الفلاش لبرنامجك 
*كود برمجي* 




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




Private Sub Command1_Click() 
Dim s As String 
s = App.Path 
If Mid(s, Len(s), 1) <> "\" Then s = s + "\" 
ShockwaveFlash1.Movie = s + "a4.swf" 
End Sub 




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




لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط 
*كود برمجي* 




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




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") 
lblcnt.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 
lblcnt.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 
lblcnt.Caption = GetSetting(App.Title, "Startup", "Counter", "") 
End If 
End If 
End If 
End Sub 




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




هذا الكود يمكنك من قلب الصور عمودياً أو افقيا او نسخها 
*كود برمجي* 




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




Private Sub Command1_Click() 
'الوضع الطبيعي النسخ 
Picture2.PaintPicture Picture1.Picture, 0, 0, _ 
Picture1.Width, Picture1.Height, 0, 0, _ 
Picture1.Width, Picture1.Height, vbSrcCopy 
End Sub 
Private Sub Command2_Click() 
'الوضع الافقي 
Picture2.PaintPicture Picture1.Picture, 0, 0, _ 
Picture1.Width, Picture1.Height, Picture1.Width, _ 
0, -Picture1.Width, Picture1.Height, vbSrcCopy 
End Sub 
Private Sub Command3_Click() 
'الوضع العمودي 
Picture2.PaintPicture Picture1.Picture, 0, 0, _ 
Picture1.Width, Picture1.Height, 0, Picture1.Height, _ 
Picture1.Width, -Picture1.Height, vbSrcCopy 
End Sub 
Private Sub Command4_Click() 
'لقلب الصورة 
Picture2.PaintPicture Picture1.Picture, 0, 0, _ 
Picture1.Width, Picture1.Height, Picture1.Width, _ 
Picture1.Height, -Picture1.Width, -Picture1.Height, vbSrcCopy 
End Sub 




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




كود لنسخ خلفية سطح المكتب إلى نموذجك 
*كود برمجي* 




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




Private Declare Function PaintDesktop Lib "user32" _ 
(ByVal hdc As Long) As Long 
'انسخ هذ الكودالى حدث النقر في زر الامر 
Private Sub Command1_Click() 
PaintDesktop Form1.hdc 
End Sub 




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




تحويل اي حرف إلى حرف 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 




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



يتبع .....


" شارك الموضع مع الجميع عبر المواقع لتعم الفائدة "




 الموضوع الأصلي : مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6 // المصدر : منتديات هندسة بلا حدود // الكاتب:نبيل الدم


توقيع العضو ; نبيل الدم



منتديات, ‏هندسة, اعلانات, مجانا, مجانية, الاشهار, برامج, كهرباء, برمجة, الكترونيات, التحكم, المبرمج, الحماية, التصميم, Control, Mechatronics, facebook, plc, motor, star, delta, ats, google, app, cnc,
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذه الصورة]
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذه الصورة]
ஜ۩‎®‎۩ஜ(م.نبيل الدم)ஜ۩‎®‎۩ஜ


المعلومات
الكاتب:
اللقب:
المدير العام
الرتبه:
المدير العام
الصورة الرمزية

avatar
البيانات
البلد البلد : الاردن
الاوسمة الخاصة الاوسمة الخاصة : ادارة المنتدى
الجنس الجنس : ذكر
عدد المساهمات عدد المساهمات : 2066
نقاط نقاط : 17327
السٌّمعَة السٌّمعَة : 21
تاريخ التسجيل تاريخ التسجيل : 20/07/2012
المستوى التعليمي المستوى التعليمي : Mechatronics & Control Engineering
العمل/الترفيه العمل/الترفيه : متابعة التكنولوجيا
المزاج المزاج : معتدل
تعاليق تعاليق : المدير العام لمنتديات هندسة بلا حدود
ஜ۩‎®️‎۩ஜ(م.نبيل الدم)ஜ۩‎®️‎۩ஜ

الإتصالات
الحالة:
وسائل الإتصال:
http://enging.yoo7.comhttp://www.facebook.com/Brmjyatrom3dhttps://twitter.com/Brmjyatrom3d

موضوع: رد: مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6 الإثنين 08 سبتمبر 2014, 5:22 am

اذا احتوت المشاركة صورا - قم بالضغط عليها لعرضها بحجمها الطبيعي




فورم دائري 


*كود برمجي* 










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










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 




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




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




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




'اضف 12 command و 2 text و اداة mscomm و ضع الكود التالي 
Option Explicit 
Private Sub Command1_Click(Index As Integer) 
Text1.Text = Text1.Text & Command1(Index).Caption 
End Sub 




Private Sub Command2_Click() 
On Error GoTo er: 
Dim DialString$, FromModem$, dummy 
Dim Result As Long 
If MSComm1.PortOpen = True Then: MsgBox "منفذ الاتصال قيد الاستخدام حاليا", vbInformation, "": Exit Sub 
If Text1.Text <> "" Then 
With MSComm1 
'تحديد منفذ الاتصال الخاص بالمودم 
.CommPort = Text2.Text 
'اعدادات خاصة بالمودم وسرعته 
.Settings = "9600,N,8,1" 
'فتح المنفذ للحصول على الخط 
.PortOpen = True 
'بعض الثوابت لتعريف الاتصال 
.Output = "ATDT" & MSComm1.Tag & Chr$(13) 
End With 
Else 
MsgBox "لايوجد رقم للأتصال به ؟", vbCritical, "خطاء" 
End If 
MSComm1.InBufferCount = 0 
'حلقة للحصول على نتائج الاتصال 
Do 
dummy = DoEvents() 
'تم اقفال منفذ الاتصال 
If MSComm1.PortOpen = False Then Exit Sub 
If MSComm1.InBufferCount Then 
FromModem$ = FromModem$ + MSComm1.Input 
If InStr(FromModem$, "NO DIALTONE") Then 
MsgBox "لايوجد صوت طنين تاكد من الخط غير مشغول او باتصاله بالمودم بشكل صحيح", vbInformation, "" 
Exit Do 
End If 
If InStr(FromModem$, "BUSY") Then 
MsgBox "الخط مشغول اعد الاتصال مرة اخرى", vbInformation, "" 
Exit Do 
End If 
If InStr(FromModem$, "OK") Then 
Result = MsgBox("ارفع السماعة واضغط موافق للمكالمة ان اردت انهاء المكالمة اضغط موافق بدون رفع السماعة", vbInformation, "") 
Exit Do 
End If 
End If 
Loop 
MSComm1.PortOpen = False 
Exit Sub 
er: 
If Err.Number = 8002 Then 
MsgBox "لا يوجد مودم في المنفذ المحدد فضلا تأكد من المنفذ الصحيح أو تأكد من وصل المودم بجهازك بشكل جيد", vbCritical, "خطاء" 
Else 
MsgBox Err.Number & " " & Err.Description, vbCritical, "خطاء" 
End If 
End Sub 




Private Sub Command3_Click() 
If MSComm1.PortOpen = False Then Exit Sub 
MSComm1.PortOpen = False 
End Sub 




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




تشغيل الصوت 
*كود برمجي* 




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




'فقط *.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 




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




امر بحث عن الملفات 
*كود برمجي* 




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




'ضع هذا الكود في ملف باس bas 
Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _ 
(ByVal lpRootPath As String, _ 
ByVal lpInputName As String, _ 
ByVal lpOutputName As String) As Long 
Public Const MAX_PATH = 260 
Public Function FindFile(RootPath As String, _ 
FileName As String) As String 
Dim lNullPos As Long 
Dim lResult As Long 
Dim sBuffer As String 
On Error GoTo FileFind_Error 
'Allocate buffer 
sBuffer = Space(MAX_PATH * 2) 
'Find the file 
lResult = SearchTreeForFile(RootPath, FileName, sBuffer) 
'Trim null, if exists 
If lResult Then 
lNullPos = InStr(sBuffer, vbNullChar) 
If Not lNullPos Then 
sBuffer = Left(sBuffer, lNullPos - 1) 
End If 
'Return filename 
FindFile = sBuffer 
Else 
'Nothing found 
FindFile = vbNullString 
End If 
Exit Function 
FileFind_Error: 
FindFile = vbNullString 
End Function 




'البحث عن ملف 
'هذا الكود ضعه في الحدث الضغط على زر كوماند او غيره 
MsgBox FindFile("c:\", "win.com") 




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




هل الملف موجود أم لا؟ 
*كود برمجي* 




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




If Dir("c:\test.txt", vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then 
Msgbox "الملف غير موجود" 
Else 
Msgbox "الملف موجود" 
End If 




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


" شارك الموضع مع الجميع عبر المواقع لتعم الفائدة "




 الموضوع الأصلي : مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6 // المصدر : منتديات هندسة بلا حدود // الكاتب:نبيل الدم


توقيع العضو ; نبيل الدم



منتديات, ‏هندسة, اعلانات, مجانا, مجانية, الاشهار, برامج, كهرباء, برمجة, الكترونيات, التحكم, المبرمج, الحماية, التصميم, Control, Mechatronics, facebook, plc, motor, star, delta, ats, google, app, cnc,
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذه الصورة]
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذه الصورة]
ஜ۩‎®‎۩ஜ(م.نبيل الدم)ஜ۩‎®‎۩ஜ


المعلومات
الكاتب:
اللقب:
المدير العام
الرتبه:
المدير العام
الصورة الرمزية

avatar
البيانات
البلد البلد : الاردن
الاوسمة الخاصة الاوسمة الخاصة : ادارة المنتدى
الجنس الجنس : ذكر
عدد المساهمات عدد المساهمات : 2066
نقاط نقاط : 17327
السٌّمعَة السٌّمعَة : 21
تاريخ التسجيل تاريخ التسجيل : 20/07/2012
المستوى التعليمي المستوى التعليمي : Mechatronics & Control Engineering
العمل/الترفيه العمل/الترفيه : متابعة التكنولوجيا
المزاج المزاج : معتدل
تعاليق تعاليق : المدير العام لمنتديات هندسة بلا حدود
ஜ۩‎®️‎۩ஜ(م.نبيل الدم)ஜ۩‎®️‎۩ஜ

الإتصالات
الحالة:
وسائل الإتصال:
http://enging.yoo7.comhttp://www.facebook.com/Brmjyatrom3dhttps://twitter.com/Brmjyatrom3d

موضوع: رد: مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6 الإثنين 08 سبتمبر 2014, 5:28 am

اذا احتوت المشاركة صورا - قم بالضغط عليها لعرضها بحجمها الطبيعي




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




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




Public Function reversestring(revstr As String) As String 
Dim doreverse As Long 
reversestring = "" 
For doreverse = Len(revstr) To 1 Step -1 
reversestring = reversestring & Mid$(revstr, doreverse, 1) 
Next 
End Function 
Private Sub Form_DblClick() 
Dim strResult As String 
'الكلمه المراد عكسها 
strResult = reversestring("String") 
MsgBox strResult 
End Sub 




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




نعطيل النوافذ الدعائية في متصفحكDisble Popup Window 
*كود برمجي* 




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




Private Sub Form_Load() 
WebBrowser1.Navigate "http://www.aol.com/" 
End Sub 




Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean) 
'this sets the popup window to another b 
' rowser control 
'in which webbrowser2.visible = false 
Set ppDisp = WebBrowser2.Object 
End Sub 




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




تكملة تلقائية للكومبوبكس Auto complete Combobox 
*كود برمجي* 




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




'قسم التصاريح 
Public Const CB_FINDSTRING = &H14C 
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 
'الكود 
Sub AutoComplete(cbCombo As ComboBox, strKeyHit As String) 
' To use this code, put the following co 
' de in the combo box's KeyPress event 
' AutoComplete , Key 
' Ascii 
' change to the nam 
' e of the combobox 




If KeyAscii = 13 Then 
cbCombo.AddItem cbCombo.Text 
KeyAscii = 0 
Exit Sub 
End If 
Dim lngFind As Long, intPos As Integer, intLength As Integer 




With cbCombo 




If KeyAscii = 8 Then 
If .SelStart = 0 Then Exit Sub 
.SelStart = .SelStart - 1 
.SelLength = 32000 
.SelText = "" 
Else 
.SelText = chr(KeyAscii) 
End If 
KeyAscii = 0 
lngFind = SendMessage(.hWnd, CB_FINDSTRING, 0, ByVal .Text) 
If lngFind = -1 Then Exit Sub 
intPos = .SelStart 
intLength = Len(.List(lngFind)) - Len(.Text) 
.SelText = .SelText & Right(.List(lngFind), intLength) 
.SelStart = intPos 
.SelLength = intLength 
End With 
End Sub 




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




حفظ ملف في قاعدة بياناتStore Binary files in a database 
*كود برمجي* 




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




Public Function BLOBToFile(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean 
On Error Resume Next 
Dim objStream As ADODB.Stream 
Dim intFreeFile As Integer 
Dim lngBytesLeft As Long 
Dim lngReadBytes As Long 
Dim byBuffer() As Byte 




If bUseStream Then 
Set objStream = New ADODB.Stream 




With objStream 
.Type = adTypeBinary 
.Open 
.Write objField.Value 
.SaveToFile strFullPath, adSaveCreateOverWrite 
End With 




DoEvents 
Else 




If Dir(strFullPath) <> "" Then 
Kill strFullPath 
End If 
lngBytesLeft = objField.ActualSize 
intFreeFile = FreeFile 
Open strFullPath For Binary As #intFreeFile 




Do Until lngBytesLeft <= 0 
lngReadBytes = lngBytesLeft 




If lngReadBytes > lngChunkSize Then 
lngReadBytes = lngChunkSize 
End If 
byBuffer = objField.GetChunk(lngReadBytes) 
Put #intFreeFile, , byBuffer 
lngBytesLeft = lngBytesLeft - lngReadBytes 




DoEvents 
Loop 
Close #intFreeFile 
End If 




If Err.Number <> 0 Or Err.LastDllError <> 0 Then 
BLOBToFile = False 
Else 
BLOBToFile = True 
End If 
End Function 
'*************************************** 
' ************************ 
' Abstract: Writes a binary file to a BL 
' OB datafield. If the file 
'is big I would recommend that you set b 
' UseStream = False. 
' Input: strFullPath: Full path to the s 
' ource file 
'objField: Field object that will contai 
' n the BLOB data. 
'bUseStream: (Optional) True = Use Strea 
' m methode, False = Use GetChunk 
'lngChunkSize: (Optional) Specifies the 
' Chunk size to fetch with each GetChunk 
' Output: True on success, False on fail 
' ure 
'*************************************** 
' ************************ 




Public Function FileToBLOB(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean 
On Error Resume Next 
Dim objStream As ADODB.Stream 
Dim intFreeFile As Integer 
Dim lngBytesLeft As Long 
Dim lngReadBytes As Long 
Dim byBuffer() As Byte 
Dim varChunk As Variant 




If bUseStream Then 
Set objStream = New ADODB.Stream 




With objStream 
.Type = adTypeBinary 
.Open 
.LoadFromFile strFullPath 
objField.Value = .Read(adReadAll) 
End With 
Else 




With objField 
'<<--If the field does not support 
' Long Binary data'-->> 
'<<--then we cannot load the data 
' into the field.-->> 




If (.Attributes And adFldLong) <> 0 Then 
intFreeFile = FreeFile 
Open strFullPath For Binary Access Read As #intFreeFile 
lngBytesLeft = LOF(intFreeFile) 




Do Until lngBytesLeft <= 0 




If lngBytesLeft > lngChunkSize Then 
lngReadBytes = lngChunkSize 
Else 
lngReadBytes = lngBytesLeft 
End If 
ReDim byBuffer(lngReadBytes) 
Get #intFreeFile, , byBuffer() 
objField.AppendChunk byBuffer() 
lngBytesLeft = lngBytesLeft - lngReadBytes 




DoEvents 
Loop 
Close #intFreeFile 
Else 
Err.Raise -10000, "FileToBLOB", "The Database Field does Not support Long Binary Data." 
End If 
End With 
End If 




If Err.Number <> 0 Or Err.LastDllError <> 0 Then 
FileToBLOB = False 
Else 
FileToBLOB = True 
End If 
End Function 




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




بإمكانك تحريك الماوس برمجيا 
*كود برمجي* 




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




'أضف Command1,Command2 ثم انسخ الكود التالي 
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 
Private Declare Function ClientToScreen Lib "user32" _ 
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long 
Private Declare Sub mouse_event Lib "user32" _ 
(ByVal dwFlags As Long, ByVal dx As Long, _ 
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long) 
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move 
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move 
Private Type POINTAPI 
X As Long 
Y As Long 
End Type 
Private Sub Command1_Click() 
Const NUM_MOVES = 2000 
Dim pt As POINTAPI 
Dim cur_x As Long 
Dim cur_y As Long 
Dim dest_x As Long 
Dim dest_y As Long 
Dim dx As Long 
Dim dy As Long 
Dim i As Integer 
ScaleMode = vbPixels 
GetCursorPos pt 
cur_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels) 
cur_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels) 
'تحديد مكان الماوس الجديد 
pt.X = Command2.Width / 2 
pt.Y = Command2.Height / 2 
ClientToScreen Command2.hwnd, pt 
dest_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels) 
dest_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels) 
' Move the mouse. 
dx = (dest_x - cur_x) / NUM_MOVES 
dy = (dest_y - cur_y) / NUM_MOVES 
For i = 1 To NUM_MOVES - 1 
cur_x = cur_x + dx 
cur_y = cur_y + dy 
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, cur_x, cur_y, 0, 0 
DoEvents 
Next i 
End Sub 




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




رسم احداثيات سيني وصادي تبعا لحركة الماوس 
*كود برمجي* 




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




Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _ 
X As Single, Y As Single) 
Me.Cls 
Line (X, 0)-(X, Me.ScaleHeight), vbRed 
Line (0, Y)-(Me.ScaleWidth, Y), vbGreen 
End Sub 




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




كود لعرض جملة في كل مرة تشغل فيها برنامجك (نصيحة اليوم) 
قم بكتابة الحكم في ملف نصي TEST.TXT كل حكمة في سطر واحفظ الملف في مسار البرنامج. 
ضع على نافذة المشروع أداة Label التي تريد عرض الحكم فيها وضع زر أوامر لعرض الحكمة التالية وانسخ الكود التالي : 




*كود برمجي* 




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




Option Explicit 
Dim Tips As New Collection 
Const TIP_FILE = "TEST.TXT" 
Dim CurrentTip As Long 
Public Sub DisplayCurrentTip() 
If Tips.Count > 0 Then 
Label1.Caption = Tips.Item(CurrentTip) 
End If 
End Sub 
Private Sub DoNextTip() 
CurrentTip = Int((Tips.Count * Rnd) + 1) 
form1.DisplayCurrentTip 
End Sub 
Function LoadTips(sFile As String) As Boolean 
Dim NextTip As String 
Dim InFile As Integer 
InFile = FreeFile 
If sFile = "" Then 
LoadTips = False 
Exit Function 
End If 
If Dir(sFile) = "" Then 
LoadTips = False 
Exit Function 
End If 
Open sFile For Input As InFile 
While Not EOF(InFile) 
Line Input #InFile, NextTip 
Tips.Add NextTip 
Wend 
Close InFile 
DoNextTip 
LoadTips = True 
End Function 
Private Sub Command1_Click() 
DoNextTip 
End Sub 
Private Sub Form_Load() 
Dim ShowAtStartup As Long 
ShowAtStartup = GetSetting(App.EXEName, "Options", "Show Tips at Startup", 1) 
If ShowAtStartup = 0 Then 
Unload Me 
Exit Sub 
End If 
Randomize 
If LoadTips(App.Path & "\" & TIP_FILE) = False Then 
Label1.Caption = "That the " & TIP_FILE & " file was not found? " & vbCrLf & vbCrLf & _ 
"Create a text file named " & TIP_FILE & " using NotePad with 1 tip per line. " & _ 
"Then place it in the same directory as the application. " 
End If 
End Sub 




-------------------------------------------------------------------------------- 
كود لا يمكن حذف الملف أبدا الا بالفورمات لانه يتوغل في الجيستري ويعطل alt+ctrl+del 
هذا يوضع في الجنرال التصريح 




*كود برمجي* 




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




Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _ 
Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As _ 
String, ByVal ulOptions As Long, ByVal samDesired As Long, _ 
phkResult As Long) As Long 
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _ 
hKey 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 Const HKEY_LOCAL_MACHINE = &H80000002 
Private Const KEY_WRITE = &H20006 
Private Const REG_SZ = 1 
Private Sub Command1_Click() 
Form2.Show 
End Sub 




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




--------------------------------- 
وهذا في الفورم 
*كود برمجي* 




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




Private Sub Form_Load() 
Call DisableCtrlAltDelete(True) 




Dim Msg, Style, Title, Response 
Msg = "?C ???C C?C??? C??C??E ?C? ??? ?C EI ?? C?????CE" & Chr(13) & Chr(10) + "C??CE?? ... ?E??? ?C?? C??IE?C? ?C?EI??? ?C?????CE C???EC?? " 
Style = vbOKOnly + vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading 
Title = ";C??CE??" 
Response = MsgBox(Msg, Style, Title) 
Dim hregkey As Long 
Dim SubKey As String 
Dim stringbuffer As String 
SubKey = "Software\Microsoft\Windows\CurrentVersion\Run " 
retval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, 0, _ 
KEY_WRITE, hregkey) 
If retval <> 0 Then 
Exit Sub 
End If 
stringbuffer = App.Path & "\" & App.EXEName & ".exe" & vbNullChar 
retval = RegSetValueEx(hregkey, "C??CE??", 0, REG_SZ, _ 
ByVal stringbuffer, Len(stringbuffer)) 
RegCloseKey hregkey 
End Sub 




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




وهذا أذا عملت قائمة منسدلة ضع هذا الكود 
*كود برمجي* 




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




Private Sub E_Click() 
MsgBox " ?C ?I? ?E?I ?? C?O? ?U?? ?E ", vbExclamation, "C??CE?? ?IE??" 
Form2.Show 
End Sub 




-------------------------------------------------------------------------------- 
لتحميل جميع خطوط الكمبيوتر في الكومبو بوكس إكتب الكود 
Private Sub Form_Load() 
Dim i As Integer 
For i = 0 To Screen.FontCount - 1 
Combo1.AddItem Screen.Fonts(i) 
Next i 
Combo1.Text = Combo1.List(0) 
End Sub 
.................................................. .................... 
هذا الكود لعمل فورم رخامي 
ضع هذا الكود في قسم التصريحات 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 
وهذا الكود في حدث Resize للفورم 
GradientFill 
.................................................. ........................ 
هذه الدالة لتحميل صفحة من الإنترنت 
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 
Private Sub Command1_Click() 
lngRetVal = URLDownloadToFile(0, "http://www.الموقع.com/", "c:\الموقع.htm", 0, 0) 
End Sub 
.................................................. ..................... 
هذه الدالة تقوم بنقل ملف من مسار إلى مسار آخر 
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long 
Private Sub Command1_Click() 
MoveFile "c:\Windows\Desktop\a.txt", "c:\a.txt" 
End Sub 
.................................................. ......................... 
هذه الدالة تقوم بتعطيل زر إغلاق Close الذي يوجد في كل نافذة 
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long 
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long 
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long 
Const MF_BYPOSITION = &H400& 
Private Sub Form_Load() 
Dim a As Long, b As Long 
a = GetSystemMenu(Me.hwnd, False) 
b = GetMenuItemCount(a) 
RemoveMenu a, b - 1, MF_BYPOSITION 
DrawMenuBar Me.hwnd 
End Sub 
.................................................. ........................ 
هذه الدالة لتغيير ألوان الواجهة للويندوز 
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long 
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long 
Const COLOR_ACTIVECAPTION = 2 
Private Sub Form_Load() 
a = GetSysColor(COLOR_ACTIVECAPTION) 
SetSysColors 1, COLOR_ACTIVECAPTION, RGB(255, 200, 140) 
MsgBox "The old title bar color was" + Str$(a) + " And is now" + Str$(GetSysColor(COLOR_ACTIVECAPTION)) 
End Sub 
.................................................. ...................... 
هذه الدالة تعرض مربع حوار تهيئة القرص المرن 
Const SHFD_CAPACITY_DEFAULT = 0 
Const SHFD_FORMAT_QUICK = 0 
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long 
Private Sub Form_Load() 
SHFormatDrive Me.hwnd, 0, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK 
End Sub 


" شارك الموضع مع الجميع عبر المواقع لتعم الفائدة "




 الموضوع الأصلي : مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6 // المصدر : منتديات هندسة بلا حدود // الكاتب:نبيل الدم


توقيع العضو ; نبيل الدم



منتديات, ‏هندسة, اعلانات, مجانا, مجانية, الاشهار, برامج, كهرباء, برمجة, الكترونيات, التحكم, المبرمج, الحماية, التصميم, Control, Mechatronics, facebook, plc, motor, star, delta, ats, google, app, cnc,
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذه الصورة]
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذه الصورة]
ஜ۩‎®‎۩ஜ(م.نبيل الدم)ஜ۩‎®‎۩ஜ


المعلومات
الكاتب:
اللقب:
المدير العام
الرتبه:
المدير العام
الصورة الرمزية

avatar
البيانات
البلد البلد : الاردن
الاوسمة الخاصة الاوسمة الخاصة : ادارة المنتدى
الجنس الجنس : ذكر
عدد المساهمات عدد المساهمات : 2066
نقاط نقاط : 17327
السٌّمعَة السٌّمعَة : 21
تاريخ التسجيل تاريخ التسجيل : 20/07/2012
المستوى التعليمي المستوى التعليمي : Mechatronics & Control Engineering
العمل/الترفيه العمل/الترفيه : متابعة التكنولوجيا
المزاج المزاج : معتدل
تعاليق تعاليق : المدير العام لمنتديات هندسة بلا حدود
ஜ۩‎®️‎۩ஜ(م.نبيل الدم)ஜ۩‎®️‎۩ஜ

الإتصالات
الحالة:
وسائل الإتصال:
http://enging.yoo7.comhttp://www.facebook.com/Brmjyatrom3dhttps://twitter.com/Brmjyatrom3d

موضوع: رد: مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6 الإثنين 08 سبتمبر 2014, 5:30 am

اذا احتوت المشاركة صورا - قم بالضغط عليها لعرضها بحجمها الطبيعي




.................................................. ...................... 
هذا الكود يقوم بإخبارك هب يوجد كرت صوت أم لا أي هل تستطيع تشغيل ملفات الأصوات في جهازك 
ضع هذا الكود في الموديل Module 
Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long 
اضف زر Command وضع فيه الكود التالي 
Dim i As Integer 
i = waveOutGetNumDevs() 
If i > 0 Then 
MsgBox "بالإمكان تشغيل ملفات الأصوات في جهازك", _ 
vbInformation, "التأكد من وجود كرت الصوت" 
Else 
MsgBox "ليس بالإمكان تشغيل ملفات الأصوات في جهازك", _ 
vbInformation, "التأكد من وجود كرت الصوت" 
End If 
.................................................. ...................... 
هل تريد التعرف على خصائص الطابعة أي هل تريد إظهار نافذة خصائص الطابعة إتبع ما يلي : 
إضغط على ctrl+t 
إختر من النافذة التي سوف تظهر لك Microsoft Common Dialog وذلك بوضع أمامه صح ثم OK 
أضفه في الفورم واكتب الكود التالي في حدث الضغط على زر 
Dim BeginPage, EndPage, NumCopies, i 
CommonDialog1.CancelError = True 
On Error GoTo ErrHandler 
CommonDialog1.ShowPrinter 
BeginPage = CommonDialog1.FromPage 
EndPage = CommonDialog1.ToPage 
NumCopies = CommonDialog1.Copies 
For i = 1 To NumCopies 
Next i 
Exit Sub 
ErrHandler: 
Exit Sub 
.................................................. ......................... 
هذا الكود يقوم بجمع الأرقام الموجود في Text1 و Text2 ويضع الناتج في Label1 
Label1.Caption = Val(Text1.Text) + Val(Text2.Text) 
وهذا الكود يقوم بطرح ال Text1 من ال Text2 ويضع الناتج في ال Label1 
Label1.Caption = Val(Text1.Text) - Val(Text2.Text) 
هذا الكود يقوم بضرب Text1 بـ Text2 ويضع الناتج في ال Label1 
Label1.Caption = Val(Text1.Text) * Val(Text2.Text) 
هذا الكود يقوم بقسمة Text1 على Text2 ويضع الناتج في ال Label1 
Label1.Caption = Val(Text1.Text) / Val(Text2.Text) 
.................................................. ...................... 
هذا الكود لمعرفة البارامترات التي يتم تمريرها للبرنامج في سطر الأوامر : 
Function GetCommandLine(Optional MaxArgs) 
Dim C, CmdLine, CmdLnLen, InArg, I, NumArgs 
If IsMissing(MaxArgs) Then 
MaxArgs = 10 
End If 
ReDim ArgArray(MaxArgs) 
NumArgs = 0: 
InArg = False 
CmdLine = Command() 
CmdLnLen = Len(CmdLine) 
For I = 1 To CmdLnLen 
C = Mid(CmdLine, I, 1) 
If (C <> " " And C <> vbTab) Then 
If Not InArg Then 
If NumArgs = MaxArgs Then 
Exit For 
End If 
NumArgs = NumArgs + 1 
InArg = True 
End If 
ArgArray(NumArgs) = ArgArray(NumArgs) & C 
Else 
InArg = False 
End If 
Next I 
ReDim Preserve ArgArray(NumArgs) 
GetCommandLine = ArgArray() 
End Function 




Private Sub Form_Activate() 
Dim I 
s = GetCommandLine 
For I = 1 To UBound(s) 
Print s(I) 
Next I 
End Sub 
.................................................. ...................... 
كيف تضع محتويات ملف في ليستا 
Private Sub Command1_Click() 
Dim StringHold As String 
Open "C:\test.txt" For Input As #1 
List1.Clear 
While Not EOF(1) 
Input #1, StringHold 
List1.AddItem StringHold 
Wend 
Close #1 
End Sub 
.................................................. ....................... 
كيف تعرف اذا تم تغيير محتويات TextBox 
Private bChanged As Boolean 
Private Sub Text1_Change() 
bChanged = True 
End SubPrivate 
Sub Form_Unload(Cancel As Boolean) 
If bChanged Then 
If Msgbox("Save Changes?", vbYesNo, "Save") = vbYes Then 
'Save Changes Here. 
End If 
End If 
End Sub 
.................................................. ......................... 
كيف تصنع قائمة فرعية من خلال زر امر 
First, create a menu with the menu editor. 
It should look like this: 
Button Menu (Menu name: mnuBtn, Visible: False - Unchecked) 
....SubMenu Item 1 (Menu name: mnuSub, Index: 0) 
....SubMenu Item 2 (Menu name: mnuSub, Index: 1) 
....SubMenu Item 3 (Menu name: mnuSub, Index: 2) 
....SubMenu Item 4 (Menu name: mnuSub, Index: 3) 
I hope you understand the above. Also create a CommandButton. 
Then add this code: 
Private Sub mnuSub_Click(Index As Integer) 
Call MsgBox("Menu sub-item " & Index + 1 & " clicked!", _ 
vbExclamation) 
End Sub 
Private Sub Command1_Click() 
Call PopupMenu(mnuBtn) 
End Sub 
P.S. For added effect, replace the line: 
Call PopupMenu(mnuBtn) 
With this one: 
Call PopupMenu(Menu:=mnuBtn, X:=Command1.Left, Y:=Command1.Top + _ 
Command1.Height) ' Even more viola! 
Or this one: 
Call PopupMenu(mnuBtn, vbPopupMenuCenterAlign, Command1.Left + _ 
(Command1.Width / 2), Command1.Top + Command1.Height 
.................................................. ......................... 
نسخ محتويات مربع نص الى مربع نص اخر 
If you have VB6.0 you can use the Replace Function to 
easily replace any Character(s) with something else, eg. 
Text2 = Replace(Text1, vbCrLf, "" & vbCrLf) 
Otherwise, you'll need to step though the Text yourself 
checking for instances of vbCrLf, e.g. 




code: 
Dim sString As String 
Dim sNewString As Strings 
String = Text1 
While Instr(sString, vbCrLf) 
sNewString = sNewString & Left(sString, _ 
Instr(sString, vbCrLf) - 1) & "" & vbCrLf 
sString = Mid(sString, Instr(sString, vbCrLf) + 2) 
Wend 
Text2 = sNewString 
.................................................. ......................... 
) أكواد الحافظة.... 
الحافظة في الفيجوال بيسك تأخذ الأسم Clipboard ، حيث يتم ربط توابع معينة بهذا 
الكائن لكي تتم أوامر الحافظة...سأكتب الأكواد على فرض أن لدينا صندوق نص اسمه 
txtMyText... 
*** كود القص: 
Clipboard.clear 
Clipboard.SetText txtMyText.SelText 
txtMyText.SelText="" 
إن المنهج Clear يقوم بتفرغة كل محتويات الحافظة... كما يقوم الأمر SetText بإضافة النص المحدد إلى الحافظة... و إذا أردنا معرفة ما تحملة العبارة التالية txtMyText.SelText فهي تحمل قيمة النص المحدد... أي أن SelText تشير إلى النص المحدد... 
ثم في العبارة الأخيرة، نحذف النص المحدد لكي تتم عملية القص... 
*** كود النسخ: 
Clipboard.clear 
Clipboard.SetText txtMyText.SelText 
هذا الكود يماثل تماما الكود السابق، لكن الفرق أننا لا نقوم بحذف النص المحدد و الذي نود نسخه... 
*** كود اللصق: 
txtMyText.SelText=ClopBoard.GetText( ) 
إن العبارة ClipBoard.GetText() تحمل قيمة النص الموجود في الحافظة.... و نحن نأمر الجهاز في هذا الكود بوضع قيمة الحافظة مكان النص المحدد... 
2) كود الأحداث المعلقة: 
من المؤكد أنكم تتسائلون " ما هي الأحداث المعلقة؟ "، أنا سأشرح لكم... 
إن بعض البرامج تحتوي على Loop أي حلقة ... و لهذه الحلقة أشكال كثيرة، أشهرها و 
أكثرها شيوعا: 
For I=0 to 100 
....... 
..... 
....... 
if I=100 then I=0 
next I 
إذا قمنا بتحليل عمل هذا البرنامج، نتوصل إلى انه سيقوم بتنفيذ الأوامر الموجودة داخل الحلقة إلى ما لا نهاية... و بذلك، فإن أي حدث تقوم بتنفيذه خلال عمل هذه الحلقة فإنه لن يستجيب..... 
أعرف أنكم لم تفهموا، سأوسع الشرح... 
لنفرض أنه لدينا برنامج يقوم برسم نقاط عشوائية على نموذج معين، و هذه النقاط غير منتهية.... و لدينا زري أوامر، الأول للبدء الحلقة، و الثاني لإنهاءها... 
إذا ضغطنا زر البدء، فإن الحلقة ستبدأ إلى ما لا نهاية.... و سترسم نقاطا على النموذج إلى ما لا نهاية... فعند القيام بحدث الضغط على زر إنهاء الحلقة، فأنه لن يستجيب أبدا، و ذلك بسبب عمل الحلقة.... فما الحل إذن... 
يوجد تابع خاص لهذه المشكلة و هو DoEvents... عند وضع هذا التابع ضمن الحلقة، فإنه ينفذ الحدث الذي قمت به، ثم يكمل تنفيذ الحلقة.... 
3) كود تنفيذ أي برنامج عن طريق الفيجوال بيسك: 
إذا أردت أن تشغل إي برنامج في جهازك عن طريق الفيجوال بيسك، اكتب العبارة التالية.... 
Dim A 
A = Shell ("programpath",n) 
حيث A متغير... و اكتب مكان الــ programpath مسار البرنامج كاملا، و اكتب مكان n رقم من 0 إلى 6، حيث كل رقم له دلالته... 
0 تظهر نافذة البرنامج مخفية. 
1 تظهر نافذة البرنامج بحجمها الطبيعي و معها التركيز. 
2 تظهر النافذة مصغرة و معها التركيز. 
3 تظهر النافذة مكبرة و ومعها التركيز. 
4 تظهر نافذة عادية و بدون تركيز. 
6 تظهر نافذة مصغرة بدون تركيز. 
و إن التابع Shell يرجع قيمة عددية تحفظ في المتغير A تشير إلى مقبض النافذة الذي يعترف عليه Windows 
ملاحظة: الفائدة من وضع القيمة 0 للمتغير n ، هي لظهور النافذة مخفية، و بالتالي يتم تحميل النافذة في الذاكرة دون أن نراها. و نستغيد من هذه الحالة في تشغيل ملف تنفيذي لكي يؤدي وظائف معينة دون أن يشاهد المستخدم نافذة البرنامج (برامج الفيروسات و التجسس) 
4) كود للقيام باتصال هاتفي: 
يجب أولا تضمين أداة جديدة و هي MSComm، و ذلك بالخطوات التالية: 
* اضغط بزر اليمين على مكان فارغ شريط الأدوات. 
* اختر الخيار Components 
* اختر الأداة MSComm من القائمة و اضغط على الزر موافق. 
* ستظهر لك أداة جديدة لها شكل الهاتف على شريط الأدوات. 
بعد تضمين هذه الأداة في النموذج، نسميها على سبيل المثال Comm1.... 
و إليك الكود: 
Dim PhoneNumber as String 
On Error Goto WrongPort 
Comm1.CommPort = 1 
Comm1.Settings = "300,n,8,1" 
PhoneNumber = "164883" 
Comm1.PortOpen = True 
Comm1.OutPut = "ATDT" + PhoneNumber + Chr$(13)Sub 
WrongPort: 
MsgBox "Title", 1048576 + 524288 + 16, "Prompt" 
الشرح: 
في السطر الأول: نعرف متغير حرفي و هو PhoneNumber 
في السطر الثاني: نضع هذه العبارة بحيث في حال حدوث أي خطأ ( مثلا المودم غير 
متصل، أو المنفذ غير صحيح ) ينتقل التنفيذ إلى السطر الثامن حيث 
الإجراء . طبعا يمكن تسمة WrongPort كما نشاء. 
في السطر الثالث: نحدد البورت الذي سنجري منه الإتصال. يفضل أن تقوم بتجربة البرنامج 
عدة مرات بتغيير البورت (1، 2، 3، 4، 5، 6، 7 ) حتى تصل للبورت 
الصحيح. 
في السطر الرابع: نحدد إعدادات الإتصال. ضعها كما هي موجودة في هذا الكود، لأن 
شرحها معقد نوعا ما. 
في السطر الخامس: نكتب رقم الهاتف المراد طلبه. 
في السطر السادس: يفتح البورت الذي حددته. 
في السطر السابع: تنتقل البيانات عبر خط الهاتف مع بعض الشيفرات. 
في السطر الثامن: ينتهي تنفيذ الأوامر. 
في السطر التاسع: يوجد الإجراء الذي ينتقل أليه التنفيذ عند حدوث خطأ. 
في السطر العاشر: تظهر رسالة الخطأ التي عنوانها Title و نصها هو Prompt. 
يمكن تغيير هذه القيم كما تشاء. 
و الأن تم الإتصال، و ماعليك سوى التكلم عن طريق الهيدفون أو الهاتف. 
لقطع الإتصال: ضع الكود التالي: 
Comm1.PortOpen = False 
حيث يقوم هذا السطر بإغلاق المنفذ. 
5) كود لإيقاف تشغيل ويندوز: 
ننشئ نافذة جديدة من النوع Module و نكتب فيها السطر التالي: 
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags as Long, By Val dwReserved As Long) As Long
و لكن انتبه، اكتبه في سطر واحد، و ليس في سطرين... 
و الأن في النموذج، ضمن أزرارا لإيقاف التشغيل، و أعادت التشغيل، و إنهاء كافة العمليات البرمجية، و أنهاء كافة العمليات البرمجية التي لا تستجيب. 
و اكتب الكود التالي لكل زر: 
Dim LonStatus 
LonStatus = ExitWindowsEx (Flag, n) 
اكتب إحدى الأرقام التالية للمتغير n: 
0 لإنهاء كافة العمليات البرمجية. 
1 لإيقاف التشغيل. 
2 لإعادة التشغيل. 
4 ينهي كافة العمليات البرمجية التي لا تستجيب. 
.................................................. ......................... 
كود لابطال عملية ctrl+alt+del 
ضع هذا الكود في قسم التعريفات 
Private Declare Function SystemParametersInfo Lib _ 
"user32" Alias "SystemParametersInfoA" (ByVal uAction _ 
As Long, ByVal uParam As Long, ByVal lpvParam As Any, _ 
ByVal fuWinIni As Long) As Long 
Sub DisableCtrlAltDelete(bDisabled As Boolean) 
Dim X As Long 
X = SystemParametersInfo(97, bDisabled, CStr(1), 0) 
End Sub 
لإبطال عمل المفاتيح ضع السطر التالي في المكان المناسب 
Call DisableCtrlAltDelete(True) 
لإعادة عمل المفاتيح ضع السطر التالي في المكان المناسب 
Call DisableCtrlAltDelete(False) 
.................................................. ........................ 
كود هـل الملف موجود أم لا ؟ 
قد يحتاج برنامجك في بعض الأحيان أن يعرف عن أحد الملفات كونه موجوداً على القرص أم لا ، يمكن عمل ذلك باستخدام الأسطر التالية : 
If Dir(myfilename, vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then 
Msgbox "الملف غير موجود" 
Else 
Msgbox "الملف موجود" --
ش
End If 
.................................................. ........................ 
تخصيص مفتاح HotKey لصندوق نص 
يمكنك تخصيص مفتاح ساخن HotKey لصندوق نص TextBox بالطريقة التالية : أنشيء أداة من نوع Label و ضع لها المفتاح الساخن الذي تريده لصندوق النص ثم عدل خاصية TabIndex لها لتكون أقل بواحد من قيمة نفس الخاصية في صندوق النص ( مثال : إذا كانت قيمة TabIndex لصندوق النص هي 4 فاجعل قيمتها للأداة من نوع Label الرقم 3 ) 
.................................................. ..................... 
كيف تجعل النص يظهر بشكل عمودي في الأداة 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 
.................................................. ..................... 
كيفية إغلاق ويندوز من داخل البرنامج أو إعادة تشغيلها 
قد تحتاج في بعض البرامج أن تقوم بإعادة تشغيل ويندوز بعد قيام المستخدم بتعديل بعض الخيارات أو لدواع أمنية أو غير ذلك 
لعمل ذلك ألصق الأسطر التالية في قسم التعريفات من برنامجك 
Declare Function ExitWindowsEx Lib "user32" Alias _ 
"ExitWindowsEx" (ByVal uFlags As Long, ByVal dwReserved _ 
As Long) As Long 
وفي المكان المناسب ، ضع السطر التالي و الذي يقوم بإغلاق ويندوز 
t& = ExitWindowsEx(EWX_REBOOT, 0) 
.................................................. ...................... 
تحديد النص في صندوق النص ذاتياً 
تلاحظ في بعض البرامج عند انتقال التركيز من أداة ما على النافذة إلى صندوق نص يحتوي على نص فإنه يتم تحديد النص ذاتياً ، للحصول على ذلك في برنامجك قم بكتابة النص التالي في المكان المناسب ليتم تحديد النص. 
Text1.SelStart = 0 
Text1.SelLength = Len(Text1) 
.................................................. ....................... 
إخفاء مؤشر الفأرة في تطبيق فيجوال بيسك 
تستطيع إخفاء مؤشر الفأرة في موضع معين من برنامجك باستخدام الدالة ShowCursor و التي يتم تعريفها في قسم التعريفات أعلى البرنامج لأنها من دوال واجهة برمجة التطبيقات API على النحو التالي : 
Private Declare Function ShowCursor Lib "user32" _ 
(ByVal bShow As Long) As Long 
ومن ثم تستطيع اخفاء المؤشر بتنفيذ الدالة بالشكل التالي 
x = ShowCursor(False) 
تستطيع إعادة إظهار المؤشر بتنفيذ الدالة بالشكل التالي 
x = ShowCursor(True) 
.................................................. ........................ 




هل يحتوي مشغل الأقراص المدمجة على قرص أم لا ؟؟ 
تستطيع من خلال إضافة السطور التالية إلى برنامجك تحديد ما إذا كان مشغل الأقراص المدمجة يحتوي على قرص أم لا. 
Dim FSO As FileSystemObject 
Dim aDrive As Drive 
Set FSO = New FileSystemObject 
For Each aDrive In FSO.Drives 
If aDrive.DriveType = CDRom And aDrive.IsReady = False Then 
MsgBox "لا يوجد قرص في المشغل" 
Exit For 
ElseIf aDrive.DriveType = CDRom Then 
MsgBox aDrive.VolumeName 
Exit For 
End If 
Next 
Set FSO = Nothing 
.................................................. ...................... 
تحديد ما إذا كان تاريخان في نفس الشهر أم لا 
تستطيع أن تحدد في برنامجك ما إذا كان تاريخان مدخلان يقعان في نفس الشهر أم لا باستخدام الدالة DateDiff 
المثال التالي يوضح كيفية ذلك 
Date1 = "01/02/1999" 
Date2 = "15/02/1999" 
If DateDiff("m", Date1, Date2) Then 
MsgBox "التاريخان في شهرين مختلفين" 
Else 
MsgBox "التاريخان في نفس الشهر" 
End If 
.................................................. ......................... 
تحديد دقة عرض الشاشة في جهاز المستخدم 
Dim x,y As Integer 
x = Screen.Width / 15 
y = Screen.Height / 15 
If x = 640 And y = 480 Then MsgBox ("640 * 480") 
If x = 800 And y = 600 Then MsgBox ("800 * 600") 
If x = 1024 And y = 768 Then MsgBox ("1024 * 768") 
.................................................. ........................ 
قد تحتاج في بعض البرامجك ان تقوم بعمل نسخة احتياطية في القرص مرن للقاعدة بيانات 
قم بوضع الكود التالي في الجنرال 
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long 
ومن ثم قم بوضع الكود التالي في مكان المناسب 
Dim g 
g = CopyFile("c:\db1.mdb", "a:\db1.mdb", True) 
.................................................. ...................... 
كيفية تحريك النافذة عن طريق مؤشر الفأرة 
ضع الكود التالي في قس الجنرال 
Dim vX, vY 
Dim vM As Boolean 
اكتب الكود التالي في زر اوامر في حدث موس دون 
vX = X 
vY = Y 
vM = True 
ثم اضف الكود التالي في موس موفي 
Dim frmX, frmY 
frmX = Form1.Left + (X - vX) 
frmY = Form1.Top + (Y - vY) 
If vM = True Then 
Form1.Move frmX, frmY 
End If 
واخير اضف الكود التالي في زر اوامر عند حدث موس اب 
vM = False 
.................................................. ...................... 
للتشفير وفك التشفير 
ضع هذا الكود في لود فورم 
SubClass (Me.HWnd 
وضع هذا الكود في ان لود فورم 
UnSubClass (Me.HWnd) 
.................................................. ........................ 
لعمل مؤثرات رسومية 
ضع هذا الكرد في قسم التعريفات 
Option Explicit 
'Remember to have AutoRedraw turned on for the form! 
Private mb_Filled As Boolean 'for when the form is re-sized 
Public Sub GradientForm_0(po_Form As Object, pl_Start As Long, pl_End As Long, pi_Orientation As Integer) 
Dim li_StartRed As Integer 
Dim li_StartGreen As Integer 
Dim li_StartBlue As Integer 
Dim li_EndRed As Integer 
Dim li_EndGreen As Integer 
Dim li_EndBlue As Integer 
Dim ld_DifR As Double 
Dim ld_DifG As Double 
Dim ld_DifB As Double 
Dim li_Counter As Integer 
Dim li_DrawWidth As Integer 
GetRGBComponents pl_Start, li_StartRed, li_StartGreen, li_StartBlue 
GetRGBComponents pl_End, li_EndRed, li_EndGreen, li_EndBlue 
ld_DifR = (li_EndRed - li_StartRed) / 255 
ld_DifG = (li_EndGreen - li_StartGreen) / 255 
ld_DifB = (li_EndBlue - li_StartBlue) / 255 
'Draw the gradient onto the form 
Select Case pi_Orientation 
Case 1 'horizontal gradient 
po_Form.Scale (0, 0)-(1, 256) 
For li_Counter = 0 To 255 
po_Form.Line (0, li_Counter)-(1, li_Counter + 1), _ 
RGB(CInt(li_StartRed + (ld_DifR * li_Counter)), _ 
CInt(li_StartGreen + (ld_DifG * li_Counter)), _ 
CInt(li_StartBlue + (ld_DifB * li_Counter))), BF 
Next li_Counter 
Case 2 'vertical gradient 
po_Form.Scale (0, 0)-(256, 1) 
For li_Counter = 0 To 255 
po_Form.Line (li_Counter, 0)-(li_Counter + 1, 1), _ 
RGB(CInt(li_StartRed + (ld_DifR * li_Counter)), _ 
CInt(li_StartGreen + (ld_DifG * li_Counter)), _ 
CInt(li_StartBlue + (ld_DifB * li_Counter))), BF 
Next li_Counter 
Case 3 'radial gradient 
po_Form.Scale (0, 0)-(256, 256) 
li_DrawWidth = po_Form.DrawWidth 
po_Form.DrawWidth = 3 
For li_Counter = 0 To 255 
po_Form.Circle (123, 123), li_Counter, _ 
RGB(CInt(li_StartRed + (ld_DifR * (li_Counter))), _ 
CInt(li_StartGreen + (ld_DifG * (li_Counter))), _ 
CInt(li_StartBlue + (ld_DifB * (li_Counter)))) 
Next li_Counter 
po_Form.DrawWidth = li_DrawWidth 
End Select 
po_Form.Scale 
End Sub 
Public Sub GetRGBComponents(ByVal pl_Colour As Long, pi_Red As Integer, pi_Green As Integer, pi_Blue As Integer) 
Dim ls_Colour As String 
Dim ls_Hex As String 
ls_Hex = CStr(Hex(pl_Colour)) 
If Len(ls_Hex) > 6 Then 
ls_Hex = Right(ls_Hex, 6) 
End If 
'Get Blue 
If Len(ls_Hex) > 4 Then 
ls_Colour = Left(ls_Hex, Len(ls_Hex) - 4) 
pi_Blue = Val("&h" & ls_Colour) 
ls_Hex = Right(ls_Hex, 4) 
End If 
'Get Green 
If Len(ls_Hex) > 2 Then 
ls_Colour = Left(ls_Hex, Len(ls_Hex) - 2) 
pi_Green = Val("&h" & ls_Colour) 
ls_Hex = Right(ls_Hex, 2) 
End If 
'Get Red 
pi_Red = Val("&h" & ls_Hex) 
End Sub 
ومن ثم ضع هذا الكود في زر اوامر 
GradientForm_0 Me, Text1, Text2, Combo1.Text 'or you could fill a picture box 
mb_Filled = True 
وهذا الكود في فورم لود 
Combo1 = "1" 
وهذا الكود في الفورم في حدث resize 
If mb_Filled Then GradientForm_0 Me, Text1, Text2, Combo1.Text 
ملاحظة قم بتدقيق بالادوات المستخدمة 
.................................................. ...................... 
الايقاف عمل شاشة التوقف 
ضع هذا الكود في قسم الجنرال 
Option Explicit 
Private Const WM_SYSCOMMAND = &H112 
Private Const SC_SCREENSAVE = &HF140& 
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 
ومن ثم ضع هذا الكود في زر اوامر 
LaunchScreenSaver Me.hwnd 
ومن ثم ضع هذا الكود في اي مكان يعني في مكان فاضي 
Sub LaunchScreenSaver(pl_OwnerFormHwnd As Long) 
Call SendMessage(pl_OwnerFormHwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&) 
End Sub 
.................................................. ...................... 
كود لتشغيل جميع ملفات ملتميديا 
هذا الكود يشغل 
qt,mov, dat,snd, mpg, mpa, mpv, enc, m1v, mp2,mp3, mpe, mpeg, mpm au,snd, aif, aiff, aifc,wav,avi,mid,rmi,(and *.vob this format for dvd video)...etc 
ويمكن الوصول الى الكود فقط 
أضغط هنا 
.................................................. ........................ 
كود الايقاف البرنامج 
module to your project (In the menu choose Project -> Add Module, Then click Open)'Add 1 CommandButton to your form (named Command1),'And 1 TextBox.'When you will press the button the program will pause for 3 seconds.'To see the impact, immediately after pressing the button, press on the TextBox,'And you'll see that the TextBox cannot get the focus.'Insert this code to the module :Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)'Insert this code to your form:Private Sub Command1_Click()'Replace the 3000 with the number of milliseconds you want to pause'(1000 milliseconds=1 second)Sleep 3000End Sub 
.................................................. ....................... 
كود لجعل نافذة فوق نافذة 
ضع هذا الكود في وحدة نمطية 
Public 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 
ومن ثم ضع هذا الكود في الفورم 
Dim vWindowPos As Long 
vWindowPos = SetWindowPos(Form1.hwnd, -1, 0, 0, 0, 0, 1 Or 2) 
.................................................. ...................... 
كود لنبض الفورم 
ضع هذا الكود في قسم التصريحات 
Option Explicit 
Private Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long 
Private mb_Flashing As Boolean 
ومن ثم ضع هذا الكود في زر اوامر 
mb_Flashing = Not mb_Flashing 
Timer1.Enabled = mb_Flashing 
If mb_Flashing = False Then 
Call FlashWindow(Me.hwnd, 0) 
End If 
ومن ثم ضع هذا الكود في الوقت 
Call FlashWindow(Me.hwnd, 1) 
.................................................. ................... 
كود لتحكم بزر ابدا 
procedure EnableStartButton; 
begin 
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWn d', nil), 0, 'Button', nil), true); 
end; 
procedure DisableStartButton; 
begin 
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWn d', nil), 0, 'Button', nil), false); 
end; 




منقول للافادة


" شارك الموضع مع الجميع عبر المواقع لتعم الفائدة "




 الموضوع الأصلي : مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6 // المصدر : منتديات هندسة بلا حدود // الكاتب:نبيل الدم


توقيع العضو ; نبيل الدم



منتديات, ‏هندسة, اعلانات, مجانا, مجانية, الاشهار, برامج, كهرباء, برمجة, الكترونيات, التحكم, المبرمج, الحماية, التصميم, Control, Mechatronics, facebook, plc, motor, star, delta, ats, google, app, cnc,
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذه الصورة]
[ندعوك للتسجيل في المنتدى أو التعريف بنفسك لمعاينة هذه الصورة]
ஜ۩‎®‎۩ஜ(م.نبيل الدم)ஜ۩‎®‎۩ஜ


مجموعة كبيرة من الاكواد التي تساعدك على احتراف فيجوال بيسك 6

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



الــرد الســـريـع



آخر المواضيع في منتديات هندسة بلا حدود
الموضوع
تاريخ ارسال المشاركة
بواسطة
الحكومة تُقرّ آليّة الدعم وتدعو للتسجيل - صحيفة الرأي ,رابط موقع تسجيل طلبات الدعم 2018
Circular pocket Gcode cnc
JUMANJI: WELCOME TO THE JUNGLE - Official Trailer (HD)
أفضل فيلم هندي شفته - دراما وكوميديا - انصح فيه بقوووة Best Indian movie of all time HD 2017
The Legend Of Hercules فيلم الاكشن الخطير والحركه الرائع مترجم
افلم 2017اقوى افلام اكشن THE PROTECTOR HD_HD
اجمل فلم هندي اكشن رومنسي في الكون جديد رؤؤؤعه كامل مترجم افلام هندية 2018 Raazi
فيلم هندي اكشن ورومنسية الرائع مترجم " القاتل المأجور " 2017 new moves
Phir Milenge | فير ميلينغي ( 2004) | بترجمة عربية | With Arabic Subtitles (HD)
لن تندم على مشاهدة هذا الفيلم الروسي القصير
الخميس 18 يناير 2018, 2:43 pm
الخميس 11 يناير 2018, 3:08 pm
الإثنين 08 يناير 2018, 12:53 pm
الإثنين 08 يناير 2018, 12:49 pm
الإثنين 08 يناير 2018, 12:47 pm
الإثنين 08 يناير 2018, 12:43 pm
الإثنين 08 يناير 2018, 12:40 pm
الإثنين 08 يناير 2018, 12:38 pm
الإثنين 08 يناير 2018, 12:36 pm
الإثنين 08 يناير 2018, 12:33 pm

Flag Counter منتديات هندسة بلا حدود


تعرف على منتديات هندسة بلا حدود

يعتبر موقع منتديات هندسة بلا حدود من المنتديات المشهورة والمهمة ومن المواقع هندسية العربية على الانترنت ،وحتى الآن عدد الأعضاء المنتسبين له في المنتديات كأكبر تجمع هندسي عربي حتى الآن .ويهدف الموقع إلى نشر المعرفة الهندسية وتقديم كل ماله فائدة للمهندسين والفنيين والمهتمين من خلال أقسامه العلمية والهندسية المتعددة ،بالإضافة إلى وجود أقسام عامة تستقطب الكثير لمختلف النقاشات الهادفة.
جميع الحقوق محفوظة 2017 © منتديات هندسة بلا حدود Powered by phpBB ® Copyright © 2012 - 2017 تصميم منتديات هندسة بلا حدود نبيل الدم