اكواد مهمه للفيجوال بيسك (ماعليك سوى النسخ) ~ مدرسة الابداع

اكواد فيجوال بيسك جاهزه ماعليك سوى النسخ

____________________________________

كود يخليلك الفورم شفافة

وبنختار درجة الشفافية اللي إحنا عايزنها من 0 الي 255

نضيف Module1 جديد ونضيغ الكود هذا فيه

كود PHP:

Option Explicit

Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Declare Function UpdateLayeredWindow Lib "user32" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, crKey As Long, ByVal pblend As Long, ByVal dwFlags As Long) As Long

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long

Public Type POINTAPI

x As Long

y As Long

End Type

Public Type SIZE

cx As Long

cy As Long

End Type

Public Type BLENDFUNCTION

BlendOp As Byte

BlendFlags As Byte

SourceConstantAlpha As Byte

AlphaFormat As Byte

End Type

Public Const WS_EX_LAYERED = &H80000

Public Const GWL_STYLE = (-16)

Public Const GWL_EXSTYLE = (-20)

Public Const AC_SRC_OVER = &H0

Public Const AC_SRC_ALPHA = &H1

Public Const AC_SRC_NO_PREMULT_ALPHA = &H1

Public Const AC_SRC_NO_ALPHA = &H2

Public Const AC_DST_NO_PREMULT_ALPHA = &H10

Public Const AC_DST_NO_ALPHA = &H20

Public Const LWA_COLORKEY = &H1

Public Const LWA_ALPHA = &H2

Public Const ULW_COLORKEY = &H1

Public Const ULW_ALPHA = &H2

Public Const ULW_OPAQUE = &H4

Public lret As Long

Function CheckLayered(ByVal hWnd As Long) As Boolean

lret = GetWindowLong(hWnd, GWL_EXSTYLE)

If (lret And WS_EX_LAYERED) = WS_EX_LAYERED Then

CheckLayered = True

Else

CheckLayered = False

End If

End Function

Function SetLayered(ByVal hWnd As Long, SetAs As Boolean, bAlpha As Byte)

lret = GetWindowLong(hWnd, GWL_EXSTYLE)

If SetAs = True Then

lret = lret Or WS_EX_LAYERED

Else

lret = lret And Not WS_EX_LAYERED

End If

SetWindowLong hWnd, GWL_EXSTYLE, lret

SetLayeredWindowAttributes hWnd, 0, bAlpha, LWA_ALPHA

End Function

وهنضيف الكود ده في الفورم لود

كود PHP:

Private Sub Form_Load()

SetLayered Me.hWnd, True, 230

End Sub

ملحوظة لو عايزين نغير درجة الشفافية هنغير الرقم 230 الي

في الكود السابق زي ما إحنا عايزين

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

لن اطول عليكم فلنباشر التحديث

الزر الأيمن للماوس

كود PHP:

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

كود PHP:

IF BUTTON=2 THEN

msgbox "الزر الأيمن للماوس"

END IF

End Sub

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

فحص المنافذ

كود PHP:

Private Sub Command1_Click()

On Error GoTo opn:

Winsock1.LocalPort = Text1.Text

Winsock1.Listen

Text2.Text = "المنفذ غير مفتوح"

Winsock1.Close

Exit Sub

opn:

If Err.Number = 10048 Then

Text2.Text = "المنفذ مفتوح"

Else

Text2.Text = "يوجد مشكلة"

End If

Winsock1.Close

End Sub

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

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

كود PHP:

Dim startdate As String

Dim differenceofdate

Dim TRACEDATE As String

Dim newdate

Dim chk

كود PHP:

If GetSetting(App.Title, "Startup", "counter", "") = "" Then

SaveSetting App.Title, "Startup", "counter", 1

SaveSetting App.Title, "Startup", "Started", Format(Date, "mm dd yyyy")

SaveSetting App.Title, "Startup", "Last Used", Format(Date, "mm dd yyyy")

lblcnt.Caption = "1"

ElseIf GetSetting(App.Title, "Startup", "counter", "") = "31" Then

MsgBox "شكراً لستخدامك هذا البرنامج " & Chr(10) + Chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vbCritical, "شكراً لك "

End

Else

TRACEDATE = GetSetting(App.Title, "Startup", "Last Used", "")

chk = DateDiff("d", CDate(TRACEDATE), Now)

If chk < 0 Then CHECK IF THE DATE WAS CHANGE which is lesser than the PREVIOUS DATE WHERE THE SYSTEM USED.

MsgBox "لم يتم العثور على تاريخ النظام لديك !! " & Chr(10) + Chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vbCritical, "تاريخ مفقود"

End

Else

startdate = GetSetting(App.Title, "Startup", "Started", "")

differenceofdate = DateDiff("d", startdate, Now)

If differenceofdate <> 0 Then

lblcnt.Caption = differenceofdate + 1

SaveSetting App.Title, "Startup", "Last Used", Format(Now, "MM DD YYYY")

SaveSetting App.Title, "Startup", "counter", differenceofdate + 1

End If

If differenceofdate = 0 Then

lblcnt.Caption = GetSetting(App.Title, "Startup", "Counter", "")

End If

End Sub

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

تنزيل ملف من الانترنت

كود PHP:

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")

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

كود PHP:

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

كود PHP:

Private Sub Form_Load()

If App.PrevInstance = True Then

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

Unload Me

Exit Sub

End If

End Sub

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

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

هذا يوضع في التصريح العام

كود PHP:

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

كود PHP:

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

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

هذه الدالة تقوم بنقل ملف من مسار إلى مسار آخر

كود PHP:

Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

Private Sub Command1_Click()

MoveFile "c:\Windows\Desktop\a.txt", "c:\a.txt"

End Sub

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

نسخ محتويات مربع نص الى مربع نص اخر

كود PHP:

If you have VB6.0 you can use the Replace Function to

easily replace any Character(s) with something else, eg.

كود PHP:

Text2 = Replace(Text1, vbCrLf, "" & vbCrLf)

Otherwise, youll need to step though the Text yourself

checking for instances of vbCrLf, e.g.

code:

Dim sString As String

Dim sNewString As Strings

String = Text1

While Instr(sString, vbCrLf)

