اكواد كثيره للفيجوال بيسك

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

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

Private Sub GradientFill()

Dim i As Long

Dim c As Integer

Dim r As Double

r = ScaleHeight / 3.142

For i = 0 To ScaleHeight

c = Abs(220 * Sin(i / r))

Me.Line (0, i)-(ScaleWidth, i), RGB(c, c, c + 30) 'Notice the bias To blue. You can be more subtle by reducing this number (try 10). Try other colours too.

Next

End Sub

وهذا الكود في حدث Resize للفورم

GradientFill

هذه الدالة لتحميل صفحة من الإنترنت

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Private Sub Command1_Click()

lngRetVal = URLDownloadToFile(0, "http://www.الموقع.com", "c:الموقع.htm", 0, 0)

End Sub

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

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

Private Sub Command1_Click()

MoveFile "c:WindowsDesktopa.txt", "c:a.txt"

End Sub

هذه الدالة تقوم بتعطيل زر إغلاق Close الذي يوجد في كل نافذة

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

Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long

Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Const MF_BYPOSITION = &H400&

Private Sub Form_Load()

Dim a As Long, b As Long

a = GetSystemMenu(Me.hwnd, False)

b = GetMenuItemCount(a)

RemoveMenu a, b - 1, MF_BYPOSITION

DrawMenuBar Me.hwnd

End Sub

هذه الدالة لتغيير ألوان الواجهة للويندوز

Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Const COLOR_ACTIVECAPTION = 2

Private Sub Form_Load()

a = GetSysColor(COLOR_ACTIVECAPTION)

SetSysColors 1, COLOR_ACTIVECAPTION, RGB(255, 200, 140)

MsgBox "The old title bar color was" + Str$(a) + " And is now" + Str$(GetSysColor(COLOR_ACTIVECAPTION))

End Sub

هذه الدالة تعرض مربع حوار تهيئة القرص المرن

Const SHFD_CAPACITY_DEFAULT = 0

Const SHFD_FORMAT_QUICK = 0

Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long

Private Sub Form_Load()

SHFormatDrive Me.hwnd, 0, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK

End Sub

هذا الكود يقوم بإخبارك هب يوجد كرت صوت أم لا أي هل تستطيع تشغيل ملفات الأصوات في جهازك

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

Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long

اضف زر Command وضع فيه الكود التالي

Dim i As Integer

i = waveOutGetNumDevs()

If i > 0 Then

MsgBox "بالإمكان تشغيل ملفات الأصوات في جهازك", _

vbInformation, "التأكد من وجود كرت الصوت"

Else

MsgBox "ليس بالإمكان تشغيل ملفات الأصوات في جهازك", _

vbInformation, "التأكد من وجود كرت الصوت"

End If

هل تريد التعرف على خصائص الطابعة أي هل تريد إظهار نافذة خصائص الطابعة إتبع ما يلي :

إضغط على ctrl+t

إختر من النافذة التي سوف تظهر لك Microsoft Common Dialog وذلك بوضع أمامه صح ثم OK

أضفه في الفورم واكتب الكود التالي في حدث الضغط على زر

Dim BeginPage, EndPage, NumCopies, i

CommonDialog1.CancelError = True

On Error GoTo ErrHandler

CommonDialog1.ShowPrinter

BeginPage = CommonDialog1.FromPage

EndPage = CommonDialog1.ToPage

NumCopies = CommonDialog1.Copies

For i = 1 To NumCopies

Next i

Exit Sub

ErrHandler:

Exit Sub

هذا الكود يقوم بجمع الأرقام الموجود في Text1 و Text2 ويضع الناتج في Label1

Label1.Caption = Val(Text1.Text) + Val(Text2.Text)

وهذا الكود يقوم بطرح ال Text1 من ال Text2 ويضع الناتج في ال Label1

Label1.Caption = Val(Text1.Text) - Val(Text2.Text)

هذا الكود يقوم بضرب Text1 بـ Text2 ويضع الناتج في ال Label1

Label1.Caption = Val(Text1.Text) * Val(Text2.Text)

هذا الكود يقوم بقسمة Text1 على Text2 ويضع الناتج في ال Label1

Label1.Caption = Val(Text1.Text) / Val(Text2.Text)

هذا الكود لمعرفة البارامترات التي يتم تمريرها للبرنامج في سطر الأوامر :

