Search the web
Sign In
New User? Sign Up
abo_elarbi · مجموعة ابو العربي
  • Members Only
  • Links
  • Polls
  • Groups Labs (Beta)
? Already a member? Sign in to Yahoo!

Yahoo! Groups Tips

Did you know...
Want your group to be featured on the Yahoo! Groups website? Add a group photo to Flickr.

Best of Y! Groups

   Check them out and nominate your group.
Having problems with message search? Fill out this form to ensure your group is one of the first to be migrated to the new message search system.

Messages

   Messages Help
Message #
Search:
Advanced
Start Topic
Messages 680 - 709 of 738   Newest  |  < Newer  |  Older >  |  Oldest
Messages: Show Message Summaries   (Group by Topic) Sort by Date v  
#709 From: "Dr. Mona" <mona25_2010@...>
Date: Wed Feb 28, 2007 2:49 pm
Subject: كتاب لتصبح محترفا في صيانة الحاسوب و انظمة الشبكات 		mona25_2010
Offline Offline
Send Email Send Email
 
 
كتاب رائع لتصبح محترفا في صيانة الحاسوب و انظمة الشبكات و الوزيد

http://www.4shared.com/file/8700736/...mlive_125.html
 

Group Email Addresses

Related Link: http://www.aboelarbi.tk/
Post message: abo_elarbi@yahoogroups.com
Subscribe: abo_elarbi-subscribe@yahoogroups.com
Unsubscribe: abo_elarbi-unsubscribe@yahoogroups.com
List owner: abo_elarbi-owner@yahoogroups.com



With my best wishes
 
Dr. Mona

Food fight? Enjoy some healthy debate
in the Yahoo! Answers Food Drink Q&A.

Reply | Forward | Messages in this Topic (1)
#708 From: "Dr. Mona" <mona25_2010@...>
Date: Wed Feb 28, 2007 2:46 pm
Subject: Windows Vista كتاب شامل بالعربي عن 		mona25_2010
Offline Offline
Send Email Send Email
 
يشتمل على كتاب عن وندوز فيسيتا والشرح بالصور

محتويات الكتاب

ويحتوى الكتاب على الاتى :-
1- معلومات فيستا
2- عملية التنصيب
3- خصائص الوندوز
4- البرامج المتوافقه مع وندوز فيستا
5- لمن وقع في مشكلة التحديث يوجد طريقتان لحل هذه المشكله
6- تفعيل فيستا لمن فاته التسجيل
7- مرفقات بها برامج ( الكراك + التنشيط + بعض البرامج الخدمية )
 
 
 
 
 
 
 
 

Group Email Addresses

Related Link: http://www.aboelarbi.tk/
Post message: abo_elarbi@yahoogroups.com
Subscribe: abo_elarbi-subscribe@yahoogroups.com
Unsubscribe: abo_elarbi-unsubscribe@yahoogroups.com
List owner: abo_elarbi-owner@yahoogroups.com



With my best wishes
 
Dr. Mona

Need Mail bonding?
Go to the Yahoo! Mail Q&A for great tips from Yahoo! Answers users.

Reply | Forward | Messages in this Topic (1)
#707 From: Adviser!!!Email <adviser.email.150806@...>
Date: Wed Jan 24, 2007 8:25 am
Subject: حكم التهنئة بالعام الهجري الجديد 		adviser_emai...
Offline Offline
Send Email Send Email
 
 

 

 

حكم التهنئة بالعام الهجري الجديد

 

السؤال : ما حكم التهنئة بمناسبة العام الهجري الجديد بقول : كل عام وأنتم بخير، أو بالدعاء بالبركة، وكأن يرسل رسالة يدعو فيها للمرسل إليه بالخير والبركة في عامه الجديد ؟


الإجابة : إن هنّأك أحد فَرُدَّ عليه ولا تبتدئ أحداً بذلك ، هذا هو الصواب في هذه المسألة ، لو قال لك إنسان مثلاً : نهنئك بهذا العام الجديد قل : هنَّأك الله بخير، وجعله عام خير وبركة ، لكن لا تبتدئ الناس أنت ؛ لأنني لا أعلم أنه جاء عن السلف أنهم كانوا يهنئون بالعام الجديد ، بل اعلموا أن السلف لم يتخذوا المُحرَّم أول العام الجديد إلا في خلافة عمر بن الخطاب _ رضي الله عنه_.

 

أجاب عليه العلاَّمة / محمد بن عثيمين رحمه الله

 

 


Reply | Forward | Messages in this Topic (1)
#706 From: "Abdullah Osama Awad" <goastmufic@...>
Date: Thu Jan 18, 2007 7:41 pm
Subject: أريد القرآن الكريم (المصحف) مترجم بالإنجليزية و الألمانية 		goastmufic
Offline Offline
Send Email Send Email
 

السلام عليكم و رحمة الله و بركاته

كيف حالكم يا أصدقائي

عسى أن تكونوا بخير

كنت أريد طلب صغير جدا منكم و لكن أجره عظيم بإذن الله و الثواب من عند الله

كنت أريد القرآن الكريم (المصحف) مترجم بالإنجليزية و الألمانية نسخة إلكترونية و أي كتب عن السنة مترجمة

بالإنجليزية و الألمانية

أخوكم المبرمج المسلم/ عبدالله أسامة العسيري

نسألكم الدعاء لأخيكم بالتوفيق و النجاح في الإمتحانات

و أي جديد أرجو إرسال الرسالة على الايميل التالي :

goastmufic@...


Reply | Forward | Messages in this Topic (1)
#705 From: "Dr. Mona" <mona25_2010@...>
Date: Wed Jan 17, 2007 6:19 am
Subject: &#1581;&#1605;&#1604; &#1575;&#1604;&#1575;&#1606; Microsoft Visual Basic NET 		mona25_2010
Offline Offline
Send Email Send Email
 
 

حمل الان Microsoft Visual Basic NET

تاريخ الاصدار 2005

المساحة 486 MB

نبذة عن البرنامج

Microsoft Visual Studio 2005 has been significantly improved for Visual Basic developers by adding innovative ******** constructs , new compiler features , dramatically enhanced productivity , and an improved debugging experience. Visual Studio 2005 includes several productivity enhancements including IntelliSense code snippets , Windows Forms designer updates , IntelliSense filtering , debugger data tips , Exception Assistant , and more. In ******** innovations , Visual Basic 2005 includes generics , unsigned types , operator overloading , and many other additions. This document samples some of the new capabilities available in Visual Basic 200


Download Now
__________________
 
 
 
 
 
 
 
 


With my best wishes
 
Dr. Mona

Access over 1 million songs - Yahoo! Music Unlimited.

Reply | Forward | Messages in this Topic (1)
#704 From: "Dr. Mona" <mona25_2010@...>
Date: Wed Jan 17, 2007 6:10 am
Subject: &#1580;&#1605;&#1610;&#1593; &#1575;&#1604;&#1578;&#1605;&#1575;&#1585;&#1610;&#1606; &#1575;&#1604;&#1593;&#1605;&#1604;&#1610;&#1577; &#1604;&#1588;&#1607;&#1575;&#1583;&#1575;&#1578; &#1587;&#1610;&#1587;&#1603;&#1608; &#1608; &#1576;&#1583;&#1608;&#1606; &#1578;&#1581;&#1605;&#1610;&#1604; 		mona25_2010
Offline Offline
Send Email Send Email
 

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





لم يبقى سوى ان أضع الرابط بين أيديكم و هو بالمرفقات

http://www.ultratechnology.net/column/elabs/index.htm

اي مساعدة؟؟؟
ارسل رسالة الى
amthal@...
 
 
 
 
 
 
 


With my best wishes
 
Dr. Mona

TV dinner still cooling?
Check out "Tonight's Picks" on Yahoo! TV.

Reply | Forward | Messages in this Topic (1)
#703 From: "Dr. Mona" <mona25_2010@...>
Date: Wed Jan 17, 2007 6:14 am
Subject: torrent file to learn visual basic"&#1589;&#1608;&#1578; &#1608; &#1589;&#1608;&#1585;&#1577;" 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 torrent file to learn visual basic"صوت و صورة"
 
 
http://www.4shared.com/file/4363385/...pdevvbnet.html
 
 
 
 
 
 
 


With my best wishes
 
Dr. Mona

Never Miss an Email
Stay connected with Yahoo! Mail on your mobile. Get started!

Reply | Forward | Messages in this Topic (1)
#702 From: mona ebrahim <mona25_2010@...>
Date: Thu Dec 14, 2006 9:47 pm
Subject: &#1605;&#1608;&#1602;&#1593; &#1593;&#1585;&#1576;&#1610; &#1608;&#1605;&#1580;&#1605;&#1608;&#1593;&#1577; &#1576;&#1585;&#1610;&#1583;&#1610;&#1577; &#1605;&#1578;&#1582;&#1589;&#1589;&#1577; &#1604;&#1604;&#1603;&#1578;&#1576; 		mona25_2010
Offline Offline
Send Email Send Email
 


كتاب تعلم و أحترف الفوتوشوب الجزء الأول

كتاب تعلم و أحترف الفوتوشوب الجزء الثاني

كتاب تعلم و أحترف الفوتوشوب الجزء الثالث ( جديد )

كتاب تعلم و أحترف الفوتوشوب الجزء الرابع ( قريباً )

كتاب يجمع أكثر من 55 اكود للجافا

مجلد يجمع الكثير من اكود للجافا ( جديد )

كتاب تعلم صنع الثيم خطوة بخطوة
 

كتاب تعلم صنع الستايل خطوة بخطوة
 

http://members.lycos.co.uk/antemm

Cheap Talk? Check out Yahoo! Messenger's low PC-to-Phone call rates.

Reply | Forward | Messages in this Topic (3)
#701 From: mona ebrahim <mona25_2010@...>
Date: Thu Dec 14, 2006 10:07 pm
Subject: &#1571;&#1603;&#1579;&#1585; &#1605;&#1606; 30 &#1603;&#1578;&#1575;&#1576; &#1601;&#1610; &#1578;&#1593;&#1604;&#1610;&#1605; &#1575;&#1604;&#1601;&#1610;&#1580;&#1608;&#1575;&#1604; &#1576;&#1610;&#1587;&#1603; &#1603;&#1578;&#1576; &#1593;&#1585;&#1576;&#1610; &#1608;&#1573;&#1606;&#1580;&#1604;&#1610;&#1586;&#1610; 		mona25_2010
Offline Offline
Send Email Send Email
 

أكثر من 30 كتاب في تعليم الفيجوال
 
 بيسك كتب عربي وإنجليزي
 

49.3 ميجا
 

Everyone is raving about the all-new Yahoo! Mail beta.

Reply | Forward | Messages in this Topic (3)
#700 From: mona ebrahim <mona25_2010@...>
Date: Thu Dec 14, 2006 10:25 pm
Subject: &#1578;&#1593;&#1604;&#1610;&#1605; &#1575;&#1604;&#1601;&#1608;&#1578;&#1608;&#1588;&#1608;&#1576; &#1603;&#1575;&#1605;&#1604;&#1575; &#1601;&#1609; 30 &#1583;&#1585;&#1587; 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 
 
 
تعليم الفوتوشوب كاملا
 
فى 30 درس

 
 

http://www.megaupload.com/?d=19PSRO7H
 
 

Any questions? Get answers on any topic at Yahoo! Answers. Try it now.

Reply | Forward | Messages in this Topic (2)
#699 From: mona ebrahim <mona25_2010@...>
Date: Thu Dec 14, 2006 9:41 pm
Subject: &#1605;&#1608;&#1602;&#1593; &#1593;&#1585;&#1576;&#1610; &#1608;&#1605;&#1580;&#1605;&#1608;&#1593;&#1577; &#1576;&#1585;&#1610;&#1583;&#1610;&#1577; &#1605;&#1578;&#1582;&#1589;&#1589;&#1577; &#1604;&#1604;&#1603;&#1578;&#1576; 		mona25_2010
Offline Offline
Send Email Send Email
 


كتاب تعلم و أحترف الفوتوشوب الجزء الأول

كتاب تعلم و أحترف الفوتوشوب الجزء الثاني

كتاب تعلم و أحترف الفوتوشوب الجزء الثالث ( جديد )

كتاب تعلم و أحترف الفوتوشوب الجزء الرابع ( قريباً )

كتاب يجمع أكثر من 55 اكود للجافا

مجلد يجمع الكثير من اكود للجافا ( جديد )

كتاب تعلم صنع الثيم خطوة بخطوة
 

كتاب تعلم صنع الستايل خطوة بخطوة
 

http://members.lycos.co.uk/antemm

Access over 1 million songs - Yahoo! Music Unlimited.

Reply | Forward | Messages in this Topic (3)
#698 From: mona ebrahim <mona25_2010@...>
Date: Thu Dec 14, 2006 10:05 pm
Subject: &#1571;&#1603;&#1579;&#1585; &#1605;&#1606; 30 &#1603;&#1578;&#1575;&#1576; &#1601;&#1610; &#1578;&#1593;&#1604;&#1610;&#1605; &#1575;&#1604;&#1601;&#1610;&#1580;&#1608;&#1575;&#1604; &#1576;&#1610;&#1587;&#1603; &#1603;&#1578;&#1576; &#1593;&#1585;&#1576;&#1610; &#1608;&#1573;&#1606;&#1580;&#1604;&#1610;&#1586;&#1610; 		mona25_2010
Offline Offline
Send Email Send Email
 

أكثر من 30 كتاب في تعليم الفيجوال
 
 بيسك كتب عربي وإنجليزي
 

49.3 ميجا
 

Any questions? Get answers on any topic at Yahoo! Answers. Try it now.

Reply | Forward | Messages in this Topic (3)
#697 From: mona ebrahim <mona25_2010@...>
Date: Thu Dec 14, 2006 9:42 pm
Subject: &#1605;&#1608;&#1602;&#1593; &#1593;&#1585;&#1576;&#1610; &#1608;&#1605;&#1580;&#1605;&#1608;&#1593;&#1577; &#1576;&#1585;&#1610;&#1583;&#1610;&#1577; &#1605;&#1578;&#1582;&#1589;&#1589;&#1577; &#1604;&#1604;&#1603;&#1578;&#1576; 		mona25_2010
Offline Offline
Send Email Send Email
 