sNewString = sNewString & Left(sString, _

Instr(sString, vbCrLf) - 1) & "" & vbCrLf

sString = Mid(sString, Instr(sString, vbCrLf) + 2)

Wend

Text2 = sNewString

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

كود لابطال عملية ctrl+alt+del

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

كود PHP:

Private Declare Function SystemParametersInfo Lib _

"user32" Alias "SystemParametersInfoA" (ByVal uAction _

As Long, ByVal uParam As Long, ByVal lpvParam As Any, _

ByVal fuWinIni As Long) As Long

Sub DisableCtrlAltDelete(bDisabled As Boolean)

Dim X As Long

X = SystemParametersInfo(97, bDisabled, CStr(1), 0)

End Sub

لإبطال عمل المفاتيح ضع السطر التالي في المكان المناسب

كود PHP:

Call DisableCtrlAltDelete(True)

لإعادة عمل المفاتيح ضع السطر التالي في المكان المناسب

كود PHP:

Call DisableCtrlAltDelete(False)

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

للتشفير وفك التشفير

كود PHP:

ضع هذا الكود في لود فورم

SubClass (Me.HWnd )

وضع هذا الكود في ان لود فورم

UnSubClass (Me.HWnd)

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

الدالة CopyFile لنسخ ملف من مسار إلى آخر

هذه الدالة تساعدك على نسخ الملفات من مسار لآخر

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

كود PHP:

Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

كود PHP:

نضع هدا الزر في الفورم لواد او في الكوماند

CopyFile "c:\my documents\b.txt", "c:\b.txt", False

طبعا من تغير المسار الموجود في اللون الأحمر الى اي مسار تريده

أو اليك كود أخر

Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

Private Sub Command1_Click()

MoveFile "c:\my documents\a.txt", "c:\a.txt"

End Sub

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

برنامج يطلع رقم الآي بي << درس ولا اسهل

حط واحد كوماند وواحد ادة وينسوك <معروفة<

بعدها دبل كليك على الكوماند وكتب هاذا الكود بين الجملتين

كود PHP:

msgbox "" + Winsock1.LocalIP

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

كود للكتابة بعدة ألوان داخل أداة النص في textbox

يمكنك عمل ذلك مع اداة الريتش تكست وليس مع التكست العادى

وبالنسبة لكود التلوين فهو

قم اولا بتحديد الجزء المراد تلوينه ثم اضف الكود

كود PHP:

Private Sub command1_click()

RichText1.SelColor=vbred

End Sub

وبالنسبة لمنع النسخ واللصق فضع هذا الكود داخل اداة تايمر

كود PHP:

Private Sub Timer1_Timer()

ClipBoard.Clear

End Sub

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

اما باقى الاكواد فانا للاسف لااعرفها

لقد توصلت الى باقى الاكواد وهاهى اليك

بالنسبة لتغيير حجم سطر معين اليك هذا الكود

كود PHP:

private sub Command1_Click()

RichText1.SelFontSize=20

End Sub

وكود التسطير

كود PHP:

RichText1.SelUnderline =true

وكود التضخيم

كود PHP:

RichText1.SelBold =true

وكود جعل الخط مائل

كود PHP:

RichText1.SelItalic =true

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

عرض نموذج داخل نموذج آخر

أضف نموذجين Form2, Form1

كود PHP:

Private Declare Function SetParent Lib "user32" _

(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Private Sub Form_Load()

SetParent Form1.hwnd, Form2.hwnd

Form2.Show

End Sub

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

هل تريد زر أمر يكون مشابه لأزرار مبرمجي فيجوال سي ++

جرب هذا الكود ولا تنس ضبط خاصية Command1.Style = 1-Graphical

كود PHP:

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 Sub Form_Load()

SendMessage Command1.hWnd, &HF4&, &H0&, 0&

End Sub

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

تحريك الماوس برمجيا باستخدام الكود التالي

أضف Command1,Command2 ثم انسخ الكود التالي

كود PHP:

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private Declare Function ClientToScreen Lib "user32" _

(ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Private Declare Sub mouse_event Lib "user32" _

(ByVal dwFlags As Long, ByVal dx As Long, _

ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)

Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move

Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move

Private Type POINTAPI

X As Long

Y As Long

End Type

Private Sub Command1_Click()

Const NUM_MOVES = 2000

Dim pt As POINTAPI

Dim cur_x As Long

Dim cur_y As Long

Dim dest_x As Long

Dim dest_y As Long

Dim dx As Long

Dim dy As Long

Dim i As Integer

ScaleMode = vbPixels

GetCursorPos pt

cur_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)

cur_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)

'تحديد مكان الماوس الجديد

pt.X = Command2.Width / 2

pt.Y = Command2.Height / 2

ClientToScreen Command2.hwnd, pt

dest_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)

dest_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)

' Move the mouse.

dx = (dest_x - cur_x) / NUM_MOVES

dy = (dest_y - cur_y) / NUM_MOVES

For i = 1 To NUM_MOVES - 1

cur_x = cur_x + dx

cur_y = cur_y + dy

mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, cur_x, cur_y, 0, 0

DoEvents

Next i

End Sub

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

هل تريد تشغيل برنامجك باستخدام أمر معين من خلال الدوس او من قائمة تشغيل Run

مثلا yourapp.exe /msg

او yourapp.exe /normal

هذا الكود مفيد جدا وغير معروف لأغلب المستخدمين

كود PHP:

Private Sub Form_Load()

Dim args As String

Get the command line arguments.

args = Trim$(Command$)

Select Case args

Case "msg"

MsgBox "test message"

Case Else

Form1.Caption = args

End Select

End Sub

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

كود للبحث عن كلمة في التست بوكس

ضع تكست

كود PHP:

Private Sub Form_Load()

Text1.Text = "Two of the peak human experiences"

Text1.Text = Text1.Text & " are good food and classical music."

End Sub

Private Sub Form_Click()

Dim Search, Where ' Declare variables.

' Get search string from user.

Search = InputBox("Enter text to be found:")

Where = InStr(Text1.Text, Search) ' Find string in text.

If Where Then ' If found,

Text1.SetFocus

Text1.SelStart = Where - 1 ' set selection start and

