الخارق مرحباً بكم في شبكة ومنتديات الخارق |
| | مجموعة أكواد | |
| | كاتب الموضوع | رسالة |
---|
القمر
عدد الرسائل : 2 sms :
تاريخ التسجيل : 10/03/2008
| موضوع: مجموعة أكواد الإثنين مارس 10, 2008 4:07 am | |
| [justify]lمجموعة من الاكواد اتمن ان تعجبكم لان الملفات لاتتحمل [كودات رائعة وجميلة
للأتصال بالأنترنت باستخدام ال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
--------------------------------------------------------------------------------
كود لاضافة بيانات حقل معين في قاعدة البيانات الى عنصر 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
--------------------------------------------------------------------------------
عرض صندوق حوار 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() 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 | |
| | | القمر
عدد الرسائل : 2 sms :
تاريخ التسجيل : 10/03/2008
| موضوع: تابع الأكواد الإثنين مارس 10, 2008 4:07 am | |
| -------------------------------------------------------------------------------- كود لنسخ خلفية سطح المكتب إلى نموذجك *كود برمجي*
--------------------------------------------------------------------------------
Private Declare Function PaintDesktop Lib "user32" _ (ByVal hdc As Long) As Long
'انسخ هذ الكودالى حدث النقر في زر الامر Private Sub Command1_Click() PaintDesktop Form1.hdc End Sub
تحيه حسب الوقت *كود برمجي*
--------------------------------------------------------------------------------
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
كيف تصنع قائمة فرعية من خلال زر امر
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[/justify] | |
| | | | مجموعة أكواد | |
|
مواضيع مماثلة | |
|
مواضيع مماثلة | |
| |
| صلاحيات هذا المنتدى: | لاتستطيع الرد على المواضيع في هذا المنتدى
| |
| |
| |
|