كتاب تعلم و أحترف الفوتوشوب الجزء الأول

كتاب تعلم و أحترف الفوتوشوب الجزء الثاني

كتاب تعلم و أحترف الفوتوشوب الجزء الثالث ( جديد )

كتاب تعلم و أحترف الفوتوشوب الجزء الرابع ( قريباً )

كتاب يجمع أكثر من 55 اكود للجافا

مجلد يجمع الكثير من اكود للجافا ( جديد )

كتاب تعلم صنع الثيم خطوة بخطوة
 

كتاب تعلم صنع الستايل خطوة بخطوة
 

http://members.lycos.co.uk/antemm

Check out the all-new Yahoo! Mail beta - Fire up a more powerful email and get things done faster.

Reply | Forward | Messages in this Topic (3)
#696 From: mona ebrahim <mona25_2010@...>
Date: Thu Dec 14, 2006 10:06 pm
Subject: &#1571;&#1603;&#1579;&#1585; &#1605;&#1606; 30 &#1603;&#1578;&#1575;&#1576; &#1601;&#1610; &#1578;&#1593;&#1604;&#1610;&#1605; &#1575;&#1604;&#1601;&#1610;&#1580;&#1608;&#1575;&#1604; &#1576;&#1610;&#1587;&#1603; &#1603;&#1578;&#1576; &#1593;&#1585;&#1576;&#1610; &#1608;&#1573;&#1606;&#1580;&#1604;&#1610;&#1586;&#1610; 		mona25_2010
Offline Offline
Send Email Send Email
 

أكثر من 30 كتاب في تعليم الفيجوال
 
 بيسك كتب عربي وإنجليزي
 

49.3 ميجا
 

Everyone is raving about the all-new Yahoo! Mail beta.

Reply | Forward | Messages in this Topic (3)
#695 From: mona ebrahim <mona25_2010@...>
Date: Thu Dec 14, 2006 10:30 pm
Subject: &#1578;&#1593;&#1604;&#1610;&#1605; &#1575;&#1604;&#1601;&#1608;&#1578;&#1608;&#1588;&#1608;&#1576; &#1603;&#1575;&#1605;&#1604;&#1575; &#1601;&#1609; 30 &#1583;&#1585;&#1587; 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 
 
 
تعليم الفوتوشوب كاملا
 
فى 30 درس

 
 

http://www.megaupload.com/?d=19PSRO7H
 
 

Everyone is raving about the all-new Yahoo! Mail beta.

Reply | Forward | Messages in this Topic (2)
#694 From: mona ebrahim <mona25_2010@...>
Date: Sat Nov 11, 2006 2:19 pm
Subject: تعلم الفجوال بيسك 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 
 
 
 
 
 
 
 
 
 
 
 

Access over 1 million songs - Yahoo! Music Unlimited.

Reply | Forward | Messages in this Topic (1)
#693 From: mona ebrahim <mona25_2010@...>
Date: Sat Nov 11, 2006 2:06 pm
Subject: أول كتاب عربى لتعليم البرمجة بلغة الPHP و قواعد البيانات MySQL 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 
أقدم لكم أول و أفضل كتاب باللغة العربية لتعليم البرمجة بلغة الPHP و قواعد البيانات MySQL من الألف إلى الياء
تأليف صقر ابن محمد العنزى
و الرابط

http://rapidshare.de/files/15032068/php.pdf.html
 
 
 
 
 
 
 

Cheap Talk? Check out Yahoo! Messenger's low PC-to-Phone call rates.

Reply | Forward | Messages in this Topic (1)
#692 From: mona ebrahim <mona25_2010@...>
Date: Sat Nov 11, 2006 2:02 pm
Subject: اSQL SERVER 2005 من شركة APPDEV سطوانه لتعليم 		mona25_2010
Offline Offline
Send Email Send Email
 
لينكات لتحميل اسطوانه لتعليم SQL SERVER 2005 من شركة APPDEV المعروفه
الاسطوانه حجمها 959 ميجا ISO
وانا شخصيا قمت بتحميلها ...

الاسطوانه تحتوى على مجموعه كبيره من الدروس فى SQL SERVER 2005
يارب تستفيدوا منها...

صوره من الاسطوانه نفسها:

التحميل:
الجزء الاول
الجزء الثانى
الجزء الثالث
الجزء الرابع
الجزء الخامس
الجزء الاخير
__________________
 
 
 
 
 
 
 
 
 

Check out the all-new Yahoo! Mail beta - Fire up a more powerful email and get things done faster.

Reply | Forward | Messages in this Topic (1)
#691 From: mohammed ali <moh_ali2005_2010@...>
Date: Mon Oct 9, 2006 5:15 pm
Subject: Re: ايه ده كله 		star_meakr
Offline Offline
Send Email Send Email
 
فينك من زمان يا دكتوره
راجعالنا نشيطه بشوية مواضيع جامده
ياريت يدوم النشاط ده على طول ومتختفيش تانى


ربنا يوفقك 
سلام

Do you Yahoo!?
Everyone is raving about the all-new Yahoo! Mail.

Reply | Forward | Messages in this Topic (2)
#690 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 8:55 am
Subject: حصريا وبالفيديو سلسلة الدروس الإحترافيه على الفوتوشوب 		mona25_2010
Offline Offline
Send Email Send Email
 
 
الدرس الاول
 
 
الدرس التانى
 
 
 
 
الدرس الثالث
 
 
 
 

درس الفلاتر من على الرابط التالي :

http://tutorials.watchandlearnphotos...s/filters.html

مدة الشرح 12.34 دقيقه
 
 

Yahoo! Messenger with Voice. Make PC-to-Phone Calls to the US (and 30+ countries) for 2¢/min or less.

Reply | Forward | Messages in this Topic (1)
#689 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 8:09 am
Subject: دورة مجانية في الفوتوشوب للمبتدئين !!! 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 
دورة مجانية في الفوتوشوب للمبتدئين !!!
 
 
 
حصة تعريفية ببرنامج الفوتوشوب

انا عندي الاصدار 8 من الفوتوشوب

هنا الواجهة الرئيسية حقت الفوتوشوب
7
7
7
7




طبعا اليوم راح يكون تعريف بقوائم لوح الخيارات

وهو يتكون من 9 قوائم
وهي : file>Edit> Image> layer > Select > Filter > View > Window > Help





نتناول قائمة ملف




لعمل عمل جديد : File> New >




ويمكن فتح ملف محفوظ على الكمبيوتر او في الفوتوشوب



ننتقل الى قائمة Edit




قائمة Image

يجب ان تكون حالة العمل الوان RGB





ثم التعديلات





ولمزيد من الفهم هنا تطبيق عملي

الصورة الاصلية :




7
7
7



7
7
7



7
7
7



7
7
7



7
7
7



7
7
7



7
7
7



7
7
7



7
7
7


7
7
7




7
7
7





فرش الفوتوشوب

أولاً : كيف تظهر لوح الفرش .

هناك طريقتان لإظهار لوح الفرش وهما :

1- النقر على مفتاح F5

2- الذهاب إلى قائمة Window ==> Show Broushes

كما في الصورة :







ثانياً : التعرف على لوح الفرش .

1- المظهر :







2- الخيارات : ( تظهر الخيارات عن طريق النقر على الإشارة المحددة باللون الأحمر في اليمين )

قائمة الخيارات : ( انظر الشكل التالي)






(التوضيح )

New Brush ( فرشاة جديدة ): إذا اردت عمل فرشاة جديدة . وعند النقر عليها ستظهر لك هذه القائمة : تستطيع التحكم بالفرشاة الجديدة من هذه القائمة .






Delete Brush(حذف فرشاة ) : إذا اردت حذف فرشاة معينة ما عليك سوى النقر على الفرشاة بالماوس نقرة واحدة ومن ثم اختيار Delete Brush
Brush Options(خيارات الفرش) : إذا اردت تغير في خيارات أي فرشاة ما عليك سوى أن تحدد الفرشاة ثم تختار Brush Options ، ستظهر لك نفس القائمة السابقة :

Define Brush (إنشاء فرشاة ) : إذا اردت أن تنشئ فرشاة بالشكل الذي تريده ما عيك سوى تحديد الشكل ومن ثم النقر على Define Brush ستلاحظ ظهور الشكل المحدد كفرشاة لاحظ المثال التالي : ...

أولاً : إحظار الشكل المطلوب ومن ثم تحديده . ( لاحظ الوردة المحددة )





ثانياً : انقر على Define Brush :





بعد ذلك لاحظ داخل لوح الفرش ( ستلاحظ ظهور شكل الوردة كفرشاة )


عند استخدامها وبألوان مختلفه ستظهر كالتالي :





Reset Brushes ( استرجاع الفرش الأساسية ) فائدتها استرجاع الفرش الأساسية التي جاءت مع برانامج الفوتوشوب ) .

Load Brushes ( إحظار فرش ) تستطيع بواسطة هذا الخيار أن تأتي بفرش اخرى و تأتي فرش مرفقة مع برنامج الفوتوشوب غير الفرش التي تظهر لك وهي في الفهرس التالي :

C:\Program Files\Adobe\Photoshop 5.5\Goodies\Brushes

ستظهر لك أربع مجموعات من الفرش : وهي Assorted Brushes ، Drop Shadows Brushes ، Natural Brushes ، Square Brushes
وهذه اشكال المجوعات التي سوف تظيفها للوح الفرش :



Assorted Brushes



Square Brushes


Natural Brushes


Drop Shadows Brushes






Replace Brush ( أستبدال فرشاة ) : إذا اردت إستبدال فرشاة بفرشاة أخرى ما عليك سوى أن تختار Replace Brush ثم تحدد الفرشاة المحفوظة التي تريد استبدالها .

Save Brush( حفظ الفرش ) أذا اردت أن تقوم بحفظ لوح الفرش ما عليك سوى أن تختار Save Brush وتحدد اسم وموضع للفرش . واذا اردت استرجاع الفرش المحظفوظة استخدم Load Brush

ملاحظة : كما يمكن تحميل العديد من الفرش ذات الإستخدام المتنوع من مصادر عدة مثل شبكة الإنترنت وغيرها .

 
 
درس كيووووت وبسيط
 
 



 
 

 درس عن تكرار الكلمة في الخلفية







 

Talk is cheap. Use Yahoo! Messenger to make PC-to-Phone calls. Great rates starting at 1¢/min.

Talk is cheap. Use Yahoo! Messenger to make PC-to-Phone calls. Great rates starting at 1¢/min.

Reply | Forward | Messages in this Topic (1)
#688 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 8:28 am
Subject: درس عمل فقاعات الصابون 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 








وهذا تطبيق عالطاير






Get your email and more, right on the new Yahoo.com

Reply | Forward | Messages in this Topic (2)
#687 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 8:22 am
Subject: تابع دورة مجانية في الفوتوشوب للمبتدئين !!! 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 


















وهذا بتدرج الرمادي




 



 




































 
درس طريقة وضع حد على الخطوط بلون معين مثل التطبيق الثاني


شاهد حد الخط باللون الاسود





درس اليوم طريقة عمل جدار بالفوتوشوب

أتمنى يكون واضح ويعجبكم




 
درس الاطار







أتمنى يعجبكم




 

How low will we go? Check out Yahoo! Messenger’s low PC-to-Phone call rates.

Reply | Forward | Messages in this Topic (1)
#686 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 8:24 am
Subject: درس عمل الختم 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 
درس عمل الختم
 










** طبعا الختم ممكن نعمله على اعمالنا الخاصة



Do you Yahoo!?
Everyone is raving about the all-new Yahoo! Mail.

Reply | Forward | Messages in this Topic (2)
#685 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 8:25 am
Subject: درس عمل الختم 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 
درس عمل الختم
 










** طبعا الختم ممكن نعمله على اعمالنا الخاصة







Talk is cheap. Use Yahoo! Messenger to make PC-to-Phone calls. Great rates starting at 1¢/min.

Reply | Forward | Messages in this Topic (2)
#684 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 8:26 am
Subject: درس عمل البرق 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 
درس عمل البرق



(1)







(2)







(3)








ثم نقوم بحفظ العمل عن طريق قائمة

File > Save Optimized As

All-new Yahoo! Mail - Fire up a more powerful email and get things done faster.

Reply | Forward | Messages in this Topic (1)
#683 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 7:17 am
Subject: سلسلة اكواد قاعدة البيانات اكسيس وتطبيقات لها 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 

 
 