Text1.SelLength = Len(Search) ' set selection length.

Else

MsgBox "String not found." Notify user.

End If

End Sub

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

كود لتحريك الفورم بواسطة الأسهم فقط يلصق في الكود

كود PHP:

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal v As Long) As Integer 'للحركة

'الدالة

'GetAsyncKeyState

'تستقبل أي زر

حتى إذا لم يكن له رقم آسكي

كود PHP:

'هذا مثال على تحريك الفورم بواسطة الأسهم

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

If GetAsyncKeyState(37) Then 'يسار

Left = Left - 15

End If

If GetAsyncKeyState(38) Then 'أعلى

Top = Top - 15

End If

If GetAsyncKeyState(39) Then 'يمين

Left = Left + 15

End If

If GetAsyncKeyState(40) Then أسفل

Top = Top + 15

End If

End Sub

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

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

كود PHP:

Private Sub Command1_Click()

الوضع الطبيعي النسخ

Picture2.PaintPicture Picture1.Picture, 0, 0, _

Picture1.Width, Picture1.Height, 0, 0, _

Picture1.Width, Picture1.Height, vbSrcCopy

End Sub

كود PHP:

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

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

هذا الكود لإنهاء البرنامج عند النقر على Esc في لوحة المفاتيح مهما كان موقع التركيز بين الأدوات.....

'Load انسخ هذا الكود لحدث تحميل النموذج

كود PHP:

Private Sub Form_Load()

Form1.KeyPreview = True

End Sub

'KeyPress انسخ هذا الكود لحدث النموذج

كود PHP:

Private Sub Form_KeyPress(KeyAscii As Integer)

If KeyAscii = 27 Then

End

End If

End Sub

'KeyPress بدلاً من كود الحدث KeyDownويمكن ايضاًوضع الكود التالي في الحدث

كود PHP:

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

If KeyCode = vbKeyEscape Then End

End Sub

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

كلمة مرور لنموذج في برنامجك

كود PHP:

Private Sub Form_Load()

تعريف المتغيرات

كود PHP:

Dim s As Integer

Dim passw As String

'اعطاء قيمة اولية

s = 1

'بدية التكرار واختبار ووضع كلمة المرور

Do Until (s = 5 Or passw = "هنا ضع كلمة المرور")

'عرض مربع الادخال لكتابة كلمة المرور

passw = InputBox("ادخل كلمة المرور الى قاعدة البيانات", "كلمة مرور مطلوبة")

'مقدار زيادة لستمرار التكرار

s = s + 1

Loop

If s = 5 Then

'عرض رسالة للمستخدم بعد التكرار دون تحقق الشرط

MsgBox "كلمة المرور التي ادخلتها خاطئة... الرجاء حاول مرة أخرى", vbOKOnly, "خطأ في كلمة المرور"

End

'عرض النموذج بعد التأكد من تحقق الشرط

Form1.Show "form1"

خروج من التكرار

End If

End Sub

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

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

كود PHP:

Private Sub Command1_Click()

Dim s As String

s = App.Path

If Mid(s, Len(s), 1) <> "\" Then s = s + ""

ShockwaveFlash1.Movie = s + "a4.swf"

كود PHP:

End Sub

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

توسيط اسم الفورم في الوسط

كود PHP:

Public Sub CenterC(frm As Form)

Dim SpcF As Integer 'How many spaces can fit

Dim clen As Integer 'caption length

Dim oldc As String 'oldcaption

Dim i As Integer 'not important

' 'remove any spaces at the ends of the caption

' 'very easy if you read it carefully

oldc = frm.Caption

Do While Left(oldc, 1) = Space(1)

كود PHP:

DoEvents

oldc = Right(oldc, Len(oldc) - 1)

Loop

Do While Right(oldc, 1) = Space(1)

DoEvents

oldc = Left(oldc, Len(oldc) - 1)

Loop

clen = Len(oldc)

If InStr(oldc, "!") <> 0 Then

If InStr(oldc, " ") <> 0 Then

clen = clen * 1.5

Else

clen = clen * 1.4

End If

Else

If InStr(oldc, " ") <> 0 Then

clen = clen * 1.4

Else

clen = clen * 1.3

End If

' ''see how many characters can fit

SpcF = frm.Width / 61.2244 ''how many space can fit it the caption

SpcF = SpcF - clen 'How many spaces can fit-How much space the

' 'caption takes up

' ''Now the tricky part

If SpcF > 1 Then

DoEvents 'speed up the program

frm.Caption = Space(Int(SpcF / 2)) + oldc

Else 'if the form is too small for spaces

frm.Caption = oldc

End If

End Sub

Private Sub Form_Resize()

If Me.Width = oldsize Then 'if the width hasn't changed

Exit Sub 'then dont mess with it

Else

CenterC Me

oldsize = Me.Width

End If

End Sub

Private Sub Form_Load()

CenterC Me

oldsize = Me.Width

End Sub

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

كود اعادة تسمية الملف

كود PHP:

name "c:\mypro\test.exe” as "c:myprotest.old”

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

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

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

المطلوب : انشاء مديول

اكتب فيها الكود التالي

كود PHP:

Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _

