• الإعلانات

    • فيصل الحربي

      تسجيل عضوية جديدة في المنتدى   01/31/2016

      السلام عليكم ورحمة الله وبركاته  عزيزي العضو الجديد :  حاليا رسالة الإيميل لتأكيد صحة إيميلكم تذهب للبريد العشوائي ( جاري حل المشكلة )  فإذا لم تجد رسالة التحقق من إيميلكم في صندوق الوارد لديكم إتجه للبريد العشوائي ( JUNK)  وقم بتفعيل إشتراككم من هناك   

proegy

اعضاء
  • عدد المشاركات

    147
  • تاريخ الانضمام

  • تاريخ اخر زياره

كل شيء نشر بواسطة proegy

  1. انا كنت ناوي من فترة امتحن 70-290 و 70-291 بس كنت باجل لحد ماذاكرهم تمام بس الشغل مبيدنيش فرصة المهم كنت بتمني من اي حد يقدر يساعدني بتوفير احدث الإمتحانات الخاصة بيهم وافضل طريقة لمذاكرتهم وانا عندي test out بذاكر عن طريقة برضة ياريت لو في حد يقدر يساعد مايبخلش عليا وشكرا لكم جميعا مقدما وشكرا طبعا لALATTAR علي موضوعة ومساعدته للإعضاء
  2. :rolleyes: هذا لينك به الكثير من دروس الclass أرجو أن تفيدكم http://www.code-vb.com/help/dlg_frmClass.htm وهذ ا هو الموقع الرئيسي وبه الكثير من المواضيع المميزة والأدوات http://www.code-vb.com/ وشكرا أخوكم
  3. بخصوص امتحانات ال MCSE

    الـــف شــــــــكر علي المعلومات المفيدة
  4. الســـلام عليكم انا كان عندي استفسار بسيط انا عارف ان مش لازم اخد كل امتحانات ال mcse متتاليين بس الي عايز اعرفة :- 1- ينفع امتحن في اي مركز معتمد بدون مادرس فية بمعني اني هدرس كورسات ال testout وال traning kit فمش ناوي اخد الكورس ده في مركز من المراكز لان لقيت الكرسات دية ممكن تكفي اني افهم منها . 2- لما امتحن امتحان واحد بس باخد شهادة بية ولا مباخدش اي شهادة الا لما اخلص كل السبع امتحانات . 3- لو حد يعرف احدث الأسعار دلوقتي لامتحانات هذة الشهادة . واخيرا اشكركم جميعا مقدما علي اهتمامكم. :rolleyes:
  5. بخصوص امتحانات ال MCSE

    هل من مجيب ؟!! <_<
  6. :D Form resize and design control for VB6. Features auto scaling of controls, lines, shapes, graphics, and fonts, multicolor gradients, tile, fit to size, center backgrounds, MDI/MDI child support, print support independant of screen res, and more! ----------------------------------- http://www.gold-software.com/69.exe =========================================================== ويوجد الكثير من الأدوات الهامة والمفيدة هنا ;) ;) http://www.gold-software.com أخوكم B)
  7. :rolleyes: السلام عليكم اولا الموضوع كله على الاكواد ووظائفها عالم الكودات+تصميم مساعد أوفيس المتحرك+ winsock+خدع للأتصال بالأنترنت باستخدام ال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 -------------------------------------------------------------------------------- فورم دائري *كود برمجي* -------------------------------------------------------------------------------- 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 -------------------------------------------------------------------------------
  8. السلام عليكم انا عايز كودين كود تشغيل الكاميرا في الفيجول وكود التسجيل منها وحفظها علي الهارد في مكان محدد لها بأي امتداد فديو-1 كود فتح صوت الميك من ال volume control -2 وتسجيل الصوت من الميك وحفظه في مكان محدد علي الهارد بأمتداد صوتي ويفضل انه يكون ام بي ثري ممكن تساعدوني أخوكم :(
  9. :rolleyes: بسم الله الرحمن الرحيم نظرا لطلبات بعض الاعضاء عن وصله لتحميل برنامج الفجوال بيسك 6 فقد قمت بعمل بحث ووجدت وصله للبرنامج والحمد لله وارجو ان تنال رضاكم وصله التحميل معلومات عن الملف بالنسبه للحجم هو 75 ميجابيت و هو ملف مضغوط و بعد فك الضغط من عليه يصير 170 ميجابيت تقريبا و الكود موجود فى ملف أرفقته بداخله اسمه serial الباسورد لفك الضغطهنـــــــــــا الوصله منقوله من منتدى القمر كاتب الموضوع الاخ محمد shawky87 أخوكم :)
  10. تدخل على شبكة الانترنت وتتصفح مواقعها وتتحدث مع من تعرف ومن لا تعرف لساعات طويلة دون ان تشعر بالوقت.. هذا الاختبار البسيط ينبهك ان كنت من مدمني الشبكة. كم مرة وجدت انك بقيت على الإنترنت وقتاً اكثر مما كنت تعتزم ؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة أهملت الروتين المنزلي لقضاء وقت أطول على الشبكة ؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة فضلت الإثارة على الإنترنت بدلاً من الألفة مع صديقك ؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة قمت بعمل علاقة مع الأفراد الآخرين على الإنترنت ؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة تذمر منك الآخرون بسبب الوقت الذي تقضيه على الإنترنت؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة تأثرت نتائجك أو واجباتك بسبب الوقت الذي تقضيه على الشبكة؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة تفحص بريدك الإلكتروني قبل عمل شيء آخر يجب عليك عمله؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة تأثر أداؤك وإنتاجك في العمل بسبب الإنترنت؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة كنت كتوماً أو دفاعياً عندما يسألك الغير عما كنت تفعله على الإنترنت؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة وجدت نفسك متحمساً للمرة القادمة التي سوف تدخل فيها إلى الشبكة؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة صرخت او تصرفت بإنزعاج عندما يزعجك الآخرون وانت على الشبكة؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة راودتك الافكار المخيفة ان الحياة ستكون مملة وكئيبة وفارغة بدون الأنترنت ؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة خسرت نوماً هادئاً بسبب الدخول المتأخر في منتصف الليل؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة احسست انك مازلت مرتبطاً بالانترنت وتتخيله حتى بعد خروجك منه؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة وجدت انك تقول فقط لبضع دقائق اخرى وانت على الشبكة؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة وجدت انك اخفقت في التقليل من الوقت الذي تستغرقه على الشبكة؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة حاولت إخفاء الوقت الذي تستغرقه على الأنترنت؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة فضلت استخدام الأنترنت مدة اطول على الخروج مع الآخرين؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً كم مرة احسست انك محبط او مزاجي او قلق عندما تكون خارج الشبكة، وبمجرد دخولك على الانترنت يذهب هذا الاحساس؟ نادراً - أحيانا - بين فترة وفترة - كثيراً - دائماً الآن اجمع النقاط على هذا النحو: نادراً = 1 أحياناً =2 بين فترة وفترة = 3 كثيراً = 4 دائماً = 5 النتيجة: من( 20 إلى 49 ) نقطة: انت مستخدم معتدل للإنترنت، وقد تبحر في الشبكة لمدة طويلة نسبيا في بعض الأحيان، ولكن لديك قدرة التحكم في إستخدامك. من ( 50 إلى 79 ) نقطة: تواجه مشاكل من حين لآخر بسبب استخدامك للإنترنت، يجب أن تنتبه لآثار هذه المشاكل على حياتك. من ( 80 إلى 100 ) نقطة: استخدامك للأنترنت يسبب لك مشاكل خطيرة في حياتك ، يجب ان تقيّم تأثير هذه المشاكل على حياتك وتعالجها بشكل مباشر وموضوعي حتى لا تفتقد اشياء كثيرة ى حياتك :wacko: _-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_- أخوكم:rolleyes:
  11. الشكر لك يأخي العزيزmoh_89
  12. جملة IF انها جملة لايستغني عنها اي مبرمج مش في الفيجول بيزك بل في كل لغات البرمجة ============================== هناك عدة صور لجملة IF ********* الصورة العامة لهذة الجملة ------------------------------------ ^^^^^^^^^^^^^^^^^^^ IF(شرط)THEN ........................ ........................ الفعل المراد تنفيذة ....................... ....................... ELSE ................... ................... الفعل الثاني المراد تنفيذة .................. .................. END IF حيث (الشرط) هو الفعل المطلوب اختبار صحتة وهو تعبير منطقي قيمة الصواب أو الخطاء وإما ان يكون شرط بسيط أوشرط مركب 1-يقوم الحاسب بأجراء اختيار الشرط في الجملة 2- ذا كانت قيمة الشرط الصواب (أي اذا تحقق الشرط) نفذ مجموعة الجمل المحصورة بين كلمة THEN و ELSE ثم يذهب مباشرة لتنفيذ جملة END IF 3-اذا كانت قيمة الشرط خطاء (الشرط لم يتحقق الشرط)نفذ مجموعة الجمل المحصورة بين الكلمتين else و end if الشرط الثاني $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ الصورة البسيطة IF(شرط)THEN ........................ ........................ الفعل المراد تنفيذة ....................... ....................... END IF 1-يقوم الحاسب بأجراء اختيار الشرط في الجملة 2- ذا كانت قيمة الشرط الصواب (أي اذا تحقق الشرط) نفذ مجموعة الجمل المحصورة بين كلمة THEN ثم يذهب مباشرة لتنفيذ جملة END IF 3-اذا كانت قيمة الشرط خطاء (الشرط لم يتحقق الشرط)نفذ مجموعة الجمل التلي end if ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ نأتي الي أهم جملةمن جمل if الجملة المتداخلة IF(شرط)THEN ........................ ........................ الفعل المراد تنفيذة ....................... ....................... ELSEIF(2شرط)THEN ................... ................... الفعل الثاني المراد تنفيذة .................. .................. ELSEIF(شرط3)THEN ................... ................... الفعل الثالث المراد تنفيذة .................. .................. ELSEIF(شرط س)THEN ................... ................... الفعل االسلام عليكم ورحمة الله وبركاته المراد تنفيذة .................. .................. end if حيث الشروط من الشرط 1الي الشرط س هي مجموعة الشروط المطلوب اختيارها .وعند تنفيذ هذة الجمل يقوم الحاسب بأختبار صحة الشرط .فأذا كان هذا الشرط صحبحا يتم تنفيذ الجملة المحصورة بين then و else if اما اذا كان الشرط غير صحيح فيتم اختيار جمله else if علي التوالي وكل جملة علي حدة فاذا وجدت شرط صحيح فيتم تنفيذ هذة الجملة واذا لم يكن هناك ولا شرط صحيح يتم تنفيذ جملة end if *********************************************************** وبأذن الله هناك المزيد من الجمل الي حشرحة مثل go to التفرع بأستخدام select for/next do-loop قريبا ********************************************************* أخوكم :D
  13. شكرا لكم وجزاكم الله خيرا
  14. اقرأ وادعيلي

    شكرا لك علي الموضوع الجميل وانا كنت وضعت هذا الموضوع بعديك فأعزرني لم أكن أعلم انة موجود أخوك
  15. الحمد لله انها أعجبتكم وأخي muthanna أنا في انتظار الهدية بفارغ الصبر وشكرا علي مرورك أخوك
  16. شكرا علي ردوكم وانا ببحث الأن علي دروس بالعربي للكلاس وبأذن الله سأجدها وللأخ yasserstars انا لسة مجرب المواقع وطلعت شغالة فجرب وقلي أخوكم
  17. شكرا لتعقيبكم ولتنبهي بتعديل الرابط وها هو الرابط الجديد من هنا وانا اتفق معك أخي فواز الشمري ولكنها مفيده علي الرغم من ذلك علي الأقل للمبتديئين :rolleyes: أخوكم
  18. السلام عليكم طريقة صنع حماييه لبرنامجك عن طريق وضع يوزر وباس من هنا وهو موضوع هام أخوكم
  19. شكرا ليك اخي COMFORT وجزاك الله خيرا أخوك
  20. جزاكم الله كل الخير أخوكم