سلسلة - أكواد الأكسس
(( من لديه أي كود فيه فائدة يتفضل بوضعه هنا ))
وأنا سوف أبدأ على بركة الله_:
___________________________
لتغییر حجم الخط في مربع النص ضع في حدث عند النقر للزر الكود التالي:
****1.FontSize = 12
غير الرقم 12 إلى الرقم الذي تريد
____________________________
ھل تريد جعل النموذج في حجم واحد لا يتغیر إستخدم الكود التالي
في حدث الحالي للنموذج
Width = 3000
Height = 3000
______________________________
لجعل الخط في مربع النص غامق استخدم الكود
****1.FontBold = True
ملاحظة:
هو اسم مربع النص ****1
______________________________
لجعل الخط مائل
****1.FontItalic = True
_______________________________
لجعل خط تحت الكلمات
****1.FontUnderline = True
________________________________
لتغییر لون الخط في مربع النص ما علیك إلا كتابة الكود
****1.ForeColor = 255
مع تغيير الرقم 255 إلى رقم اللون الذي تريد
255 هو اللون الأحمر
________________________________
ھل تريد إدارج التاريخ في مربع النص ..إذاً إكتب الكود التالي
****1 = Date
__________________________________
ھذا الكود لإضافة الوقت في مربع النص
****1 = Time
__________________________________
اليكم يا أعزائي هذه المجموعة أيضا
أتمنى أن تحوز على رضى مرتادي هذا المنتدي الجميل بكل أعضائه
أولاً :
أي بدون شريط عنوان . (none) لتحريك الفورم
وانسخ الكود : Image ضع أداة صور 1
Dim MoveFlag As Integer
Dim MXstart As Single
Dim MYstart As Single
Private Sub Image1 _MouseDown(Button As Integer, Shift As Integer,
x As Single, y As Single)
MousePointer = 5
MXstart = x
MYstart = y
MoveFlag = True
End Sub
Private Sub Image1 _MouseMove(Button As Integer, Shift As Integer,
x As Single, y As Single)
If MoveFlag Then
Move Left + (x - MXstart), Top + (y - MYstart)
End If
End Sub
Private Sub Image1 _MouseUp(Button As Integer, Shift As Integer, x
As Single, y As Single)
MoveFlag = False
MousePointer = 1
End Sub
************************************************** *****
********
ثانیاً-:
لرسم دوائر تصغ وتكبر حول المشیرة
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X
As Single, Y As Single)
Me.DrawWidth = 2
Dim R
R = 10
Do
Cls
R = R + 10
Circle (X, Y), R, vbRed
If R = 400 Then
R = 10
End If
DoEvents
Loop
End Sub
************************************************** *****
********
ثالثاً-:
أنا مستعد ھذه واحدة معروفة لجعل النافذة تومض
FLASHWINDOW: بدالة
MODULE : عرف الدالة التالية في قسم الإجراءات أو في
Code:
--------------------------------------------------------------------------------
PUBLIC DECLARE FUNCTION FLASHWINDOW LIB "USER32"_
(BYVAL HWND AS LONG,BYVAL BINVERT AS LONG)AS LONG
--------------------------------------------------------------------------------
أكتب الحدث التالي في تايمر واجعل قيمتها 100
Code:
--------------------------------------------------------------------------------
PRIVATE SUB TIMER1_TIMER()
FLASHWINDOW(ME.HWND,0)
END SUB
--------------------------------------------------------------------------------
FLASHWINDOW. أولاً : نقوم بتعريف الدالة
نقوم بأخد مقبض النافذة في FLASHWINDOW(ME.HWND, ثانيا : في حدث التايمر نكتب( 0
أي تعمل FALSE أو TRUE ومن ثم تكون قيمة الإجراء الآخر صفر لكي لا تكون ME.HWND الإجراء
دائماً
[/code]
************************************************** *****
*********
رابعاً-:
كود لأضافة ايقونة عند ساعة الويندوز:
Code:
--------------------------------------------------------------------------------
Private Declare Function ****l_NotifyIcon Lib "****l32.dll" _
Alias "****l_NotifyIconA" (ByVal dwMessage As Long, _
lpData As NOTIFYICONDATA) As Longprivate
Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
Private Const WM_RBUTTONDBLCLK = &H206
Private Const NIM_ADD = &H0
Private Const NIM_DELETE = &H2
Private Const NIM_MODIFY = &H1
Private Const NIF_ICON = &H2
Private Const NIF_MESSAGE = &H1
Private Const NIF_TIP = &H4
NotifyIcon هنا تعريف المتغير من نوع Private Ic As NOTIFYICONDATA '
'''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''
Private Sub Load_Form()
Ic.cbSize = Len(Ic)
مقبض النافذة Ic.hwnd = Me.hwnd '
Ic.uID = 1&
يحتوي على : ايقون + Ic.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE '
ملاحظات + رسائل الفأرة
Ic.uCallbackMessage = WM_RBUTTONDOWN Or WM_RBUTTONUP Or
رسائل الفأرة النشطة WM_RBUTTONDBLCLK '
ضع هنا الايقونه Ic.hIcon = Picture '
ToolTip**** الملاجظات الخاصة للبرنامج او ما يسمى Ic.szTip = "My Program First" '
الأمر اضافة للأيقونة ****l_NotifyIcon NIM_ADD, Ic '
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''
Private Sub Form_Unload()
Ic.cbSize = Len(Ic)
Ic.hwnd = Me.hwnd
Ic.uID = 1&
الأمر حذف للأيقونة ****l_NotifyIcon NIM_DELETE, Ic '
End Sub '''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Timer1_Timer()
Ic.szTip = "My Program Second"
الأمر تعديل في الأيقونة وهنا كان التعديل فقط على ****l_NotifyIcon NIM_MODIFY, Ic '
الملاحظات
End Sub
************************************************** *****
*********
خامساً-:
ھذي علشان النافذة دائما في الاعلى:
Module : في ال
Code:
--------------------------------------------------------------------------------
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
Declare Sub ReleaseCapture Lib "user32" ()
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer,
ByVal lParam As Long) As Long
Const HWND_TOPMOST = -1
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Public Function PutWindowOnTop(Form1 As Form)
Dim lngWindowPosition As Long
lngWindowPosition = SetWindowPos(Form1.hwnd, HWND_TOPMOST,
0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Function
--------------------------------------------------------------------------------
ثم في الفورم:
Code:
--------------------------------------------------------------------------------
Private Sub Form_Load()
Call PutWindowOnTop(Me)
End Sub
ضع الكود في الزر لإضهار الآلة الحاسبة ·
****l "c:\windows\calc.exe"
----------------------------------------------------------
لجعل مؤشر الماوس لا يخرج من حدود الفورم ،اليكم الكود .
السلام عليكم و رحمة الله
إخواني الاعزاء
لأسر مؤشر الفأره داخل حدود الفورم اليكم بالتالي :
ضع الكود التالي داخل مديول :
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function ClipCursor Lib "user32" (lpRect As Any) As
Long
ثم ضع الكود التالي في الفورم :
Private Sub Form_Load()
'The form should not be set to sizable or this will not work. You
should also call the code each time the user moves the form.
Dim lngX As Long
Dim lngY As Long
Dim lngReturn As Long
Dim NewRect As RECT
'Get the screens Twips per pixel (form's scalemode must be
Twips)
lngX = Screen.TwipsPerPixelX
lngY = Screen.TwipsPerPixelY
'Set cursor region to that of form
With NewRect
.Left = Me.Left / lngX
.Top = Me.Top / lngY
.Right = .Left + Me.Width / lngX
.Bottom = .Top + Me.Height / lngY
End With
lngReturn = ClipCursor(NewRect)
End Sub
لمنع المستخدم من الضغط على زر الفأرة الأيمن كما ھو في المتصفح
ضع هذا الكود في حدث عند الضغط على الماوس
في مقطع التفصيل وفي خصائص النموذج
______________________________
If Button = 2 Then
ممنوع الضغط بزر الفأرة الأيمن" MsgBox "
DoCmd.CancelEvent
End If
_______________________________
لمنع المستخدم من الضغط على زر الفأرة الأيسر كما ھو في المتصفح
ضع هذا الكود في حدث عند الضغط على الماوس
في مقطع التفصيل وفي خصائص النموذج
If Button = 1 Then
ممنوع الضغط بزر الفأرة الأيسر" MsgBox "
End If
_________________
RunCommand بعض أوامر
الجزء الأول :
وسيتلوه إن شاء الله الجزء الثاني ثم بقية RunCommand هذه هو الجزء الأول من شرح لبعض أوامر
الأوامر التي لم اعرف طريقة عملها ، اي استفسار أو ملاحظات ارجو سرعة كتابتها حتى تكون في موضعها
المناسب .
إظهار مربع حول ميكروسوفت أكسس
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAboutMicrosoftAccess
--------------------------------------------------------------------------------
فتح عامل تصفية فرز متقدم
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAdvancedFilterSort
--------------------------------------------------------------------------------
محاذاة إلى الأسفل
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAlignBottom
--------------------------------------------------------------------------------
يجب أن يسبقها الأوامر التالية :
1 - أمر فتح النموذج أو التقرير في عرض التصميم .
2 - أمر اختيار كل الكائنات :
اختيار كل الكائنات
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdSelectAll
--------------------------------------------------------------------------------
والأوامر الستة التالیة يشترط لھا الشرطین السابقین .
محاذاة إلى اليسار
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAlignLeft
--------------------------------------------------------------------------------
محاذاة إلى الیمین
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAlignRight
--------------------------------------------------------------------------------
محاذاة إلى الشبكة
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAlignToGrid
--------------------------------------------------------------------------------
محاذاة إلى الأعلى
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAlignTop
--------------------------------------------------------------------------------
محاذاة إلى الأقصر
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAlignToShortest
--------------------------------------------------------------------------------
محاذاة إلى الأطول
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAlignToTallest
--------------------------------------------------------------------------------
إظھار مربع حوار معالج الأداء
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAnalyzePerformance
--------------------------------------------------------------------------------
تشغیل معالج محلل الجداول
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAnalyzeTable
--------------------------------------------------------------------------------
إظھار تعلیمات الأكسس :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAnswerWizard
--------------------------------------------------------------------------------
تطبیق معامل تصفیة فرز متقدم :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdApplyFilterSort
--------------------------------------------------------------------------------
يأتي بعد عمل للنموذج تصفیة فرز متقدم للنموذج قبل ذلك .
تكبیر إطار الأكسس للحجم الأقصى ، لاحظ إطار أكسس ولیس غیره :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAppMaximize
--------------------------------------------------------------------------------
إرجاع إطار الأكسس إلى الخلف (لماذا يختلف العمل عن الاسم ؟ : (!!
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAppMinimize
--------------------------------------------------------------------------------
تحريك إطار الأكسس :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAppMove
--------------------------------------------------------------------------------
استرجاع) تصغیر) نافذة الأكسس :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAppRestore
--------------------------------------------------------------------------------
تغییر حجم ناذة الأكسس :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAppSize
--------------------------------------------------------------------------------
ترتیب تلقائي :
والمقصود به ترتیب الرموز في إطار أكسس بأحد الطرق التالیة :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdArrangeIconsAuto
--------------------------------------------------------------------------------
يجب أن يسبقھا أمر اختیار إطار قاعدة البیانات بأحد الطرق التالیة :
كود :
--------------------------------------------------------------------------------
}", False طSendKeys "%{
SendKeys "{1}"
--------------------------------------------------------------------------------
أو :
كود :
--------------------------------------------------------------------------------
DoCmd.SelectObject acQuery, , True
--------------------------------------------------------------------------------
للفائدة :
بأحد الاختیارات التالیة لیفتح على صفحة التبويب acQuery يمكنك استبدال
الخاصة بأحد ھذه الكائنات :
النوع / رقماً / توضیح
جدول AcTable / 0 /
استعلام AcQuery / 1 /
نموذج AcForm / 2 /
تقرير AcReport / 3 /
ماكرو AcMacro / 4 /
وحدة نمطیة AcModule / 5 /
صفحة بیانات أكسس AcDataAccessPage / 6 /
طريقة عرض الملقم AcServerView / 7 /
رسم بیاني أو تخطیطي AcDiagram / 8 /
إجراء مخزن AcStoredProcedure / 9 /
إذا كان الكائن مفتوحاً مسبقاً . False يعني من إطار قاعدة البیانات الحالیة و True و
الأربعة التالیة تحتاج نفس الطريقة السابقة .
حسب تاريخ الإنشاء
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdArrangeIconsByCreated
--------------------------------------------------------------------------------
حسب تاريخ التعديل
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdArrangeIconsByModified
--------------------------------------------------------------------------------
حسب الاسم
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdArrangeIconsByName
--------------------------------------------------------------------------------
حسب النوع
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdArrangeIconsByType
--------------------------------------------------------------------------------
إظھار مربع حوار التصحیح التلقائي
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAutoCorrect
--------------------------------------------------------------------------------
ملاحظة : تحتاج لوضع عبارة اعتراض الخطأ لظھور خطأ في حالة ما إذا نقر المستخدم زر إلغاء
الأمر .
اتصال ھاتفي تلقائي :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAutoDial
--------------------------------------------------------------------------------
يجب أن يسبقھا أمر نقل التركیز لمربع النص مثلا الذي يحتوي على رقم الھاتف .
فتح مربع حوار تنسیق تلقائي
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdAutoFormat
--------------------------------------------------------------------------------
لابد أن يسبق ھذا الأمر أمر فتح النموذج أو التقرير في وضع التصمیم .
مسح شبكة الاستعلام :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdClearGrid
--------------------------------------------------------------------------------
يسبقه أمر فتح الاستعلام في عرض التصمیم .
إغلاق الكائن النشط :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdClose
--------------------------------------------------------------------------------
إغلاق الأكسس :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdCloseWindow
--------------------------------------------------------------------------------
يظھر مربع حوار عرض العمود في استعلام أو جدول
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdColumnWidth
--------------------------------------------------------------------------------
يسبقه أمر فتح الاستعلام أو الجدول .
ترجمة كافة الوحدات النمطیة
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdCompileAllModules
--------------------------------------------------------------------------------
ترجمة كافة الوحدات النمطیة وحفظھا
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdCompileAndSaveAllModules
--------------------------------------------------------------------------------
تحويل وحدات ماكرو إلى فیوجل بیسك :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdConvertMacrosToVisualBasic
--------------------------------------------------------------------------------
يسبقه ھذا الأمر الأمر التالي :
كود :
--------------------------------------------------------------------------------
", True اسم الماكرو المطلوب تحويله DoCmd.SelectObject acMacro, "
--------------------------------------------------------------------------------
نسخ كائن :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdCopy
--------------------------------------------------------------------------------
يسبقھا أمر اختیار كائن كالذي في المثال السابق مع ملاحظة أن اسم الكائن مطلوب .
إنشاء قائمة لنموذج :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdCreateMenuFromMacro
--------------------------------------------------------------------------------
يسبقھا أمر اختیار ماكرو .
يغلق قاعدة البیانات المفتوحة وينشئ نسخة مماثلة :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdCreateReplica
--------------------------------------------------------------------------------
يظھر مربع إنشاء اختصار لكائن في قاعدة البیانات :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdCreateShortcut
--------------------------------------------------------------------------------
يسبقھا أمر اختیار الكائن .
إنشاء قائمة من ماكرو :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdCreateShortcutMenuFromMacro
--------------------------------------------------------------------------------
يسبقھا أمر اختیار ماكرو .
إنشاء شريط أدوات من ماكرو
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdCreateToolbarFromMacro
--------------------------------------------------------------------------------
يسبقھا أمر اختیار ماكرو .
قص كائن :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdCut
--------------------------------------------------------------------------------
يسبقھا أمر اختیار الكائن .
عرض صفحة بیانات (يسبقه أمر اختیار الصفحة (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDataAccessPageBrowse
--------------------------------------------------------------------------------
عرض صفحة بیانات في عرض التصمیم (يسبقه أمر اختیار الصفحة (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDataAccessPageDesignView
--------------------------------------------------------------------------------
خصائص قاعدة البیانات الحالیة
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDatabaseProperties
--------------------------------------------------------------------------------
جعل النموذج لإدخال البیانات فقط
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDataEntry
--------------------------------------------------------------------------------
فتح نموذج كصفحة بیانات
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDatasheetView
--------------------------------------------------------------------------------
يسبقھا إما أمر اختیار النموذج أو أمر فتح النموذج في عرض التصمیم أما إذا كان النموذج
المطلوب ھو النموذج النشط فلا حاجة لما سبق .
فتح نافذة الدبج في النموذج الحالي
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDebugWindow
--------------------------------------------------------------------------------
حذف كائن
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDelete
--------------------------------------------------------------------------------
يسبقھا أمر اختیار الكائن .
حذف صفحة
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDeletePage
--------------------------------------------------------------------------------
يسبقھا أمر اختیار الكائن .
حذف عمود من تقرير في وضع التصمیم
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDeleteQueryColumn
--------------------------------------------------------------------------------
يسبقھا أمر اختیار الكائن .
حذف سجل .
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDeleteRecord
--------------------------------------------------------------------------------
يسبقه أمر فتح جدول أو استعلام في العرض العادي .
يحذف الحقل الأول في جدول مفتوح في عرض التصمیم :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDeleteRows
--------------------------------------------------------------------------------
يحذف العمود الأول في جدول مفتوح في العرض العادي :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDeleteTableColumn
--------------------------------------------------------------------------------
يفتح الكائن النشط في عرض التصمیم :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDesignView
--------------------------------------------------------------------------------
تكبیر اطار الكائن النشط :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDocMaximize
--------------------------------------------------------------------------------
تصغیر اطار الكائن النشط :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDocMinimize
--------------------------------------------------------------------------------
تحريك اطار الكائن النشط :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDocMove
--------------------------------------------------------------------------------
إستعادة اطار الكائن النشط :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDocRestore
--------------------------------------------------------------------------------
تغییر حجم اطار الكائن النشط :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdDocSize
--------------------------------------------------------------------------------
إظھار معالج التوثیق :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmd********er
--------------------------------------------------------------------------------
إظھار مربع حوار إدراج ارتباط تشعبي :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdEditHyperlink
--------------------------------------------------------------------------------
تحرير علاقة (يسبقھا أمر فتح إطار العلاقات : (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdEditRelationship
--------------------------------------------------------------------------------
تشفیر/فك شفرة قاعدة البیانات
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdEncryptDecryptDatabase
--------------------------------------------------------------------------------
غلق القاعدة والاكسس
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdExit
--------------------------------------------------------------------------------
إظھار مربع حوار إضافة إلى المفضلة
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFavoritesAddTo
--------------------------------------------------------------------------------
إظھار مربع حوار فتح المفضلة
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFavoritesOpen
--------------------------------------------------------------------------------
إظھار مربع قائمة الحقول (يسبقھا أمر فتح النموذج أو التقرير في عرض التصمیم (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFieldList
--------------------------------------------------------------------------------
تصفیة بواسطة النموذج
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFilterByForm
--------------------------------------------------------------------------------
تصفیة بواسطة التحديد
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFilterBySelection
--------------------------------------------------------------------------------
تصفیة مع استبعاد التحديد
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFilterExcludingSelection
--------------------------------------------------------------------------------
إظھار مربع بحث واستبدال
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFind
--------------------------------------------------------------------------------
تكرار البحث :
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFindNext
--------------------------------------------------------------------------------
إظھار مربع حوار خط (يسبقه أمر فتح الجدول أو الاستعلام أو النموذج –عرض صفحة بیانات-
في العرض العادي (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFont
--------------------------------------------------------------------------------
إظھار مربع تنسیق صفحة البیانات (يسبقه أمر فتح الجدول أو الاستعلام أو النموذج –عرض
صفحة بیانات- في العرض العادي (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFormatCells
--------------------------------------------------------------------------------
عرض رأس وتذيیل النموذج (يسبقه أمر فتح النموذج في عرض التصمیم (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFormHdrFtr
--------------------------------------------------------------------------------
عرض النموذج
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFormView
--------------------------------------------------------------------------------
تجمید أعمده (يسبقه أمر فتح الجدول أو الاستعلام أو النموذج –عرض صفحة بیانات- في
العرض العادي (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdFreezeColumn
--------------------------------------------------------------------------------
إخفاء عمود في صفحة بیانات
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdHideColumns
--------------------------------------------------------------------------------
إنقاص التباعد الأفقي (يسبقه فتح النموذج أو التقرير في عرض التصمیم وكذلك أمر اختیار كل
الكائنات (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdHorizontalSpacingDecrease
--------------------------------------------------------------------------------
زيادة التباعد الأفقي (كالسابق (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdHorizontalSpacingIncrease
--------------------------------------------------------------------------------
مساواة التباعد الأفقي (كالسابق (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdHorizontalSpacingMakeEqual
--------------------------------------------------------------------------------
تحرير نص العرض للإرتباط التشعبي (يسبقه نقل التركیز لمربع النص المربتط بحقل من نوع
ارتباط تشعبي (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdHyperlinkDisplay****
--------------------------------------------------------------------------------
إظھار مربع الحوار استیراد
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdImport
--------------------------------------------------------------------------------
إظھار مربع حوار فھارس (يسبقه أمر فتح الجدول في عرض التصمیم (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdIndexes
--------------------------------------------------------------------------------
إدراج عنصر تحكم ActiveX
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdInsertActiveXControl
--------------------------------------------------------------------------------
إدراج تخطیط في تقرير (يسبقه أمر فتح التقرير في عرض التصمیم (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdInsertChart
--------------------------------------------------------------------------------
إدراج ارتباط تشعبي (يسبقھا فتح النموذج أو التقرير في عرض التصمیم (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdInsertHyperlink
--------------------------------------------------------------------------------
إدراج عمود بحث في جدول (في العرض العادي (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdInsertLookupColumn
--------------------------------------------------------------------------------
إدراج عمود بحث في جدول (في عرض التصمیم (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdInsertLookupField
--------------------------------------------------------------------------------
إدراج كائن في نموذج أو تقرير (في عرض التصمیم (
كود :
--------------------------------------------------------------------------------
DoCmd.RunCommand acCmdInsertObject
ھذا الكود يغیر لون كل محتويات مربع النص عند كتابة كل حرف،كیف استطیع جعل كل حرف
ياخذ لون معین عند كتابته بحیث تظھر حروف النص مختلفة الالوان. أنشأ مربع نص على
**** النموذج وسمه 1
وضع في خصائصه في حدث ( عند التغییر (
ھذا الكود
_________________________________
Private Sub ****1_Change()
Static i As Integer
i = i + 1
Select Case i
Case 1
****1.ForeColor = vbRed
Case 2
****1.ForeColor = vbGreen
Case 3
****1.ForeColor = vbBlue
Case 4
****1.ForeColor = vbYellow
End Select
If i = 4 Then i = 0
End Sub
__________________________________
أيضا ھذا الكود نفس الكود أعلاه ولكن يعتمد على جمیع ألوان الشاشة ولیس على أربعة
**** الوان فقط . أنشأ مربع نص على النموذج وسمه 1
وضع في خصائصه في حدث ( عند التغییر (
ھذا الكود
_________________________________
Private Sub ****1_Change()
Randomize
r = Int(Rnd * 255) + 1
g = Int(Rnd * 255) + 1
b = Int(Rnd * 255) + 1
****1.ForeColor = RGB(r, g, b)
End Sub
____________________________________
ھذا الكود يستخدم لمعرفة كم عدد تكرار حرف معین في جملة معینة
ضع في الوحدة النمطية العامة
_______________________
Public Function CountChar(StringToSearch As String, Character As String) As
Integer
CountChar = 0
For i = 1 To Len(StringToSearch)
If Mid(StringToSearch, i, 1) = Character Then CountChar = CountChar + 1
Next i
End Function
_________________________
وضع في حدث ( عند النقر ) للزر الكود التالي
الفريق العربي للبرمجة .. منتدى قواعد بیانات مايكروسوفت ", "م(" n = CountChar("
MsgBox n
___________________________
أضغط على الزر لیقوم البرنامج بعد حرف ) المیم ) في الجملة ھذه
طريقة تجزئة جملة نصیة عن طريق عرضھا في رسالة
ضع ھذا الكود في حدث ( عند النقر ( للزر
____________________________
Dim str As String
Dim x() As String
البرمجة##وقواعد##البيانات##منتديات##تكنولجي##فورس" str = "
x() = Split(str, "##")
For Each y In x()
MsgBox y
Next
_____________________________
ھذه طريقة تأجیل تنفیذ الكود لفترة معینة
ضع في الوحدة النمطیة الخاصة بالنموذج الكود التالي
Public Sub Delay(HowLong As Date)
TempTime = DateAdd("s", HowLong, Now)
While TempTime > Now
DoEvents
Wend
End Sub
__________________
وضع في حدث ( عند النقر ) للزر الكود التالي
Delay 5
البرمجة وقواعد البيانات ... منتديات تكنولجي فورس" MsgBox "
سوف يتم عرض ھذه الرسالة بعد خمس ثواني كما ھو محدد في الكود
____________
 
 
 
 
 
 
 
 
 

Do you Yahoo!?
Get on board. You're invited to try the new Yahoo! Mail.

Reply | Forward | Messages in this Topic (1)
#682 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 7:18 am
Subject: حمل بنك الأكواد 		mona25_2010
Offline Offline
Send Email Send Email
 
 
 
 

 
 
 
 
 
 
 
 
 
 
 
 
 

Yahoo! Messenger with Voice. Make PC-to-Phone Calls to the US (and 30+ countries) for 2¢/min or less.

Reply | Forward | Messages in this Topic (1)
#681 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 7:11 am
Subject: مكتبة الأكواد الجزء التانى 		mona25_2010
Offline Offline
Send Email Send Email
 
حذف أي ملف

Private Sub Command1_Click()
Kill ("C:\FileName.fnm")
End Sub
************************************************** ***

إنشاء ملف جديد

Private Sub Command1_Click()
open "c:\FileName.txt" for append as #1
Print #1,"Willkommen auf die Erde"
Close #1
End Sub

************************************************** ****

معرفة الفرق بين تاريخين باليوم

Private Sub Command1_Click()
On Error GoTo 1
Dim Form1Date As Date
Dim Form2Date As Date
Form1Date = ****1.****
Form2Date = ****2.****
****3.**** = DateDiff("d", ****1.****, ****2.****) & " يوم"
Exit Sub
1 MsgBox ("من فضلك أدخل التاريخ بشكل صحيح")
End Sub
************************************************** *****

معرفة مسار مجلد الـ Temp

Public Function TheTempDir() As String
Dim lpBuffer As String
Dim TempPath As Long
lpBuffer = Space(255)
TempPath = GetTempPath(255, lpBuffer)
TheTempDir = ****(lpBuffer, TempPath)
End Function
Private Sub Command1_Click()
****1.**** = TheTempDir
End Sub
ونكتب في موديل Modell
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

************************************************** **
عرض الزمن والتاريخ

Private Sub Form_Load()
Timer1.Interval = 1000
End Sub

Private Sub Timer1_Timer()
Label1 = Time & Date
End Sub

************************************************** *****
نسخ الملفات من وإلى أي مكان في الهارديسك

Private Sub Command1_Click()
FileCopy "c:\Autoexec.bat", "d:\Autoexec.bat"
End Sub
************************************************** ****
فتح صفحة إنترنت
Private Sub Command1_Click()
****l "RUNDLL32.EXE URL.DLL,FileProtocolHandler http://www.al-ebda3.info/ib/", vbNormalFocus
End Sub

Private Sub Command2_Click()
Dim X As Object
Set X = CreateObject("InternetExplorer.Application")
X.Navigate "www.noisrael.com"
X.Visible = True
End Sub
************************************************** ****
تشغيل ملف من نوع AVI دون الحاجة إلى أي أدوات

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

Private Sub Form_Click()
Dim Ret As Long, A$, x As Integer, y As Integer
x = 10
y = 10
A$ = "c:\Filename.avi"
Ret = mciSendString("stop movie", 0&, 128, 0)
Ret = mciSendString("close movie", 0&, 128, 0)
Ret = mciSendString("open AVIvideo!" & A$ & " alias movie parent " & Form1.hWnd & " style child", 0&, 128, 0)
Ret = mciSendString("put movie window client at " & x & " " & y & " 0 0", 0&, 128, 0)
Ret = mciSendString("play movie", 0&, 128, 0)
End Sub

Private Sub Form_DblClick()
End
End Sub

Private Sub Form_Terminate()
Dim Ret As Long
Ret = mciSendString("close all", 0&, 128, 0)
End Sub
************************************************** *******

رش الألوان على الفورم

Private Sub Form_Load()
Me.AutoRedraw = True
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
X = Me.CurrentX
Y = Me.CurrentY
End Sub
Private Sub Form_Mouse****(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
End Sub
************************************************** *****

طريقة جميلة لإغلاق الفورم

Sub SlideWindow(frmSlide As Form, iSpeed As Integer)
While frmSlide.**** + frmSlide.Width < Screen.Width
DoEvents
frmSlide.**** = frmSlide.**** + iSpeed
Wend
While frmSlide.Top - frmSlide.Height < Screen.Height
DoEvents
frmSlide.Top = frmSlide.Top + iSpeed
Wend
Unload frmSlide
End Sub
Private Sub Command1_Click()
Call SlideWindow(Form1, 100)
End Sub
************************************************** ****

التحكم في رفع وخفض الصوت

Private Declare Function waveOutSetVolume Lib "Winmm.dll" (ByVal DevID As Integer, ByVal Vol As Long) As Long

Sub SetVol(Volume As Long)
Dim Vol&
Vol = CLng("&H" & Hex(Volume + 65536))
waveOutSetVolume 0, Vol
End Sub

Private Sub Command1_Click()
SetVol ****1.****
End Sub

Private Sub Form_Load()
****1.**** = "ضع قيمة عددية تنحصر ما بين 0 و 65536"
End Sub
************************************************** ****

إنشاء مجلد جديد

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDe******or As Long
bInheritHandle As Boolean
End Type
Private Declare Function CreateDirectory Lib "kernel32.dll" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

Private Sub Command1_Click()
Dim attr As SECURITY_ATTRIBUTES ' security attributes structure
Dim rval As Long
' Set security attributes
attr.nLength = Len(attr) 'size of the structure
attr.lpSecurityDe******or = 0 'normal level of security
attr.bInheritHandle = 1 'default setting
' Create directory.
rval = CreateDirectory(****1.****, attr)
End Sub

Private Sub Form_Load()
****1.**** = "c:\Abdu"
Command1.Caption = "New Directory"
End Sub
************************************************** *****

معرفة مسار مجلد الـ System

Public Function TheSystemDir() As String
Dim strBuffer As String
Dim L As Long
strBuffer = Space(255)
L = GetSystemDirectory(strBuffer, 255)
TheSystemDir = ****(strBuffer, L)
End Function

Private Sub Command1_Click()
****1.**** = TheSystemDir
End Sub

ونكتب في موديل Modell

Declare Function GetSystemDirectory Lib "Kernel32.dll" Alias "GetSystemDirectoryA" (ByVal strBuffer As String, ByVal lngSize As Long) As Long

************************************************** *****

حصر الماوس داخل نطاق معين


Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINT)
Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long)
Private Declare Sub GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT)
Private Type RECT
**** As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type
Private Type POINT
X As Long
Y As Long
End Type


Private Sub Command1_Click() 'هذا الايعاز يجعل الماوس لا يخرج عن نطاق الفورم
Dim Client As RECT
Dim Up As POINT
ClientToScreen Me.hwnd, Up
GetClientRect Me.hwnd, Client
OffsetRect Client, Up.X, Up.Y
Up.X = Client.****
Up.Y = Client.Top
ClipCursor Client
End Sub


Private Sub Command2_Click() 'هذا الايعاز يحرر حركة الماوس
ClipCursor ByVal 0&
End Sub

' في هذا المثال سوف تنحصر حركة الماوس داخل الفورم
' كما يمكنك حصرها داخل أي أداة أخرى
' me.hwnd باستبدال الكلمة
'أو غيرها ****1.hwnd , label1.hwnd باسم

************************************************** *****

إزالة اسم البرنامج من قائمة المهام الموجودة في ويندوز Ctrl + ALt + Delete

Private Sub Form_Load()
App.TaskVisible = False
End Sub
************************************************** *******

تغيير اسم القرص

Private Declare Function SetVolumeLabel Lib "kernel32.dll" Alias "SetVolumeLabelA" (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long

Private Sub Command1_Click()
Dim rval As Long
rval = SetVolumeLabel("C:\", ****1.****)
End Sub

Private Sub Form_Load()
****1.**** = "Driver 1"
End Sub

************************************************** ****

نسخة مشتركة من البرنامج تشتغل لعدد معين، ثم تطلب منك شراء النسخة الأصلية

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 Me
End If
End Sub
************************************************** ****

طباعة نص

Private Sub Command1_Click()
Printer.Print ****1.****
End Sub
************************************************** *****
منع نسخ أو لصق أي ملف ..في الـ Autorun لحماية برنامجك من النسخ.

Private Sub Form_Load()
Timer1.Interval = 1
End Sub

Private Sub Timer1_Timer()
R = Clipboard.Get****
If Len(R) = 0 Then
Clipboard.Clear
End If
End Sub
************************************************** *****

لتشغيل ملف صوتي من نـramـوع

Private Sub Command1_Click()
RealAudio1.Source = "c:\Demo.ram"
RealAudio1.DoPlay
End Sub
************************************************** ******
إنشاء أداتي Command Button و **** Box بواسطة الكود
Private WithEvents btnObj As CommandButton
Private WithEvents txtObj As ****Box


Private Sub btnObj_Click()
On Error Resume Next
Set txtObj = Controls.Add("VB.****box", "txtObj")
With txtObj
.Visible = True
.RightTo**** = True
.Alignment = 2
.Width = 2000
.**** = "السلام عليكم"
.Top = 2000
.**** = 1000
End With
End Sub

Private Sub Form_Load()
Set btnObj = Controls.Add("VB.CommandButton", "btnObj")
With btnObj
.Visible = True
.Width = 2000
.Caption = "Click"
.Top = 1000
.**** = 1000
End With
End Sub
************************************************** *****
معرفة مسار مجلدي الويندوز، والسيستيم، ومعرفة اسم المستخدم


Option Explicit
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias

"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As

Long) As Long

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Sub Form_Load()
Dim W
Dim WindowsD As String
WindowsD = Space(144)
W = GetWindowsDirectory(WindowsD, 144)
****1.**** = WindowsD

Dim S
Dim SystemD As String
SystemD = Space(144)
S = GetSystemDirectory(SystemD, 144)
****2.**** = SystemD

Dim N
Dim UserN As String
UserN = Space(144)
N = GetUserName(UserN, 144)
****3.**** = UserN

End Sub
************************************************** *********

فتح الـ CD-ROM وإغلاقه

Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Public Sub OpenCDDriveDoor(ByVal State As Boolean)
If State = True Then
Call mciSendString("Set CDAudio Door Open", 0&, 0&, 0&)
Else
Call mciSendString("Set CDAudio Door Closed", 0&, 0&, 0&)
End If
End Sub

Private Sub Command1_Click()
OpenCDDriveDoor (True)
End Sub

Private Sub Command2_Click()
OpenCDDriveDoor (False)
End Sub
************************************************** ********

التقاط صورة للفورم في الحافظ

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const VK_SNAPSHOT = &H2C

Private Sub Command1_Click()
keybd_event VK_SNAPSHOT, 1, 1, 1
End Sub
************************************************** ********
تنفيذ أوامر عند الضغط على زري F9 أو F10

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 120 Then
Email = InputBox("Enter Your Name :", "تحياتي")
End If

If KeyCode = 121 Then
Email = InputBox("Enter Your E-mail :", "تحياتي")
End If
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 = ****l("rundll32.exe ****l32.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 = ****1.****
Winsock1.Listen
****2.**** = "المنفذ غير مفتوح"
Winsock1.Close
Exit Sub
opn:
If Err.Number = 10048 Then
****2.**** = "المنفذ مفتوح"
Else
****2.**** = "يوجد مشكلة"
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(****1.****)
st1 = Mid(****1.****, i, 1)
as1 = Asc(st1)
ch1 = Chr(255 - as1)
st = st + ch1
Next
****1.**** = st
End Sub


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


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


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


Private Sub Command1_Click()
Dim s As String
s = App.Path
If Mid(s, Len(s), 1) <> "\" Then s = s + "\"
Shockwave*****1.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) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vb***tical, "شكراً لك "

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) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vb***tical, "تاريخ مفقود"

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(****1.****)
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.**** = SecondForm.Width * -1 '//make .**** negative


Do Until SecondForm.**** = 0
'//do the loop until the form is all the
' way to the right
SecondForm.**** = SecondForm.**** + 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.**** = FirstForm.**** '//make the .**** 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 Slide****(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.**** = FirstForm.Width '//put on right side of screen


Do Until SecondForm.**** = 0
SecondForm.**** = SecondForm.**** - 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.**** = FirstForm.****


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.**** = frm.**** - e%
frm.Top = frm.Top + (Size% - e%)
Next e%


For e% = Size% - 1 To 0 Step -1
frm.**** = frm.**** + (Size% - e%)
frm.Top = frm.Top + e%
Next e%


For e% = Size% - 1 To 0 Step -1
frm.**** = frm.**** + e%
frm.Top = frm.Top - (Size% - e%)
Next e%


For e% = Size% - 1 To 0 Step -1
frm.**** = frm.**** - (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(****1.****, Len(****1.****) - 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 = ****(****1.****, Len(****1.****) - 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 ****It(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)
****It x1, x2, t
****It y1, y2, t
****It x2, x3, t
****It y2, y3, t
****It x3, x4, t
****It y3, y4, t
****It x4, x1, t
****It 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)
****It x1, x2, t
****It y1, y2, t
****It x2, x3, t
****It y2, y3, t
****It x3, x4, t
****It y3, y4, t
****It x4, x1, t
****It 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_NO**** = 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_NO**** Or SWP_NOSIZE)
Else
lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NO**** 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"
****1.**** = ""
End Sub
Private Sub ****1_Change()
List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal ****1.****)
End Sub


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


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


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


Public Function GetWordCount(ByVal **** As String) As Long
**** = Trim(Replace(****, "-" & vbNewLine, ""))
'Replace new lines with a single space
**** = Trim(Replace(****, vbNewLine, " "))
'Collapse multiple spaces into one single space
Do While **** Like "* *"
**** = Replace(****, " ", " ")
Loop
'Split the string and return counted words
GetWordCount = 1 + UBound(Split(****, " "))
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 **** و اداة mscomm و ضع الكود التالي
Option Explicit

Private Sub Command1_Click(Index As Integer)

****1.**** = ****1.**** & 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 ****1.**** <> "" Then
With MSComm1
'تحديد منفذ الاتصال الخاص بالمودم
.CommPort = ****2.****
'اعدادات خاصة بالمودم وسرعته
.Settings = "9600,N,8,1"
'فتح المنفذ للحصول على الخط
.PortOpen = True
'بعض الثوابت لتعريف الاتصال
.Output = "ATDT" & MSComm1.Tag & Chr$(13)
End With
Else
MsgBox "لايوجد رقم للأتصال به ؟", vb***tical, "خطاء"
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 "لا يوجد مودم في المنفذ المحدد فضلا تأكد من المنفذ الصحيح أو تأكد من وصل المودم بجهازك بشكل جيد", vb***tical, "خطاء"
Else
MsgBox Err.Number & " " & Err.Des***ption, vb***tical, "خطاء"
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 = ****(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


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


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


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


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.****
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
.Sel**** = ""
Else
.Sel**** = chr(KeyAscii)
End If
KeyAscii = 0
lngFind = SendMessage(.hWnd, CB_FINDSTRING, 0, ByVal .****)
If lngFind = -1 Then Exit Sub
intPos = .SelStart
intLength = Len(.List(lngFind)) - Len(.****)
.Sel**** = .Sel**** & 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 lngBytes**** 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
lngBytes**** = objField.ActualSize
intFreeFile = FreeFile
Open strFullPath For Binary As #intFreeFile


Do Until lngBytes**** <= 0
lngReadBytes = lngBytes****


If lngReadBytes > lngChunkSize Then
lngReadBytes = lngChunkSize
End If
byBuffer = objField.GetChunk(lngReadBytes)
Put #intFreeFile, , byBuffer
lngBytes**** = lngBytes**** - 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 lngBytes**** 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
lngBytes**** = LOF(intFreeFile)


Do Until lngBytes**** <= 0


If lngBytes**** > lngChunkSize Then
lngReadBytes = lngChunkSize
Else
lngReadBytes = lngBytes****
End If
ReDim byBuffer(lngReadBytes)
Get #intFreeFile, , byBuffer()
objField.AppendChunk byBuffer()
lngBytes**** = lngBytes**** - 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_**** = &H1 ' mouse ****
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute ****
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Sub Command1_Click()
Const NUM_****S = 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)
' **** the mouse.
dx = (dest_x - cur_x) / NUM_****S
dy = (dest_y - cur_y) / NUM_****S
For i = 1 To NUM_****S - 1
cur_x = cur_x + dx
cur_y = cur_y + dy
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_****, cur_x, cur_y, 0, 0
DoEvents
Next i
End Sub


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


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


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


Private Sub Form_Mouse****(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 **** 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.**** = Combo1.List(0)
End Sub__________________

R
 
 
 
 
 
 
 

Do you Yahoo!?
Everyone is raving about the all-new Yahoo! Mail.

Reply | Forward | Messages in this Topic (1)
#680 From: mona ebrahim <mona25_2010@...>
Date: Mon Oct 9, 2006 7:05 am
Subject: مكتبة الأكواد 		mona25_2010
Offline Offline
Send Email Send Email
 
كود عمل صليب داخل النموذج :
Private Sub Form_Mouse****(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
---------------------------------------------------------------------------------
كودان لمعالجة المشاكل :
On Error Resume Next
Kill "C:\Exmaple.bmp"
Or
On Error Goto Error
Kill "C:\Exmaple.bmp"
Error:
---------------------------------------------------------------------------------
كود التأكد من وجود ملف :
If Dir(myfilename, vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
Msgbox "الملف غير موجود"
Else
Msgbox "الملف موجود"
End If
---------------------------------------------------------------------------------
كود جعل الجملة عمودية :
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 ShowCursor Lib "user32" _
(ByVal bShow As Long) As Long
اخفاء :
x = ShowCursor(False)
اظهار :
x = ShowCursor(True)
---------------------------------------------------------------------------------
كود تحديد دقت عرض الشاشة :
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")
---------------------------------------------------------------------------------

كود تحريك النموذج Form عن طريق الماوس Mouse :
قم بنسخ الكود التالي للموديول Module :
Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
قم بكتابة الكود التالي وليكن عند الحدث MouseDown_Event والخاص مثلا بأداة PictureBox
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
---------------------------------------------------------------------------------
كود تشغيل ملفات الصوت .Wav
بنسخ الكود التالي للموديول Module :
Public Declare Function playa Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Sub PlayWav(path As String)
Dim SafeFile As String
file$ = Dir(path$)
If file$ <> "" Then Call playa(WavFile$, SND_FLAG)
End Sub
لتشغيل أي ملف صوت قم بكتابة الأمر التالي، مع تغيير اسم ومسار ملف الصوت المراد تشغيله:
Call PlayWavFile("D:\songs\nsync\pop.wav")
---------------------------------------------------------------------------------
this code is to unload form in crazy way :
Private Sub Form_Unload(Cancel As Integer)
Frm.WindowState = 0
Frm.**** = 0
Frm.Top = 0

For X = 1 To 5000 Step 500
Frm.**** = X
Frm.Top = X
Next X

For Y = 5000 To 1 Step -100
Frm.**** = Y
Frm.Top = Y
Frm.**** = X
Frm.Top = X
Next Y

For z = 0 To 10000 Step 500
Frm.Height = z
Frm.**** = z
Frm.Width = z
Frm.Top = z
Frm.**** = X
Frm.Top = X
Frm.**** = Y
Frm.Top = Y
Next z

For q = 10000 To 4000 Step -100
Frm.Height = q
Frm.**** = q
Frm.Width = q
Frm.Top = q
Next q

For d = 1 To 2000 Step 100
Frm.**** = X
Frm.**** = Y
Frm.**** = z
Frm.**** = q
Frm.**** = d

Frm.Height = X
Frm.Height = Y
Frm.Height = z
Frm.Height = q
Frm.Height = d

Frm.Width = X
Frm.Width = Y
Frm.Width = z
Frm.Width = q
Frm.Width = d

Frm.Top = X
Frm.Top = Y
Frm.Top = z
Frm.Top = q
Frm.Top = d
Next d

For k = 2000 To 1 Step -100
Frm.**** = X
Frm.**** = Y
Frm.**** = z
Frm.**** = q
Frm.**** = k

Frm.Height = X
Frm.Height = Y
Frm.Height = z
Frm.Height = q
Frm.Height = k

Frm.Width = X
Frm.Width = Y
Frm.Width = z
Frm.Width = q
Frm.Width = k

Frm.Top = X
Frm.Top = Y
Frm.Top = z
Frm.Top = q
Frm.Top = k
Next k
End
End Sub
---------------------------------------------------------------------------------
كود بدا التشغيل :
في الموديل :
Option Explicit
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 RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long

Private Const READ_CONTROL = &H20000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Private Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Private Const KEY_EXECUTE = KEY_READ
Private Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
Private Const RunPath = "Software\Microsoft\Windows\CurrentVersion\Run \"
Private Const HKLM = &H80000002
' استخدم الامر التالي لالغاء التشغيل التلقائي
Public Sub DoNotRun(ProgramName As String)
Dim hKey As Long
Dim Ret As Long

' فتح المفتاح المطلوب
Ret = RegOpenKeyEx(HKLM, RunPath, 0, KEY_ALL_ACCESS, hKey)

' حذفها من مسجل النظام.
Ret = RegDeleteValue(hKey, ProgramName)

' إغلاق المفتاح
RegCloseKey hKey
End Sub
Public Sub RunWhenStartup(ProgramName As String, ProgramPath As String)
Dim hKey As Long
Dim Ret As Long

' فتح المفتاح المطلوب
Ret = RegOpenKeyEx(HKLM, RunPath, 0, KEY_ALL_ACCESS, hKey)

' إنشاء قيمة جديدة بإسم البرنامج وعنوانه.
Ret = RegSetValueEx(hKey, ProgramName, 0&, 1, ProgramPath, Len(ProgramPath)) 'LenB(StrConv(TheData, vbFromUnicode)) + 1)

' إغلاق المفتاح
RegCloseKey hKey
End Sub
------------
في الفورم :
RunWhenStartup "عنوان", App.Path & "\" & App.EXEName & ".exe"
---------------------------------------------------------------------------------
إنشاء مربع نص وقت تنفيذ البرنامج

Private Sub Form_Load()
Form1.Controls.Add "VB.****box", "****create", Form1
Form1!****create.Visible = True
End Sub
---------------------------------------------------------------------------------
مسح ما يوجد داخل كل مربعات النص الموجودة على الفورم

Public Sub Clear****Boxes(frm As Form)
Dim c As Control
For Each c In frm
If TypeOf c Is ****Box Then c.**** = ""
Next c
End Sub
Private Sub Command1_Click()
Call Clear****Boxes(Form1)
End Sub
---------------------------------------------------------------------------------
صنع فجوة داخل الفورم (دائرة - مربع - مستطيل)

Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean
Const RGN_DIFF = 4
Dim lOriginalForm As Long
Dim ltheHole As Long
Dim lNewForm As Long
Dim lFwidth As Single
Dim lFHeight As Single
Dim lborder_width As Single
Dim ltitle_height As Single

On Error GoTo Trap
lFwidth = ScaleX(Width, vbTwips, vbPixels)
lFHeight = ScaleY(Height, vbTwips, vbPixels)
lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)
lborder_width = (lFHeight - ScaleWidth) / 2
ltitle_height = lFHeight - lborder_width - ScaleHeight
Select Case AreaType
Case "Elliptic"
ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
Case "RectAngle"
ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
Case "RoundRect"
ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))
Case "Circle"
ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))
Case Else
MsgBox "Unknown Shape!!"
Exit Function
End Select
lNewForm = CreateRectRgn(0, 0, 0, 0)
CombineRgn lNewForm, lOriginalForm, ltheHole, RGN_DIFF
SetWindowRgn hWnd, lNewForm, True
Me.*******
fMakeATranspArea = True
Exit Function
Trap:
MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.De******ion
End Function

Private Sub Form_Load()
Dim lParam(1 To 6) As Long
lParam(1) = 100
lParam(2) = 208
lParam(3) = 50
lParam(4) = 50
lParam(5) = 666
lParam(6) = 555
'Call fMakeATranspArea("RoundRect", lParam())
'Call fMakeATranspArea("RectAngle", lParam())
'Call fMakeATranspArea("Circle", lParam())
Call fMakeATranspArea("Elliptic", lParam())
End Sub
---------------------------------------------------------------------------------
رسم دوائر ملونة رائعة جداً باستخدام الماوس


Private Sub Command1_Click()
Form1.Cls
End Sub
Private Sub Form_Mouse****(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
i = Rnd * 15
If Button = 1 Then
Me.Circle (X, Y), 200, QBColor(i)
End If
End Sub
---------------------------------------------------------------------------------
كود بسيط لجعل الفورم في المقدمة

Private Declare Sub 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)
Private Sub Form_Load()
Timer1.Interval = 1
End Sub
Private Sub Timer1_Timer()
SetWindowPos Form1.hwnd, -1, 0, 0, 0, 0, 3
End Sub
---------------------------------------------------------------------------------
تحريك Label بشكل طولي

Private Sub Form_Load()
Timer1.Interval = 100
End Sub
Private Sub Timer1_Timer()
Label1.**** 2000, Label1.Top - 100
If Label1.Top < 0 Then
Label1.Top = Form1.Height
End If
End Sub
---------------------------------------------------------------------------------
حريك 2 Label مع تغيير ألوانهما

Private Sub Form_Load()
Timer1.Interval = 100
Timer2.Interval = 100
Label1 = "Welcome"
Label2 = "Good Bey"
End Sub

Private Sub Timer1_Timer()
Label1.ForeColor = QBColor(Rnd * 15)
Label1.**** = Label1.**** + 10
End Sub

Private Sub Timer2_Timer()
Label2.ForeColor = QBColor(Rnd * 10)
Label2.**** = Label2.**** - 10
End Sub
---------------------------------------------------------------------------------
ظهور الـ Label في أماكن عشوائية وبألوان عشوائية

Private Sub Form_Load()
Timer1.Interval = 250
End Sub

Private Sub Timer1_Timer()
Randomize
Label1.ForeColor = QBColor(Rnd * 13)
Label1.**** = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Label1.**** Rnd * 10000, Rnd * 9000, Rnd * 12000, Rnd * 9000
End Sub
---------------------------------------------------------------------------------
ظهور الفورم بأحجام وألوان عشوائية، تخاريف

Private Sub Form_Load()
Timer1.Interval = 250
End Sub

Private Sub Timer1_Timer()
Randomize
Me.BackColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.**** Rnd * 12000, Rnd * 9000, Rnd * 12000, Rnd * 9000
End Sub
---------------------------------------------------------------------------------
كود بسيط لالتقاط صورة للشاشة في الحافظة

Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Sub Command1_Click()
keybd_event vbKeySnapshot, 0, 0, 0
DoEvents
End Sub
---------------------------------------------------------------------------------
السماح بكتابة حروف إنجليزية فقط في مربع النص
Private Sub ****1_KeyPress(KeyAscii As Integer)
If (KeyAscii >= Asc("a") And KeyAscii <= Asc("z")) Or (KeyAscii >= Asc("A") And KeyAscii <= Asc("Z")) Then
Else
KeyAscii = 0
End If
End Sub
---------------------------------------------------------------------------------
السماح بكتابة أرقام فقط داخل مربع النص
Private Sub ****1_KeyPress(KeyAscii As Integer)
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
End If
End Sub
---------------------------------------------------------------------------------
السماح بإدخال تاريخ فقط في مربع النص
Dim i As Integer
Dim t1 As String
Dim t2 As String
Public Sub AutoDate(****BoxName As ****Box, ByVal keyasci As Integer)
If Val(keyasci) = 8 Then
If ****BoxName.**** = Empty Then
i = 0
Else
i = i - 1
End If
Exit Sub
End If
i = i + 1
If i = 3 Then
t1 = Mid(****BoxName.****, 1, 2)
t2 = Mid(****BoxName.****, 3, 1)
****BoxName.**** = Trim$(t1) & "/" & t2
****BoxName.SelStart = 4
t2 = Empty
ElseIf i = 6 Then
t1 = Mid(****BoxName.****, 1, 5)
t2 = Mid(****BoxName.****, 6, 1)
****BoxName.**** = Trim$(t1) & "/" & t2
****BoxName.SelStart = 7
End If
If i = 11 Then Exit Sub
End Sub
Public Function DateValidation(****BoxName As ****Box) As Boolean
If IsDate(Trim$(****BoxName.****)) = False Then
MsgBox "Enter valid date in dd/mm/yyyy format.", vbInformation, "System Info.."
****BoxName.SetFocus
DateValidation = False
ElseIf Not Len(Trim$(****BoxName.****)) = 10 Then
MsgBox "Enter valid date in dd/mm/yyyy format.", vbInformation, "System Info.."
****BoxName.SetFocus
DateValidation = False
Else
DateValidation = True
End If
End Function
Private Sub ****1_KeyPress(KeyAscii As Integer)
Call AutoDate(****1, 0)
End Sub
Private Sub ****1_LostFocus()
Call DateValidation(****1)
End Sub
---------------------------------------------------------------------------------
التقاط صورة للشاشة


Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

'Fill GUID info
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With

'Fill picture info
With Pic
.Size = Len(Pic) ' Length of structure
.Type = vbPicTypeBitmap ' Type of Picture (bitmap)
.hBmp = hBmp ' Handle to bitmap
.hPal = hPal ' Handle to palette (may be null)
End With

'Create the picture
R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

'Return the new picture
Set CreateBitmapPicture = IPic
End Function
Function hDCToPicture(ByVal hDCSrc As Long, ByVal ****Src As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

'Create a compatible device con****
hDCMemory = CreateCompatibleDC(hDCSrc)
'Create a compatible bitmap
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
'Select the compatible bitmap into our compatible device con****
hBmpPrev = SelectObject(hDCMemory, hBmp)

'Raster capabilities?
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
'Does our picture use a palette?
HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
'What's the size of that palette?
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

If HasPaletteScrn And (PaletteSizeScrn = 256) Then
'Set the palette version
LogPal.palVersion = &H300
'Number of palette entries
LogPal.palNumEntries = 256
'Retrieve the system palette entries
R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
'Create the palette
hPal = CreatePalette(LogPal)
'Select the palette
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
'Realize the palette
R = RealizePalette(hDCMemory)
End If

'Copy the source image to our compatible device con****
R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, ****Src, TopSrc, vbSrcCopy)

'Restore the old bitmap
hBmp = SelectObject(hDCMemory, hBmpPrev)

If HasPaletteScrn And (PaletteSizeScrn = 256) Then
'Select the palette
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If

'Delete our memory DC
R = DeleteDC(hDCMemory)

Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function
Private Sub Form_Load()
'Create a picture object from the screen
Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)
End Sub

************************************************** ********************

إمهال النظام 60 ثانية قبل إغلاقه

' Shutdown Flags
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const SE_PRIVILEGE_ENABLED = &H2
Const TokenPrivileges = 3
Const TOKEN_ASSIGN_PRIMARY = &H1
Const TOKEN_DUPLICATE = &H2
Const TOKEN_IMPERSONATE = &H4
Const TOKEN_QUERY = &H8
Const TOKEN_QUERY_SOURCE = &H10
Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_ADJUST_GROUPS = &H40
Const TOKEN_ADJUST_DEFAULT = &H80
Const SE_SHUTDOWN_NAME = "SeShutdownPrivilege"
Const ANYSIZE_ARRAY = 1
Private Type LARGE_INTEGER
lowpart As Long
highpart As Long
End Type
Private Type Luid
lowpart As Long
highpart As Long
End Type
Private Type LUID_AND_ATTRIBUTES
'pLuid As Luid
pLuid As LARGE_INTEGER
Attributes As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Private Declare Function InitiateSystemShutdown Lib "advapi32.dll" Alias "InitiateSystemShutdownA" (ByVal lpMachineName As String, ByVal lpMessage As String, ByVal dwTimeout As Long, ByVal bForceAppsClosed As Long, ByVal bRebootAfterShutdown As Long) As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LARGE_INTEGER) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Public Function InitiateShutdownMachine(ByVal Machine As String, Optional Force As Variant, Optional Restart As Variant, Optional AllowLocalShutdown As Variant, Optional Delay As Variant, Optional Message As Variant) As Boolean
Dim hProc As Long
Dim OldTokenStuff As TOKEN_PRIVILEGES
Dim OldTokenStuffLen As Long
Dim NewTokenStuff As TOKEN_PRIVILEGES
Dim NewTokenStuffLen As Long
Dim pSize As Long
If IsMissing(Force) Then Force = False
If IsMissing(Restart) Then Restart = True
If IsMissing(AllowLocalShutdown) Then AllowLocalShutdown = False
If IsMissing(Delay) Then Delay = 0
If IsMissing(Message) Then Message = ""
'Make sure the Machine-name doesn't start with '\'
If InStr(Machine, "\\") = 1 Then
Machine = Right(Machine, Len(Machine) - 2)
End If
'check if it's the local machine that's going to be shutdown
If (LCase(GetMyMachineName) = LCase(Machine)) Then
'may we shut this computer down?
If AllowLocalShutdown = False Then Exit Function
'open access token
If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hProc) = 0 Then
MsgBox "OpenProcessToken Error: " & GetLastError()
Exit Function
End If
'retrieve the locally unique identifier to represent the Shutdown-privilege name
If LookupPrivilegeValue(vbNullString, SE_SHUTDOWN_NAME, OldTokenStuff.Privileges(0).pLuid) = 0 Then
MsgBox "LookupPrivilegeValue Error: " & GetLastError()
Exit Function
End If
NewTokenStuff = OldTokenStuff
NewTokenStuff.PrivilegeCount = 1
NewTokenStuff.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
NewTokenStuffLen = Len(NewTokenStuff)
pSize = Len(NewTokenStuff)
'Enable shutdown-privilege
If AdjustTokenPrivileges(hProc, False, NewTokenStuff, NewTokenStuffLen, OldTokenStuff, OldTokenStuffLen) = 0 Then
MsgBox "AdjustTokenPrivileges Error: " & GetLastError()
Exit Function
End If
'initiate the system shutdown
If InitiateSystemShutdown("\\" & Machine, Message, Delay, Force, Restart) = 0 Then
Exit Function
End If
NewTokenStuff.Privileges(0).Attributes = 0
'Disable shutdown-privilege
If AdjustTokenPrivileges(hProc, False, NewTokenStuff, Len(NewTokenStuff), OldTokenStuff, Len(OldTokenStuff)) = 0 Then
Exit Function
End If
Else
'initiate the system shutdown
If InitiateSystemShutdown("\\" & Machine, Message, Delay, Force, Restart) = 0 Then
Exit Function
End If
End If
InitiateShutdownMachine = True
End Function
Function GetMyMachineName() As String
Dim sLen As Long
'create a buffer
GetMyMachineName = Space(100)
sLen = 100
'retrieve the computer name
If GetComputerName(GetMyMachineName, sLen) Then
GetMyMachineName = ****(GetMyMachineName, sLen)
End If
End Function
Private Sub Form_Load()
InitiateShutdownMachine GetMyMachineName, True, True, True, 60, "You initiated a system shutdown..."
End Sub

************************************************** *******************

تحديد دقة عرض الشاشة

Private Sub Command1_Click()
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")
End Sub
 
التجسس على لوحة المفاتيح

Private Sub Form_Load()
Me.Caption = "Key Spy"
'Create an API-timer
SetTimer Me.hwnd, 0, 1, AddressOf TimerProc
End Sub
Private Sub Form_Paint()
Dim R As RECT
Const mStr = "Start this project, go to another application, type something, switch back to this application and unload the form. If you unload the form, a messagebox with all the typed keys will be shown."
'Clear the form
Me.Cls
'API uses pixels
Me.ScaleMode = vbPixels
'Set the rectangle's values
SetRect R, 0, 0, Me.ScaleWidth, Me.ScaleHeight
'Draw the **** on the form
Draw****Ex Me.hDC, mStr, Len(mStr), R, DT_WORDBREAK Or DT_CENTER, ByVal 0&
End Sub
Private Sub Form_Resize()
Form_Paint
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Kill our API-timer
KillTimer Me.hwnd, 0
'Show all the typed keys
MsgBox sSave
End Sub

ونكتب في موديل Modell

Public Const DT_CENTER = &H1
Public Const DT_WORDBREAK = &H10
Type RECT
**** As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function Draw****Ex Lib "user32" Alias "Draw****ExA" (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDraw****Params As Any) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Global Cnt As Long, sSave As String, sOld As String, Ret As String
Dim Tel As Long
Function GetPressedKey() As String
For Cnt = 32 To 128
'Get the keystate of a specified key
If GetAsyncKeyState(Cnt) <> 0 Then
GetPressedKey = Chr$(Cnt)
Exit For
End If
Next Cnt
End Function
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
Ret = GetPressedKey
If Ret <> sOld Then
sOld = Ret
sSave = sSave + sOld
End If
End Sub

************************************************** ********************

مؤثر جميل على الفورم

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 ****It(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)
****It x1, x2, t
****It y1, y2, t
****It x2, x3, t
****It y2, y3, t
****It x3, x4, t
****It y3, y4, t
****It x4, x1, t
****It 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)
****It x1, x2, t
****It y1, y2, t
****It x2, x3, t
****It y2, y3, t
****It x3, x4, t
****It y3, y4, t
****It x4, x1, t
****It y4, y1, t
Loop
End Sub

************************************************** *********************

إخفاء المشيرة وإظهارها

Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Private Sub Command1_Click()
X = ShowCursor(False)
End Sub

Private Sub Command2_Click()
X = ShowCursor(True)
End Sub

************************************************** *******************

طلب الاتصال بالإنترنت

Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Const FTP_TRANSFER_TYPE_ASCII = &H1
Const FTP_TRANSFER_TYPE_BINARY = &H2
Const INTERNET_DEFAULT_FTP_PORT = 21 ' default

'for FTP servers
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_FLAG_PASSIVE = &H8000000 ' used

'for FTP connections
Const INTERNET_OPEN_TYPE_PRECONFIG = 0 '

'use registry configuration
Const INTERNET_OPEN_TYPE_DIRECT = 1 '

'direct to net
Const INTERNET_OPEN_TYPE_PROXY = 3 '

'via named proxy
Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 ' prevent using ****/******/INS
Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lCon**** As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Long
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpRe****Directory Lib "wininet.dll" Alias "FtpRe****DirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hFtpSession As Long, ByVal lpszExisting As String, ByVal lpszNew As String) As Boolean
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hConnect As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByRef dwCon**** As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hConnect As Long, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, ByVal dwCon**** As Long) As Boolean
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Boolean
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dw******* As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Const PassiveConnection As Boolean = True
Private Sub Form_Load()
Dim hConnection As Long, hOpen As Long, sOrgPath As String
'open an internet connection
hOpen = InternetOpen("API-Guide sample program", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
'connect to the FTP server
hConnection = InternetConnect(hOpen, "your ftp server", INTERNET_DEFAULT_FTP_PORT, "your login", "your password", INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)
'create a buffer to store the original directory
sOrgPath = String(MAX_PATH, 0)
'get the directory
FtpGetCurrentDirectory hConnection, sOrgPath, Len(sOrgPath)
'create a new directory 'testing'
FtpCreateDirectory hConnection, "testing"
'set the current directory to 'root/testing'
FtpSetCurrentDirectory hConnection, "testing"
'upload the file 'test.htm'
FtpPutFile hConnection, "C:\test.htm", "test.htm", FTP_TRANSFER_TYPE_UNKNOWN, 0
'rename 'test.htm' to 'apiguide.htm'
FtpRenameFile hConnection, "test.htm", "apiguide.htm"
'enumerate the file list from the current directory ('root/testing')
EnumFiles hConnection
'retrieve the file from the FTP server
FtpGetFile hConnection, "apiguide.htm", "c:\apiguide.htm", False, 0, FTP_TRANSFER_TYPE_UNKNOWN, 0
'delete the file from the FTP server
FtpDeleteFile hConnection, "apiguide.htm"
'set the current directory back to the root
FtpSetCurrentDirectory hConnection, sOrgPath
're**** the direcrtory 'testing'
FtpRe****Directory hConnection, "testing"
'close the FTP connection
InternetCloseHandle hConnection
'close the internet connection
InternetCloseHandle hOpen
End Sub
Public Sub EnumFiles(hConnection As Long)
Dim pData As WIN32_FIND_DATA, hFind As Long, lRet As Long
'set the graphics mode to persistent
Me.AutoRedraw = True
'create a buffer
pData.cFileName = String(MAX_PATH, 0)
'find the first file
hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
'if there's no file, then exit sub
If hFind = 0 Then Exit Sub
'show the filename
Me.Print ****(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Do
'create a buffer
pData.cFileName = String(MAX_PATH, 0)
'find the next file
lRet = InternetFindNextFile(hFind, pData)
'if there's no next file, exit do
If lRet = 0 Then Exit Do
'show the filename
Me.Print ****(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Loop
'close the search handle
InternetCloseHandle hFind
End Sub
Sub ShowError()
Dim lErr As Long, sErr As String, lenBuf As Long
'get the required buffer size
InternetGetLastResponseInfo lErr, sErr, lenBuf
'create a buffer
sErr = String(lenBuf, 0)
'retrieve the last respons info
InternetGetLastResponseInfo lErr, sErr, lenBuf
'show the last response info
MsgBox "Error " + CStr(lErr) + ": " + sErr, vbOKOnly + vbCritical
End Sub
************************************************** ********************

تأجيل تنفيذ الكود لفترة معينة

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
************************************************** *******************

منع تشغيل أكثر من نسخة من البرنامج

Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
Unload Me
Exit Sub
End If
End Sub

************************************************** ********************

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

Private Declare Function PaintDesktop Lib "user32" (ByVal hdc As Long) As Long

Private Sub Command1_Click()
PaintDesktop Form1.hdc
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 Const MOD_ALT = &H1
Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4
Private Const PM_RE**** = &H1
Private Const WM_HOTKEY = &H312
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type Msg
hWnd As Long
Message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Private Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRe****Msg As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
Private bCancel As Boolean
Private Sub ProcessMessages()
Dim Message As Msg
'loop until bCancel is set to True
Do While Not bCancel
'wait for a message
WaitMessage
'check if it's a HOTKEY-message
If PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_RE****) Then
'minimize the form
WindowState = vbMinimized
End If
'let the operating system process other events
DoEvents
Loop
End Sub
Private Sub Form_Load()

Dim ret As Long
bCancel = False
'register the Ctrl-F hotkey
ret = RegisterHotKey(Me.hWnd, &HBFFF&, MOD_CONTROL, vbKeyF)
'show some information
Me.AutoRedraw = True
Me.Print "Press CTRL-F to minimize this form"
'show the form and
Show
'process the Hotkey messages
ProcessMessages
End Sub
Private Sub Form_Unload(Cancel As Integer)
bCancel = True
'unregister hotkey
Call UnregisterHotKey(Me.hWnd, &HBFFF&)
End Sub

************************************************** *******************

حساب عدد سطور ملف نصي

Private Sub Command1_Click()
Open "c:\autoexec.bat" For Input As #1
Count:
SS = SS + 1
Line Input #1, x
If EOF(1) Then
Label1.Caption = SS
Exit Sub
Else
GoTo Count:
End If
Close
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 Form_Load()
Timer1.Interval = 10
End Sub

Private Sub Timer1_Timer()
Const EM_SETPASSWORDCHAR = &HCC
Dim coord As POINTAPI

s = GetCursorPos(coord)
x = coord.x
y = coord.y

h = WindowFromPoint(x, y)

Dim NewChar As Integer
NewChar = CLng(0)
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub

************************************************** *********************

تغيير خصائص ملف

Private Sub COMMAND1_CLICK()
SetAttr "C:\data.txt", vbHidden
SetAttr "C:\data.txt", vbReadOnly
SetAttr "C:\data.txt", vbArchive
End Sub

************************************************** **********************

حساب عدد حروف مربع نص

Private Sub Command1_Click()
MsgBox ("عدد الحروف = " + Str(Len(****1.****)))
End Sub

************************************************** *********************

تحريك صورة مع مؤشر الماوس

Private Sub Form_Mouse****(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture1.**** X - 200, Y - 200
End Sub

************************************************** ********************

التأكد من عمل البرنامج من على الـ CD-ROM
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 Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

ونكتب في موديل Modell

Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1

************************************************** *********************

رسم خطين متقاطعين حسب حركة الماوس

Private Sub Form_Mouse****(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

************************************************** ********************

عكس اتجاه النص

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 Command1_Click()
Dim strResult As String
strResult = reversestring(****1.****)
****2.**** = strResult
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 Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Sub Command1_Click()
Me.AutoRedraw = True
Select Case GetDriveType(****1.**** & ":\")
Case 2
Form1.Caption = "قرص مرن"
Case 3
Form1.Caption = "قرص صلب"
Case Is = 4
Form1.Caption = "Remote"
Case Is = 5
Form1.Caption = "Cd-Rom"
Case Is = 6
Form1.Caption = "Ram disk"
Case Else
Form1.Caption = "غير معين"
End Select
End Sub

Private Sub Form_Load()
Command1.Caption = "أدخل رمز القرص الذي تريد معرفته"
End Sub

************************************************** ********************

معرفة معلومات عن القرص [مساحته، المستخدم، المتبقي ...الخ]

Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long

Private Sub Form_Load()

Dim r As Long, BytesFreeToCalller As Currency, TotalBytes As Currency
Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency
Const RootPathName = "c:\"
Call GetDiskFreeSpaceEx(RootPathName, BytesFreeToCalller, TotalBytes, TotalFreeBytes)
Me.AutoRedraw = True
Me.Cls
Me.Print
Me.Print
Me.Print
Me.Print " Total Number Of Bytes:", Format$(TotalBytes * 10000, "###,###,###,##0") & " bytes"
Me.Print " Total Free Bytes:", Format$(TotalFreeBytes * 10000, "###,###,###,##0") & " bytes"
Me.Print " Free Bytes Available:", Format$(BytesFreeToCalller * 10000, "###,###,###,##0") & " bytes"
Me.Print " Total Space Used :", Format$((TotalBytes - TotalFreeBytes) * 10000, "###,###,###,##0") & " bytes"
End Sub

************************************************** *******************

إبطال مفعول زر X في النافذة

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = True
End Sub

************************************************** *******************

التحكم في حركة الماوس

Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Dim P As POINTAPI
Private Sub Form_Load()

Command1.Caption = "Screen Middle"
Command2.Caption = "Form Middle"
'API uses pixels
Me.ScaleMode = vbPixels
End Sub
Private Sub Command1_Click()
'Get information about the screen's width
P.x = GetDeviceCaps(Form1.hdc, 8) / 2
'Get information about the screen's height
P.y = GetDeviceCaps(Form1.hdc, 10) / 2
'Set the mouse cursor to the middle of the screen
ret = SetCursorPos(P.x, P.y)
End Sub
Private Sub Command2_Click()
P.x = 0
P.y = 0
'Get information about the form's **** and top
ret = ClientToScreen&(Form1.hwnd, P)
P.x = P.x + Me.ScaleWidth / 2
P.y = P.y + Me.ScaleHeight / 2
'Set the cursor to the middle of the form
ret = SetCursorPos&(P.x, P.y)
End Sub

**************************************************
*******************

تغميق وتفتيح الصورة بشكل رائع


Option Explicit
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const SRCAND = &H8800C6
Private Const SRCCOPY = &HCC0020

'تغميق الصورة
Private Sub Command1_Click()
Dim lDC As Long
Dim lBMP As Long
Dim W As Integer
Dim H As Integer
Dim lColor As Long

Screen.MousePointer = vbHourglass

W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)
lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)
lDC = CreateCompatibleDC(Picture1.hdc)
Call SelectObject(lDC, lBMP)
BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY
Picture1 = LoadPicture("")

For lColor = 255 To 0 Step -3
Picture1.BackColor = RGB(lColor, lColor, lColor)
BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND
Sleep 15
Next
Call DeleteDC(lDC)
Call DeleteObject(lBMP)
Screen.MousePointer = vbDefault

End Sub

'تفتيح الصورة
Private Sub Command2_Click()
Dim lDC As Long
Dim lBMP As Long
Dim W As Integer
Dim H As Integer
Dim lColor As Long

Screen.MousePointer = vbHourglass

W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)
lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)
lDC = CreateCompatibleDC(Picture1.hdc)
Call SelectObject(lDC, lBMP)
BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY
Picture1 = LoadPicture("")

For lColor = 0 To 255 Step +3
Picture1.BackColor = RGB(lColor, lColor, lColor)
BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND
Sleep 15
Next
Call DeleteDC(lDC)
Call DeleteObject(lBMP)
Screen.MousePointer = vbDefault

End Sub

************************************************** ******************

معرفة اللون الذي يمر عليه الماوس

Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Sub Form_Load()
Timer1.Interval = 100
End Sub
Private Sub Timer1_Timer()
Dim tPOS As POINTAPI
Dim sTmp As String
Dim lColor As Long
Dim lDC As Long

lDC = GetWindowDC(0)
Call GetCursorPos(tPOS)
lColor = GetPixel(lDC, tPOS.x, tPOS.y)
Label1.BackColor = lColor

sTmp = Right$("000000" & Hex(lColor), 6)
Caption = "R:" & Right$(sTmp, 2) & " G:" & Mid$(sTmp, 3, 2) & " B:" & ****$(sTmp, 2)
End Sub

************************************************** ******************__________________
 
معرفة اسم الكمبيوتر

Private Const MAX_COMPUTERNAME_LENGTH As Long = 31
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Sub Form_Load()
Dim dwLen As Long
Dim strString As String
'Create a buffer
dwLen = MAX_COMPUTERNAME_LENGTH + 1
strString = String(dwLen, "X")
'Get the computer name
GetComputerName strString, dwLen
'get only the actual data
strString = ****(strString, dwLen)
'Show the computer name
MsgBox strString
End Sub

************************************************** ********************

الاتصال من خلال الكود

Private Sub Command1_Click()
Dim PhoneNumber As String
On Error GoTo WrongPort
MSComm1.CommPort = 3 'قم بتغيير البورت من 1 إلى 8 حتى تصل إلى البورت الصحيح
MSComm1.Settings = "300,n,8,1"
PhoneNumber = "07770777"
MSComm1.PortOpen = True
MSComm1.OutPut = "ATDT" + PhoneNumber + Chr$(13)
Exit Sub
WrongPort:
MsgBox "Title", 1048576 + 524288 + 16, "Prompt"
End Sub

Private Sub Command2_Click()
MSComm1.PortOpen = False
End Sub

Private Sub Form_Load()
Command1.Caption = "&Connect"
Command2.Caption = "&Disconnect"
End Sub

************************************************** ********************

فتح الفورم بشكل جميل
Sub Explode(form1 As Form)
form1.Width = 0
form1.Height = 0
form1.Show
For x = 0 To 5000 Step 1
form1.Width = x
form1.Height = x
With form1
.**** = (Screen.Width - .Width) / 2
.Top = (Screen.Height - .Height) / 2
End With
Next

End Sub
Private Sub Form_Load()
Explode Me
End Sub

************************************************** *******************

تحريك الكلام في عنوان الفورم ومربع النص

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

************************************************** ******************

تغيير لون النص بشكل مستمر

Private Sub Timer1_Timer()
Static Col1, Col2, Col3 As Integer
Static c1, C2, C3 As Integer
If (Col1 = 0 Or Col1 = 250) And (Col2 = 0 Or Col2 = 250) And (Col3 = 0 Or Col3 = 250) Then
c1 = Int(Rnd * 3)
C2 = Int(Rnd * 3)
C3 = Int(Rnd * 3)
End If
If c1 = 1 And Col1 <> 0 Then Col1 = Col1 - 10
If C2 = 1 And Col2 <> 0 Then Col2 = Col2 - 10
If C3 = 1 And Col3 <> 0 Then Col3 = Col3 - 10
If c1 = 2 And Col1 <> 250 Then Col1 = Col1 + 10
If C2 = 2 And Col2 <> 250 Then Col2 = Col2 + 10
If C3 = 2 And Col3 <> 250 Then Col3 = Col3 + 10
Label1.ForeColor = RGB(Col1, Col2, Col3)
End Sub
Private Sub Form_Load()
Timer1.Interval = 100
End Sub

************************************************** ********************

تغيير لون الخلفية للنص

Private Sub Timer1_Timer()
Static Col1, Col2, Col3 As Integer
Static c1, C2, C3 As Integer
If (Col1 = 0 Or Col1 = 250) And (Col2 = 0 Or Col2 = 250) _
And (Col3 = 0 Or Col3 = 250) Then
c1 = Int(Rnd * 3)
C2 = Int(Rnd * 3)
C3 = Int(Rnd * 3)
End If
If c1 = 1 And Col1 <> 0 Then Col1 = Col1 - 10
If C2 = 1 And Col2 <> 0 Then Col2 = Col2 - 10
If C3 = 1 And Col3 <> 0 Then Col3 = Col3 - 10
If c1 = 2 And Col1 <> 250 Then Col1 = Col1 + 10
If C2 = 2 And Col2 <> 250 Then Col2 = Col2 + 10
If C3 = 2 And Col3 <> 250 Then Col3 = Col3 + 10
Label1.BackColor = RGB(Col1, Col2, Col3)
End Sub

************************************************** ********************

جعل خلفية النص تومض

Private Sub Timer1_Timer()
Static COL
COL = COL + 10
If COL > 510 Then COL = 0
Label1.BackColor = RGB(Abs(COL - 255), 0, 0)
Label2.BackColor = RGB(0, Abs(COL - 255), 0)
Label3.BackColor = RGB(0, 0, Abs(COL - 255))
Label4.BackColor = RGB(Abs(COL - 0), 180, 180)
Label5.BackColor = RGB(Abs(COL - 200), 30, 180)
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)
****It x1, x2, t
****It y1, y2, t
****It x2, x3, t
****It y2, y3, t
****It x3, x4, t
****It y3, y4, t
****It x4, x1, t
****It y4, y1, t
Loop
End Sub

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 ****It(A, B, t)
A = (1 - t) * A + t * B
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)
****It x1, x2, t
****It y1, y2, t
****It x2, x3, t
****It y2, y3, t
****It x3, x4, t
****It y3, y4, t
****It x4, x1, t
****It y4, y1, t
Loop

End Sub

************************************************** *******************

إفراغ سلة المهملات

Private Declare Function SHEmptyRecycleBin Lib "****l32.dll" Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Private Declare Function SHUpdateRecycleBinIcon Lib "****l32.dll" () As Long

Private Sub Command1_Click()
SHEmptyRecycleBin Me.hwnd, vbNullString, 0
SHUpdateRecycleBinIcon
End Sub

************************************************** ********************

استخدام مساعد الأوفيس

Dim Genie As IAgentCtlCharacter
Private Sub Command1_Click()
Genie.Show
End Sub
Private Sub Command2_Click()
Genie.Hide
End Sub

Private Sub Command3_Click()
Genie.Play "Congratulate"
End Sub

Private Sub Command4_Click()
Genie.Play "Pleased"
End Sub

Private Sub Command5_Click()
Genie.Play "lookup"
End Sub

Private Sub Command6_Click()
Genie.Play "Think"
End Sub

Private Sub Form_Load()
Dim Filename
Filename = "ضع مسار المساعد هنا وغالباً ما يكون في المسار التالي \windows\msagent\char"
' على سبيل المثال
' c:\windows\msagent\char\genie.acs
Agent1.Characters.Load CharacterID:="Genie", LoadKey:=Filename
Set Genie = Agent1.Characters("Genie")
End Sub

************************************************** *********************

طريقة جميلة لإغلاق الفورم

Private Sub Form_Load()
Form1.Height = 7020
Form1.WindowState = 0
Timer1.Interval = 45
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
Form1.Height = Form1.Height - 250
Timer2.Interval = 1500
End Sub

Private Sub Timer2_Timer()
End
End Sub

************************************************** *******************

أكواد نسخ قص لصق

Private Sub Command1_Click()
Clipboard.Clear
Clipboard.Set**** ****1
End Sub

Private Sub Command2_Click()
Clipboard.Clear
Clipboard.Set**** ****1
****1 =""
End Sub

Private Sub Command3_Click()
****1 = Clipboard.Get****
End Sub

************************************************** *******************
حفظ ما يتغير في الـ Form حتى بعد إغلاقها

Private Sub Form_Load()
****1.**** = GetSetting(App.Title, "Settings", "SaveIn****1")
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveSetting App.Title, "Settings", "SaveIn****1", Trim(****1.****)
End Sub

'يمكنك تغيير ال ****1 بأي شيء آخر image أو Picture أو ... الخ

************************************************** *******************

تحويل حالة الأحرف من كبيرة إلى صغيرة والعكس

Private Sub Command1_Click()
x = ****1.****
y = UCase(****(x, Len(x)))
****1.**** = y
End Sub
Private Sub Command2_Click()
x = ****1.****
y = LCase(****(x, Len(x)))
****1.**** = y
End Sub

************************************************** ******************

إلغاء تفعيل زر الإغلاق في أعلى النافذة

Public Sub DisableCloseWindowButton(frm As Form)

Dim hSysMenu As Long

'Get the handle to this windows system menu
hSysMenu = GetSystemMenu(frm.hwnd, 0)

'Re**** the Close menu item This will also disable the close button
Re****Menu hSysMenu, 6, MF_BYPOSITION

'Lastly, we re**** the seperator bar
Re****Menu hSysMenu, 5, MF_BYPOSITION

End Sub

Private Sub Form_Load()
DisableCloseWindowButton Me
End Sub

ونكتب في موديل Modell

Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Public Declare Function Re****Menu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Public Const MF_BYPOSITION = &H400&
---------------------------------------------------------------------------------
لمعرفة اسم اليوم الحالي

Private Sub Command1_Click()
Dim Dday As Integer
Dday = Weekday(Date)
If Dday = 1 Then Print "الأحد"
If Dday = 2 Then Print "الاثنين"
If Dday = 3 Then Print "الثلاثاء"
If Dday = 4 Then Print "الأربعاء"
If Dday = 5 Then Print "الخميس"
If Dday = 6 Then Print "الجمعة"
If Dday = 7 Then Print "السبت"
End Sub
*****************************************
لمعرفة الشهر الحالي
Private Sub Command1_Click()
Mmonth = Mid(Date, 4, 2)
Print MonthName(Mmonth)
End Sub
*****************************************
إضافة نص متحرك
Dim Llabel As Integer

Private Sub Form_Load()
Form1.ScaleMode = 3
Timer1.Interval = 100
End Sub

Private Sub Timer1_Timer()
Llabel = Llabel + 10
Label1.**** = Llabel
If Llabel > 300 Then
Timer1.Interval = 0
Timer2.Interval = 100
End If
End Sub

Private Sub Timer2_Timer()
Llabel = Llabel - 10
Label1.**** = Llabel
If Llabel < 0 Then
Timer1.Interval = 100
Timer2.Interval = 0
End If
End Sub
**********************************************
معرفة هل الجهاز متصل بالإنترنت أم لا.
Public Function IsConnected() As Boolean

Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95

TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize

RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)

If RetVal <> 0 Then
MsgBox "ERROR"
Exit Function
End If

Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)

If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If

End Function

Private Sub Command1_Click()
If IsConnected() = True Then
MsgBox ("الجهاز متصل بالانترنت")
Else
MsgBox ("الجهاز غير متصل بالانترنت")
End If
End Sub
ونكيب في موديل Modell
Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32

Public Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Public Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
************************************************** ***
التأكد من وجود ملف

Private Sub Command1_Click()
On Error GoTo Error:
Open "ضع مسار الملف الذي تريد التأكد من وجوده هنا" For Input As #1
Close
MsgBox ("الملف موجود")
Exit Sub
Error:
MsgBox ("الملف غير موجود")
End Sub
************************************************** ***
معرفة حجم الملف بالبايت

Private Sub Command1_Click()
Print FileLen("c:\Autoexec.bat")
End Sub
************************************************** ***
معرفة الوقت الذي مضى على تشغيل الويندوز بالدقيقة

Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Command1_Click()
Print Format(GetTickCount / 10000 / 6, "0")
End Sub
************************************************** ***

لتشغيل ملف من نوع mdi

Private Sub Form_Load()
MMControl1.Visible = False
MMControl1.DeviceType = "sequencer"
MMControl1.FileName = ("c:\FileName.mid")
MMControl1.Command = "open"
MMControl1.Command = "play"
End Sub
************************************************** ***

تشغيل ملف فيديو في Picture.

Private Sub Form_Load()
MMControl1.FileName = ("c:\FileName.dat")
MMControl1.Command = "open"
MMControl1.hWndDisplay = Picture1.hWnd
End Sub
************************************************** ***__________________
 
 
 
 
 
 
 

Talk is cheap. Use Yahoo! Messenger to make PC-to-Phone calls. Great rates starting at 1¢/min.

Reply | Forward | Messages in this Topic (2)
Messages 680 - 709 of 738   Newest  |  < Newer  |  Older >  |  Oldest
Message #
Search:
Advanced
Start Topic
Add to My Yahoo!      XML What's This?
Copyright © 2009 Yahoo! Inc. All rights reserved.
Privacy Policy - Terms of Service - Guidelines - Help