(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

كود PHP:

ثم ضع هذا الكود في الفورم

'Ahmed Ksnv'

Private Sub Form_Load()

'replace 1.wav with the WAV file you want to play

sndPlaySound "1.wav", 1

'the '1' following the file means that the program should not stop to play the file.

'The sound will play and other events can be happening.

'If you want the whole program to stop while the sound is playing, just change the '1' to '0'.

End Sub

ملحوظة

القيمة

"1"

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

ويمكنك تغيرها بالقيمة "0"

وتعني ان الصوت سيسبق عرض الفورم

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

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

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

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

كود PHP:

Private Sub Form_Load()

Dim s As String

Timer1.Interval = 1000

Open "c:\1.txt" For Input As #2

Input #2, s

Close #2

Text1.Text = s

End Sub

كود PHP:

Private Sub Timer1_Timer()

Open "c:\1.txt" For Output As #1

Print #1, Text1

Close #1

End Sub

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

حفظ ما يتغير في التيكست بعد اغلاقه

كود PHP:

Private Sub Form_Load()

Text1.Text = GetSetting(App.Title, "Settings", "SaveInText1")

End Sub

Private Sub Form_Unload(Cancel As Integer)

SaveSetting App.Title, "Settings", "SaveInText1", Trim(Text1.Text)

End Sub

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

فتح الفورم بشكل جميل

كود PHP:

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

.left = (screen.width - .width) / 2

.top = (screen.height - .height) / 2

end with

كود PHP:

end sub

private sub form_load()

explode me

end sub

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

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

كود PHP:

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Me.Cls

Line (X, 0)-(X, Me.ScaleHeight), vbRed

Line (0, Y)-(Me.ScaleWidth, Y), vbGreen

End Sub

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

لطباعة النص

ضع هذا الكود في الفورم

كود PHP:

Private Sub Command1_Click()

Printer.Print text1.text

End Sub

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

تلوين النموذج قبل اغلاقة

ضع هذا الكود في الفورم

كود PHP:

Private Sub Form_Unload(Cancel As Integer)

WindowState = 2 'تكبير حجم النموذج ليصبح بحجم الشاشة

DrawWidth = 4 'اتغيير حجم نقطة الرسم

For i = 1 To 18000 'التحضير للتنفيذ

Down = Down + 1 ' سرعة الرسم

Across = Across + 1

PSet (Rnd * Across, Rnd * Down), QBColor(Rnd * 15) 'رسم النقط

Next i ' اعد تنقيذ الرسم

End Sub

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

لتجميل الفورم

كود PHP:

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 +

End Function

Sub MoveIt(A, B, t)

A = (1 - t) * A + t * B

End Sub

Private Sub Form_Click()

Cls

Dim t As Single, x1 As Single, y1 As Single

Dim x2 As Single, y2 As Single, x3 As Single

Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)

t = 0.05

x1 = -320: y1 = 200

x2 = 320: y2 = 200

x3 = 320: y3 = -200

x4 = -320: y4 = -200

Do Until Dist(x1, y1, x2, y2) < 10

Line (x1, y1)-(x2, y2)

Line -(x3, y3)

Line -(x4, y4)

Line -(x1, y1)

MoveIt x1, x2, t

MoveIt y1, y2, t

MoveIt x2, x3, t

MoveIt y2, y3, t

MoveIt x3, x4, t

MoveIt y3, y4, t

MoveIt x4, x1, t

MoveIt y4, y1, t

Loop

End Sub

Private Sub Form_Resize()

Cls

Dim t As Single, x1 As Single, y1 As Single

Dim x2 As Single, y2 As Single, x3 As Single

Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)

t = 0.05

x1 = -320: y1 = 200

x2 = 320: y2 = 200

x3 = 320: y3 = -200

x4 = -320: y4 = -200

Do Until Dist(x1, y1, x2, y2) < 10

Line (x1, y1)-(x2, y2)

Line -(x3, y3)

Line -(x4, y4)

Line -(x1, y1)

MoveIt x1, x2, t

MoveIt y1, y2, t

MoveIt x2, x3, t

MoveIt y2, y3, t

MoveIt x3, x4, t

MoveIt y3, y4, t

MoveIt x4, x1, t

MoveIt y4, y1, t

Loop

End Sub

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

وضع الخطوط في أدة Combo

يحتاج الى اداة Combo

ضع هذا الكود في الفورم

كود PHP:

Private Sub Form_Load()

Dim i As Integer

For i = 0 To Screen.FontCount - 1

Combo1.AddItem Screen.Fonts(i)

Next i

Combo1.Text = Combo1.List(0)

End Sub

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

كود النسخ من مربع النص الى اخر

كود النسخ

كود PHP:

Clipboard.Clear

Clipboard.SetText Text1.Text

كود اللصق

Text2.Text = Clipboard.GetText

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

كود لعمل انزال الشريط

كود PHP:

Private Sub Command5_Click()

FrmMain.WindowState = 2

End Sub

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

كود لتنفيد اوامر رون

اضف text و command

كود PHP:

Private Sub Command1_Click()

On Error Resume Next

Shell Text1.Text

End Sub

لاكن الكود لا يفتح الملفات

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

References التعامل مع المكتبة Shell

ادرج 13 command

و 2label

و2 text

والان اليك مجموعة هائلة من الأكواد

Dim SH As New Shell

Private Sub Command1_Click()

Dim ShFB As Folder 'نسميه ب اختيار مجلد

' txtPath هذا الكوماند ندرجه باسفل

On Error Resume Next

'set object

Set ShFB = SH.BrowseForFolder(hWnd, "please choose a folder and click OK!", 1)

With ShFB.Items.Item

'get folder props

txtPath = .Path

txtFDetails = "Name: " & .Name & vbCrLf & "Type: " & .Type & vbCrLf & _

"Last Modified: " & .ModifyDate & vbCrLf & "Parent: " & .Parent & vbCrLf

End With

End Sub

Private Sub Command10_Click()

SH.Explore "Path" 'فتح المستكشف

End Sub

Private Sub Command11_Click()

SH.Open "Path" 'فتح قرص او مجلد

End Sub

Private Sub Command12_Click()

' فتح أي عنصر في لوحة التحكم

'لا تستدرجها دفعة واحدة قم

SH.ControlPanelItem "ALSNDMGR.CPL"

SH.ControlPanelItem "appwiz.cpl"

SH.ControlPanelItem "bthprops.cpl"

SH.ControlPanelItem "desk.cpl"

SH.ControlPanelItem "firewall.cpl"

SH.ControlPanelItem "hdwwiz.cpl"

SH.ControlPanelItem "inetcpl.cpl"

SH.ControlPanelItem "intl.cpl"

SH.ControlPanelItem "irprops.cpl"

SH.ControlPanelItem "main.cpl"

SH.ControlPanelItem "mmsys.cpl"

SH.ControlPanelItem "ncpa.cpl"

SH.ControlPanelItem "netsetup.cpl"

SH.ControlPanelItem "nusrmgr.cpl"

SH.ControlPanelItem "nwc.cpl"

SH.ControlPanelItem "odbccp32.cpl"

SH.ControlPanelItem "powercfg.cpl"

SH.ControlPanelItem "sysdm.cpl"