Function GetCommandLine(Optional MaxArgs)

Dim C, CmdLine, CmdLnLen, InArg, I, NumArgs

If IsMissing(MaxArgs) Then

MaxArgs = 10

End If

ReDim ArgArray(MaxArgs)

NumArgs = 0:

InArg = False

CmdLine = Command()

CmdLnLen = Len(CmdLine)

For I = 1 To CmdLnLen

C = Mid(CmdLine, I, 1)

If (C <> " " And C <> vbTab) Then

If Not InArg Then

If NumArgs = MaxArgs Then

Exit For

End If

NumArgs = NumArgs + 1

InArg = True

End If

ArgArray(NumArgs) = ArgArray(NumArgs) & C

Else

InArg = False

End If

Next I

ReDim Preserve ArgArray(NumArgs)

GetCommandLine = ArgArray()

End Function

Private Sub Form_Activate()

Dim I

s = GetCommandLine

For I = 1 To UBound(s)

Print s(I)

Next I

End Sub

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

Private Sub Command1_Click()

Dim StringHold As String

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

List1.Clear

While Not EOF(1)

Input #1, StringHold

List1.AddItem StringHold

Wend

Close #1

End Sub

كيف تعرف اذا تم تغيير محتويات TextBox

Private bChanged As Boolean

Private Sub Text1_Change()

bChanged = True

End SubPrivate

Sub Form_Unload(Cancel As Boolean)

If bChanged Then

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

'Save Changes Here.

End If

End If

End Sub

كيف تصنع قائمة فرعية من خلال زر امر

First, create a menu with the menu editor.

It should look like this:

Button Menu (Menu name: mnuBtn, Visible: False - Unchecked)

....SubMenu Item 1 (Menu name: mnuSub, Index: 0)

....SubMenu Item 2 (Menu name: mnuSub, Index: 1)

....SubMenu Item 3 (Menu name: mnuSub, Index: 2)

....SubMenu Item 4 (Menu name: mnuSub, Index: 3)

I hope you understand the above. Also create a CommandButton.

Then add this code:

Private Sub mnuSub_Click(Index As Integer)

Call MsgBox("Menu sub-item " & Index + 1 & " clicked!", _

vbExclamation)

End Sub

Private Sub Command1_Click()

Call PopupMenu(mnuBtn)

End Sub

P.S. For added effect, replace the line:

Call PopupMenu(mnuBtn)

With this one:

Call PopupMenu(Menu:=mnuBtn, X:=Command1.Left, Y:=Command1.Top + _

Command1.Height) ' Even more viola!

Or this one:

Call PopupMenu(mnuBtn, vbPopupMenuCenterAlign, Command1.Left + _

(Command1.Width / 2), Command1.Top + Command1.Height

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

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

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

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

Otherwise, you'll need to step though the Text yourself

checking for instances of vbCrLf, e.g.

code:

Dim sString As String

Dim sNewString As Strings

String = Text1

While Instr(sString, vbCrLf)

sNewString = sNewString & Left(sString, _

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

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

Wend

Text2 = sNewString

كيفية تشفير نص

Public Function Encrypt(ByVal Plain As String)

For I=1 To Len(Plain)

Letter=Mid(Plain,I,1)

Mid(Plain,I,1)=Chr(Asc(Letter)+1)

Next

Encrypt = Plain

End Sub

Public Function Decrypt(ByVal Encrypted As String)

For I=1 to Len(Encrypted)

Letter=Mid(Encrypted,I,1)

Mid(Encrypted,I,1)=Chr(Asc(Letter)-1)

Next

Decrypt = Encrypted

End Sub

((Print Encrypt("This is just an example")

((Print Decrypt("Uijt!jt!kvtu!bo!fybnqmf")

انشاء قوائم خلال تشغيل البرنامج

Dim index As Integer

index = mnuHook.Count

Load mnuHook(index)

mnuHook(index).Caption = "New Menu Entry"

mnuHook(index).Visible = True

وضع صورة صغيرة في قائمة

'Add a picturebox control.

'Set 'Autosize' to 'True' with a bitmap (not an Icon)

'at a maximum of 13X13.

'Place these Declarations in BAS module

Private Declare Function VarPtr Lib "VB40032.DLL" (variable As Any) As Long

Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long

Const MF_BYPOSITION = &H400&

'Place this code into the form load event:

Dim mHandle As Long, lRet As Long, sHandle As Long, sHandle2 As Long

mHandle = GetMenu(hwnd)

sHandle = GetSubMenu(mHandle, 0)

lRet = SetMenuItemBitmaps(sHandle, 0, MF_BYPOSITION, imOpen.Picture, imOpen.Picture)

lRet = SetMenuItemBitmaps(sHandle, 1, MF_BYPOSITION, imSave.Picture, imSave.Picture)

lRet = SetMenuItemBitmaps(sHandle, 3, MF_BYPOSITION, imPrint.Picture, imPrint.Picture)

lRet = SetMenuItemBitmaps(sHandle, 4, MF_BYPOSITION, imPrintSetup.Picture, imPrintSetup.Picture)

sHandle = GetSubMenu(mHandle, 1)

sHandle2 = GetSubMenu(sHandle, 0)

lRet = SetMenuItemBitmaps(sHandle2, 0, MF_BYPOSITION, imCopy.Picture, imCopy.Picture)

تدوير العدد الى اقرب 100 او 10 او 1000

'Example - round to nearest 100

Round(RatioBolus * Val(txtDW), 100)

'Put this in BAS module

Public Function Round(Dose, Factor)

'Purpose: Round a dose

'Input: Dose, Factor (10, 100, 1000, etc)

'Output: Rounded dose

Dim Temp As Single

Temp = Int(Dose / Factor)

Round = Temp * Factor

End Function

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

'Put this in the click event of a control

Dim iRet As Long

Dim Response As Integer

Response = MsgBox("You have chosen 'www.rxkinetics.com', " & vbCrLf & "which

will launch your web browser and" & vbCrLf & "point you to the Kinetics web _

site." & vbCrLf & vbCrLf & "Do you wish to continue?", vbInformation + _

vbYesNo, "www.rxkinetics.com")

Select Case Response

Case vbYes

iRet = Shell("start.exe http://www.rxkinetics.com/", vbNormal)

Case vbNo

Exit Sub

End Select

اجراء معالجة الاخطاء

'Begin error handle code

On Error GoTo ErrHandler

'Insert code to be checked

'Stop error trapping & exit function

On Error GoTo 0

Exit Function

ErrHandler:

Dim strErr As String

strErr = "Error " & Err.Number & " " & Err.Description

MsgBox strErr, vbCritical + vbOK, "Error message"

التحقق من التاريخ بالسنوات

Public Function ValidDate(MDate)

'Purpose: Check for 4 digit yyyy DATE

'Input: String from text box

'Output: True or False

'Default is false

ValidDate = False

'Exit if length less than "m/d/yyyy"

If Len(MDate) < 8 Then Exit Function

'Exit if not a valid date wrong

If IsDate(MDate) = False Then Exit Function

'Exit if not ending or starting with "yyyy"

Dim StartDate As String

Dim EndDate As String

EndDate = Right(MDate, 4)

StartDate = Left(MDate, 4)

If ValidChar(EndDate, "0123456789") = False And _

ValidChar(StartDate, "0123456789") = False Then Exit Function

'Set to true if it passes all these tests!

ValidDate = True

End Function

حساب العمر بالاعتماد على تاريخ الميلاد

'Convert text to Date

Dim Birth as Date

Birth = DateValue(txtDOB)

'Calculate age

Dim Age as Integer

Age = Int(DateDiff("D", Birth, Now) / 365.25)

كيفية برمجة شريط الادوات ToolBar

Private Sub Toolbar1_ButtonClick(ByVal Button As Button)

'Handle button clicks

Select Case Button.Key

Case Is = "Exit"

'If user clicks the No button, stop Exit

If MsgBox("Do you want to exit?", vbQuestion + vbYesNo + _

vbDefaultButton2, "Exiting Code Bank") = vbNo Then Exit Sub

Call ExitProgram

Case Is = "Repair"

Call Repairdb

Case Is = "Delete"

Call DeleteRoutine

Case Is = "Edit"

Call EditRoutine

Case Is = "New"

Call NewRoutine

Case Is = "Copy"

Call CopyToClipboard

Case Is = "Help"

Call ShowHelpContents

End Select

End Sub

نسخ نص الى الحافظة ClipBoard

'First clear the clipboard

Clipboard.Clear

'Select Text in txtBox & copy to clipboard

Clipboard.SetText txtBox.Text, vbCFText