SH.ControlPanelItem "telephon.cpl"

SH.ControlPanelItem "timedate.cpl"

SH.ControlPanelItem "wscui.cpl"

SH.ControlPanelItem "wuaucpl.cpl"

SH.ControlPanelItem "cmicnfg.cpl"

SH.ControlPanelItem "alsndmgr.cpl"

SH.ControlPanelItem "ALSNDMGR.CPL"

SH.ControlPanelItem "ImageDrive.cpl"

SH.ControlPanelItem "CMICNFG.CPL"

SH.ControlPanelItem "sapi.cpl"

SH.ControlPanelItem "CMICNFG.CPL"

SH.ControlPanelItem "ALSNDMGR.CPL"

SH.ControlPanelItem "ODBCCP32.CPL"

End Sub

Private Sub Command13_Click()

'فتح برنامج المفكرة

Shell "notepad.exe", vbNormalNoFocus

AppActivate ("bloc-notes")

SendKeys ("اهلا بكم في منتدى الابداع الاسلامي")

End Sub

Private Sub Command2_Click()

SH.FileRun 'الرون

End Sub

Private Sub Command4_Click()

SH.Help 'المساعدة

End Sub

Private Sub Command5_Click()

SH.FindComputer 'البحث في الجهاز

End Sub

Private Sub Command6_Click()

SH.TrayProperties 'خصائص شريط المهام

End Sub

Private Sub Command7_Click()

SH.SetTime 'خصائص الوقت والتاريخ

End Sub

Private Sub Command8_Click()

SH.ShutdownWindows 'مربع حوار ايقاف التشغيل

End Sub

Private Sub Command9_Click()

'الذهاب للانترنت

SH.Open "هنا اكتب عنوان موقع الانترنت الذي ترغب بفتحة"

End Sub

Private Sub Form_Load()

End Sub

Private Sub Label1_Click()

'نسميه ب مسار المجلد

End Sub

Private Sub Label2_Click()

'نسميه بتفاصيل المجلد

End Sub

Private Sub txtFDetails_Change()

'name ادراج تكست وتبديل

'المسمى بمسار المجلد label هذا التكست ندرجه باسفل

End Sub

Private Sub txtPath_Change()

'name ادراج تكست وتبديل

'المسمى بتفاصيل المجلد label هذا التكست ندرجه باسفل

End Sub

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

كود ايقونة البرنامج بجوار الساعة

ضع هذا الكود في الفورم

Public 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

Public Const NIM_ADD = &H0

Public Const NIM_MODIFY = &H1

Public Const NIM_DELETE = &H2

Public Const NIF_MESSAGE = &H1

Public Const NIF_ICON = &H2

Public Const NIF_TIP = &H4

Public Const WM_MOUSEMOVE = &H200

Public Const WM_LBUTTONDOWN = &H201 'Button down

Public Const WM_LBUTTONUP = &H202 'Button up

Public Const WM_LBUTTONDBLCLK = &H203 'Double-click

Public Const WM_RBUTTONDOWN = &H204 'Button down

Public Const WM_RBUTTONUP = &H205 'Button up

Public Const WM_RBUTTONDBLCLK = &H206 'Double-click

Public Declare Function SetForegroundWindow Lib "user32" _

(ByVal hWnd As Long) As Long

Public Declare Function Shell_NotifyIcon Lib "shell32" _

Alias "Shell_NotifyIconA" _

(ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

Public nid As NOTIFYICONDATA

Private Sub Form_Load()

Me.Show

Me.Refresh

With nid

.cbSize = Len(nid)

.hWnd = Me.hWnd

.uId = vbNull

.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE

.uCallBackMessage = WM_MOUSEMOVE

.hIcon = Me.Icon

.szTip = "Your ToolTip" & vbNullChar

End With

Shell_NotifyIcon NIM_ADD, nid

End Sub

Private Sub Form_Resize()

If Me.WindowState = vbMinimized Then Me.Hide

End Sub

Private Sub Form_Unload(Cancel As Integer)

Shell_NotifyIcon NIM_DELETE, nid

End Sub

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

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

Private strText As String

Private Sub Form_Load()

Timer1.Interval = 75

strText = "Guten Tag! Wie ght's Ihnen? Ich hoffe Ihnen alles Gutes!"

strText = Space(50) & strText

End Sub

Private Sub Timer1_Timer()

strText = Mid(strText, 2) & Left(strText, 1)

Text1.Text = strText

Me.Caption = strText

End Sub

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

السماح بكتابة ارقام فقط داخل مربع النص

Private Sub Text1_KeyPress(KeyAscii As Integer)

If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then

KeyAscii = 0

End If

End Sub

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

طباعة النص على النودج بألوان مختلفة

Sub Form_Paint()

Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Const LWA_ALPHA = 2

Const GWL_EXSTYLE = (-20)

Const WS_EX_LAYERED = &H80000

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

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

Private Sub Text1_KeyPress(KeyAscii As Integer)

If KeyAscii = 32 Then

KeyAscii = 0

End If

End Sub

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

ازالة اسم البرنامج من ادارة المهام

Private Sub Form_Load()

App.TaskVisible = False

End Sub

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

الوقت الذي مضى في تشغيل الويندوز بالدقيقة

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

Private Sub Command1_Click()

Print Format(GetTickCount / 10000 / 6, "0")

End Sub

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

نمودج شفاف

Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Const LWA_ALPHA = 2

Const GWL_EXSTYLE = (-20)

Const WS_EX_LAYERED = &H80000

Private Sub Form_Load()

SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED

SetLayeredWindowAttributes hwnd, 0, 128, LWA_ALPHA

End Sub

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

لقراءة سطر معين من الملف

Public Function readLine(ByRef strFilePath As String, ByRef nLine _

As Integer) As String

Dim NextLine As String

Dim n As Integer

FileNum = FreeFile

Open strFilePath For Input As FileNum

Do Until EOF(FileNum)

Line Input #FileNum, NextLine

n = n + 1

If n = nLine Then readLine = NextLine

Loop

End Function

Private Sub Command1_Click()

'autoexec.bat لقراءة السطر الثالث من الملف

Text1.Text = readLine("c:\autoexec.bat", 3)

End Sub

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

النسخ الاحتياطي للبيانات

Private Sub CMDmak_Click()

'MkDir "D:\BACKUP"

'MkDir "D:\BACKUP\SITRAWI"

End Sub

'áäÓÎ ÇáãáÝ

Private Sub CMDBAK_Click()

SOURCE = "D:\hus\Aig.bmp"

dESTN = "D:\BACKUP\SITRAWI\AIG.BMp"

FileCopy SOURCE, dESTN

End Sub

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

تشفير / إلغاء تشفير نص باستخدام كلمة المرور

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As _

Any, source As Any, ByVal bytes As Long)

' encrypt a string using a password

' you must reapply the same function (and same password) on

' the encrypted string to obtain the original, non-encrypted string

' you get better, more secure results if you use a long password

' (e.g. 16 chars or longer). This routine works well only with ANSI strings.

Function EncryptString(ByVal Text As String, ByVal Password As String) As String

Dim passLen As Long

Dim i As Long

Dim passChr As Integer

Dim passNdx As Long

passLen = Len(Password)

' null passwords are invalid

If passLen = 0 Then Err.Raise 5

' move password chars into an array of Integers to speed up code

ReDim passChars(0 To passLen - 1) As Integer

CopyMemory passChars(0), ByVal StrPtr(Password), passLen * 2

' this simple algorithm XORs each character of the string

' with a character of the password, but also modifies the

' password while it goes, to hide obvious patterns in the

' result string

For i = 1 To Len(Text)

' get the next char in the password

passChr = passChars(passNdx)

' encrypt one character in the string

Mid$(Text, i, 1) = Chr$(Asc(Mid$(Text, i, 1)) Xor passChr)

' modify the character in the password (avoid overflow)

passChars(passNdx) = (passChr + 17) And 255

' prepare to use next char in the password

passNdx = (passNdx + 1) Mod passLen

EncryptString = Text

End Function

Private Sub Command1_Click()

Text2.Text = EncryptString(Text1.Text, "hythem")

End Sub

Private Sub Command2_Click()

Text3.Text = EncryptString(Text2.Text, "hythem")

End Sub

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

اضافة البرنامج الى قائمة regedit

اضافة البرنامج نفسه اول ما يشتغل الى قائمة regedit نفرض في هذاالمكان-hkey_local_machine-sofware-microsoft-windows

currentversion-run

و يعني ان يضيف نفسه الى تلك اللائحة

هذا فى قسم التعريفات

Private Function RegWrite(Key1, SValue As String)

Set WSHShell = CreateObject("WScript.Shell")

WSHShell.RegWrite Key1, SValue

End Function

و هذا في المكان المناسب ..في الفورم مثلاَ

Private Sub Form_Load()RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\ Curr entVersion\Run\EXENAME.exe", App.Path & "\EXENAME.exe"

End Sub

ملحوظة : قم بتغير كلمة EXENAME.exe , الى اسم برنامجك مثلا"...Project1.exe

هذا ان كان اسم برنامجك project1

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

جعل البرنامج يعمل مع بدء تشغيل وندوز

Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _

(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _

"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _

ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _

ByVal cbData As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" _

(ByVal hKey As Long) As Long

Private Const HKEY_LOCAL_MACHINE = &H80000002

Private Sub Form_Load()

Dim lRegKey As Long

Dim sApp As String

sApp = App.Path + IIf(Right(App.Path, 1) <> "", "", "") + App.EXEName + ".exe"

If RegOpenKey(HKEY_LOCAL_MACHINE, "SoftwareMicrosoftWindowsCurrentVersionRun", lRegKey) = 0 Then

If RegSetValueEx(lRegKey, "My Program", 0, 1, ByVal sApp, Len(sApp)) Then

MsgBox "There was a Problem Adding This Program to the Registry", vbExclamation, "Error"

End If

Call RegCloseKey(lRegKey)

End If

End Sub

الطريقة الثانية

Set iii= CreateObject("wscript.shell")

'للكتابة

iii.regwrite " HKEY_CURRENT_USERSoftwareMicrosoftWindowsCurre

ntVersionRuncode4arab", "c:file name"

'اما للقراءه

iii.regread " HKEY_CURRENT_USERSoftwareMicrosoftWindowsCurre

ntVersionRuncode4arab", "c:file name"

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

فتح ملف نصي ووضعة في أداة نص

Open "c:windowsdesktopbooks.txt" For Input As #1

Text1.Text = Input(LOF(1), 1)

Close #1

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

إغلاق الفورم بشكل تدرجي

Sub SlideWindow(frmSlide As Form, iSpeed As Integer)

While frmSlide.Left + frmSlide.Width < Screen.Width

DoEvents

frmSlide.Left = frmSlide.Left + 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, 250)

End Sub

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

هل تريد إخفاء برنامجك من قائمة Ctrl+Alt+Del

Private Const RSP_SIMPLE_SERVICE = 1

Private Const RSP_UNREGISTER_SERVICE = 0

Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long

Private Declare Function RegisterServiceProcess Lib "kernel32" _

(ByVal dwProcessID As Long, ByVal dwType As Long) As Long

Sub HideApp(Hide As Boolean)

Dim ProcessID As Long

ProcessID = GetCurrentProcessId()

If Hide Then

retval = RegisterServiceProcess(ProcessID, RSP_SIMPLE_SERVICE)

Else

retval = RegisterServiceProcess(ProcessID, RSP_UNREGISTER_SERVICE)

End If

End Sub

Private Sub Form_Load()

HideApp (True)

End Sub

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

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

Public Function GetWordCount(ByVal Text As String) As Long

Text = Trim(Replace(Text, "-" & vbNewLine, ""))

'Replace new lines with a single space

Text = Trim(Replace(Text, vbNewLine, " "))

'Collapse multiple spaces into one single space

Do While Text Like "* *"

Text = Replace(Text, " ", " ")

Loop

'Split the string and return counted words

GetWordCount = 1 + UBound(Split(Text, " "))

End Function

وتستخدم

lLineCount = GetWordCount(Text1.Text)

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

عرض فورم داخل فورم

أضف نموذجين Form1 , Form2

Private Declare Function SetParent Lib "user32" _

(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Private Sub Form_Load()

SetParent Form1.hwnd, Form2.hwnd

Form2.Show

End Sub

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

النسخ من و الى الحافظه

من التكست

Clipboard.Clear

Clipboard.SetText txtBox.Text, vbCFText

الى التكست

txtBox.SelText = Clipboard.GetText

txtBox.Text = Clipboard.GetText

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

لإضهار الوقت والتاريخ

Private Sub Form_Load()

Label1.Caption = Time 'الوقت

Label2.Caption = Date 'التاريخ

End Sub

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

لمسح ما يتواجد في تكست

Private Sub Form_Load()

Text1.Text = ""

End Sub

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

لإستبدال نص بأخر

ندرج Text4

ثم نعدل على text 1 ب

Multiline=true

Scrollbars=2-vertical

الاكواد

Dim StartPoint As Long

Private Sub Command1_Click()

Dim Position As Long

StartPoint = 1

Position = InStr(StartPoint, Text1.Text, Text2.Text)

If Position > 0 Then

Command2.Enabled = True

StartPoint = Position + 1

Text1.SelStart = Position - 1

Text1.SelLength = Len(Text2.Text)

Text1.SetFocus

Else

Command2.Enabled = False

MsgBox "انتهت عملية البحث الأن ولم يتم العثور عن المطلوب", , " بحث"

End If

End Sub

Private Sub Command2_Click()

Dim Position As Long

Position = InStr(StartPoint, Text1.Text, Text2.Text)

If Position > 0 Then

StartPoint = Position + 1

Text1.SelStart = Position - 1

Text1.SelLength = Len(Text2.Text)

Text1.SetFocus

Else

Command2.Enabled = False

MsgBox "انتهت عملية البحث الأن ولم يتم العثور عن المطلوب", , " بحث"

End If

End Sub

Private Sub Command3_Click()

Text1.Text = Replace(Text1.Text, Text3.Text, Text4.Text)

End Sub

Private Sub Form_Load()

End Sub

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

نسخ و تغيير اسم ملف

FileCopy "C:\MyFile.EXT" As "C:\MyFile2.EXT"

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

حذف ملف

Kill "D:\MyFile.EXT"

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

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

Kill "*.TMP"

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

تحميل محتويات ملف نصي في text

Open "c:\windows\desktop\books.txt" For Input As #1

Text1.Text = Input(LOF(1), 1)

Close #1

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

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

Private Type SECURITY_ATTRIBUTES

nLength As Long

lpSecurityDescriptor 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.lpSecurityDescriptor = 0 'normal level of security

attr.bInheritHandle = 1 'default setting

' Create directory.

rval = CreateDirectory(Text1.Text, attr)

End Sub

Private Sub Form_Load()

Text1.Text = "c:\Abdu"

Command1.Caption = "New Directory"

End Sub

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

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

Ctrl + ALt + Delete

Private Sub Form_Load()

App.TaskVisible = False

End Sub

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

لنقل ملف من مسار إلى مسار آخر

Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

Private Sub Command1_Click()

MoveFile "c:\Windows\Desktop\a.txt", "c:\a.txt"

End Sub

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

وضع محتويات ملف في ليست

Private Sub Command1_Click()

Dim StringHold As String

Open "C:\test.txt" For Input As #1

List1.Clear

While Not EOF(1)

Input #1, StringHold

List1.AddItem StringHold

Wend

Close #1

End Sub

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

معرفة اذا تم تغيير محتويات textbox

Private bChanged As Boolean

Private Sub Text1_Change()

bChanged = True

End SubPrivate

Sub Form_Unload(Cancel As Boolean)

If bChanged Then

If Msgbox("Save Changes?", vbYesNo, "Save") = vbYes Then

'Save Changes Here.

End If

End Sub

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

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

Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

Private Type SECURITY_ATTRIBUTES

nLength As Long

lpSecurityDescriptor As Long

bInheritHandle As Long

End Type

Private Sub Command1_Click()

Dim Security As SECURITY_ATTRIBUTES

Ret& = CreateDirectory("C:\Directory", Security)

If Ret& = 0 Then MsgBox "Error : Couldn't create directory !", vbCritical + vbOKOnly

End Sub

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

انشاء مسار

Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long

Private Sub Form_Load()

SHCreateDirectoryEx Me.hwnd, "c:\test\dir\hello\something\apiguide\", ByVal 0&

End Sub

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

نسخ ملف

FileCopy "C:\WINDOWS\Temp\mitanya.swf", "c:\mitanya.swf"

طبع الصورة

Printer.Print Text1.Text

فتح اي ملف

Shell ""

هذا الكود يمكنك من عمل ذلك ( كلمة السر هي فلسطين )

[a = InputBox("إدخل الرقم السري", "الرقم السري")

If a = "فلسطين" Then '

MsgBox "كلمة السر صحيحة"

Else

MsgBox "كلمة السر خاطئة"

End

لتغيير لون الخط في التكست بوكس ما عليك إلا كتابة الكود

Text1.ForeColor = Color

يقوم بتحويل شكل التكست واليبل الى 3d

*كود برمجي*

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

'Set form's AutoRedraw property toTrue

Sub PaintControl3D(frm As Form, Ctl As Control)

' This Sub draws lines around controls to make them 3d

' darkgrey, upper - horizontal

frm.Line (Ctl.Left, Ctl.Top - 15)-(Ctl.Left + _

Ctl.Width, Ctl.Top - 15), &H808080, BF

' darkgrey, left - vertical

frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _

Ctl.Top + Ctl.Height), &H808080, BF

' white, right - vertical

frm.Line (Ctl.Left + Ctl.Width, Ctl.Top)- _

(Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF

' white, lower - horizontal

frm.Line (Ctl.Left, Ctl.Top + Ctl.Height)- _

(Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF

End Sub

Sub PaintForm3D(frm As Form)

' This Sub draws lines around the Form to make it 3d

' white, upper - horizontal

frm.Line (0, 0)-(frm.ScaleWidth, 0), &HFFFFFF, BF

' white, left - vertical

frm.Line (0, 0)-(0, frm.ScaleHeight), &HFFFFFF, BF

' darkgrey, right - vertical

frm.Line (frm.ScaleWidth - 15, 0)-(frm.ScaleWidth - 15, _

frm.Height), &H808080, BF

' darkgrey, lower - horizontal

frm.Line (0, frm.ScaleHeight - 15)-(frm.ScaleWidth, _

frm.ScaleHeight - 15), &H808080, BF

End Sub

'DEMO USAGE

'Add 1 label and 1 textbox

Private Sub Form_Load()

Me.AutoRedraw = True

PaintForm3D Me

PaintControl3D Me, Label1 'Label1 is name of label

PaintControl3D Me, Text1 'Text1 is name of textbox

End Sub

ملاحظة في البداية لبد من انشاء تكست وليبل

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

*كود برمجي*

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

Private Sub Command1_Click()

MM.HWNDDISPLAY=PICTURE1.HWND

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

تحويل اي حرف إلى حرف ASCII

*كود برمجي*

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

Dim temp as String

temp=asc(text1.text)

MsgBox temp

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

نسخ خلفية

Private Declare Function PaintDesktop Lib "user32" _

(ByVal hdc As Long) As Long

'انسخ هذ الكودالى حدث النقر في زر الامر

Private Sub Command1_Click()

PaintDesktop Form1.hdc

End Sub

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

استعراض صورة

On Error Resume Next

OpenFileDialog1.Filter = "Png File|*.png|Gif File|*.gif|Jpg File|*.jpg|Bmp File|*.bmp|All File|*.*"

OpenFileDialog1.Title = "استعراض صورة"

OpenFileDialog1.ShowDialog()

PictureBox1.Load(OpenFileDialog1.FileName)

استعراض فيديو

OpenFileDialog1.Showdialog

AxWindowsMediaPlayer1.URL = OpenFileDialog1.FileName

كود اللون

'display color dialog

ColorDialog1.ShowDialog()

'set the form's background color

Me.BackColor = ColorDialog1.Color

كود الخروج

End

الطريق لصنع برنامج الالوان

اولا اضافة ادة ColorDialog1

تانيا اضافة (2) Button

ثالثاا اضافة Label1

انتها الشرح

textBox1.text="اكتب هنا ما تريد"

الجمع

TextBox3.Text = Val(TextBox1.Text) + Val(TextBox2.Text)

الطرح

TextBox3.Text = Val(TextBox1.Text) - Val(TextBox2.Text)

القسمة

Text3Box.Text = Val(TextBox1.Text) / Val(TextBox2.Text)

الضرب

TextBox3.Text = Val(TextBox1.Text) * Val(TextBox2.Text)

اكواد المتصفح

للذهاب الى الموقع :

WebBrowser1.Navigate(TextBox1.Text)

للرجوع للصفحة السابقة :

WebBrowser1.GoBack()

للتقدم الى الصفحة التي رجعت عنها :

WebBrowser1.GoForward()

تحديث الصفحة :

WebBrowser1.Refresh()

حفظ الصورة

Dim xsave As New SaveFileDialog

xsave.Filter = "BMP Picture--*.bmp--PNG Picture--*.png--JPEG Picture--*.jpg"

xsave.title = "حفظ صورة"

xsave.showDialog

If xsave.FileName = nothing Then Exit Sub

PictureBox1.Image.Save(xsave.FileName)

كود لتحويل ألوان الصور إلى الرمادي

أضف زر كوماند ومربع صورة واكتب في الكوماند الكود التالي

كود:

Picture1.ScaleMode = vbPixels

x = Picture1.ScaleWidth

y = Picture1.ScaleHeight

For i = 0 To y - 1

For j = 0 To x - 1

pixel = Picture1.Point(j, i)

red = pixel Mod 256

green = ((pixel And &HFF00) / 256) Mod 256

blue = (pixel And &HFF0000) / 65536

g = ((red * 30) + (green * 60) + (blue * 20)) / 100

Picture1.PSet (j, i), RGB(g, g, g)

Picture1.ScaleMode = vbTwips

هذا الكود يحول الحروف الإنجليزية لإحرف كبيرة

كود:

Private Sub Text1_KeyPress(KeyAscii As Integer)

KeyAscii = Asc(UCase(Chr$(KeyAscii)))

End Sub

تغيير الصورة من ملونة الى متدرجة باللون الرمادي

Private Sub Command1_Click()

Picture1.ScaleMode = vbPixels

x = Picture1.ScaleWidth

y = Picture1.ScaleHeight

For i = 0 To y - 1

For j = 0 To x - 1

pixel = Picture1.Point(j, i(

red = pixel Mod 256

green = ((pixel And &HFF00) / 256) Mod 256

blue = (pixel And &HFF0000) / 65536

g = ((red * 30) + (green * 60) + (blue * 20)) /

100

Picture1.PSet (j, i), RGB(g, g, g(

Dim SecForm As New Form2

SecForm.ShowDialog()

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

Dim ThirdForm As New Form3

ThirdForm.ShowDialog()

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

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

المصدر :- انوار للتعليم
http://mnef.7olm.org/t2-topic

بقلم محمد الركابي

أنا محمد من العراق، التكنلوجيا هوايتي واحب أن أضع كل ما أعرف من معلومات حول الحاسوب ولاأبخل به عليكم، وخطرت لي فكرة عمل مدونة تضم كل المجالات التعليمية للكومبيوتر التي أستطيع إفادتكم بها، فأرجوا ان لاتبخلوا علي أيضا بمتابعتكم لمواضيعي كما ان تعليقاتكم تهمني وتزيد من عطائي لكم إخوتي الكرام وأي استفسار ان موجود وشكرا

قسم : العاب و برامج,فوتوشوب,فيجوال بيسك

بحث هذه المدونة الإلكترونية

الأربعاء، 14 أكتوبر 2015

اكواد مهمه للفيجوال بيسك (ماعليك سوى النسخ)

بقلم محمد الركابي

0 التعليقات:

إضغط هنا لإضافة تعليق

إرسال تعليق

المواضيع الشائعة

التسميات

أرشيف المدونة الإلكترونية

الوقت الان...

اطعم السمك

ترجمة | Translated

أقسام المدونة

جميع الحقوق محفوظة لدى مدونة مدرسة الابداع.