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

نسخ نص من المفكرة الى البرنامج

'Select Text in txtBox & copy from clipboard

txtBox.SelText = Clipboard.GetText

'Or replace entire text

txtBox.Text = Clipboard.GetText

اضافة ميزة التراجع لمربع نص و ليستا

'Windows API provides an undo function

'Do the following declares:

Declare Function SendMessage Lib "User" (ByVal hWnd As _

Integer, ByVal wMsg As Integer, ByVal wParam As _

Integer, lParam As Any) As Long

Global Const WM_USER = &h400

Global Const EM_UNDO = WM_USER + 23

'And in your Undo Sub do the following:

UndoResult = SendMessage(myControl.hWnd, EM_UNDO, 0, 0)

'UndoResult = -1 indicates an error.

التحويل بين العرض والادخال في مربع نص

1. Put a label on the form called 'lblOVR'

2. Put this code in KeyUp event of Form

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

If KeyCode = vbKeyInsert Then

If lblOVR = "Over" Then

lblOVR = "Insert"

Else

lblOVR = "Over"

End If

End If

End Sub

3. Put this code in KeyPress event of Text Box

Private Sub txtText_KeyPress(KeyAscii As Integer)

'Exit if already selected

If txtText.SelLength > 0 Then Exit Sub

If lblOVR = "Over" Then

If KeyAscii <> 8 And txtText.SelLength = 0 Then

txtText.SelLength = 1 '8=backspace

End If

Else

txtText.SelLength = 0

End If

End Sub

تشغيل ملفات الصوت بدون مشاكل

تحتاج الى عنصر التحكم الخاص بالميديا بلير

Always include the "Close" statement before "Open"

MMControl1.Command = "Close"

MMControl1.Filename = "C:1.mid"

MMControl1.Command = "Open"

MMControl1.Command = "Play"

تغيير مؤشر الماوس

Screen.MousePointer = 0 'Default

Screen.MousePointer = 11 'Hourglass

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

SetAttr "C:data.txt", vbNormal

SetAttr "C:data.txt", vbReadOnly

اضافة بيانات لملف موجود مسبقا

Open "C:data.txt" For output As #1

Do While Not EOF(1)

Print #1, "Overwrite the file!"

Close #1

قراءة ملف حرف بحرف

Do While Not EOF(1)

myChar = Input(1, #1) 'one char a line

WholeWord = WholeWord & myChar

Loop

البحث في ليستا كما تكتبها انت

By changing the SendMessage Function's "ByVal wParam as Long" to

"ByVal wParam as String", we change the search ability from first letter only, to "change-as-we-type" searching.

Here's some example code. Start a new Standard EXE project and add

a ListBox (List1) and a TextBox (Text1), then paste in the following code :

option Explicit

'Start a new Standard-EXE project.

'Add a textbox and a listbox control to form 1

'Add the following code to form1:

private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (byval hWnd as Long, byval wMsg as Integer, byval wParam as string, lParam as Any) as Long

Const LB_FINDSTRING = &H18F

private Sub Form_Load()

With List1

.Clear

.AddItem "RAM"

.AddItem "rams"

.AddItem "RAMBO"

.AddItem "ROM"

.AddItem "Roma"

.AddItem "Rome"

.AddItem "Rommel"

.AddItem "Cache"

.AddItem "Cash"

End With

End Sub

private Sub Text1_Change()

List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, Text1, byval Text1.Text)

End Sub

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

This method is straightforward: it uses SendMessage to retrieve the

number of lines in a textbox. A line to this method is defined as a

new line after a word-wrap; it is independent of the number of hard

returns in the text.

Declarations

Public Declare Function SendMessageLong Lib "user32" Alias

"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long,ByVal

wParam As Long, ByVal lParam As Long) As Long

Public Const EM_GETLINECOUNT = &HBA

The Code

Sub Text1_Change()

Dim lineCount as Long

On Local Error Resume Next

'get/show the number of lines in the edit control

lineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)

Label1 = Format$(lineCount, "##,###")

End Sub

ازالة الصفر من نص

Function KillZeros(incoming as string) as string

KillZeros = CStr(CInt(incoming))

End Function

اضافة سجل الى قاعدة بيانات

Private dbCurrent As Database

Private recCategories As Recordset

Set dbCurrent = OpenDatabase(cFilePathMajor & "Record.mdb", False)

Set recCategories = dbCurrent.OpenRecordset("select * from Record")

With recCategories

.AddNew

!Date = Date

!Time = Time

.Update

End With

recCategories.Close

dbCurrent.Close

Set dbCurrent = Nothing

فتح ملف سطر بعد سطر

Do While Not EOF(1)

Line Input #1, LineHolder

LineHolder = LineHolder + 1

Loop

تظليل النص عند التركيز

Public Sub TextSelected()

Dim tBox As TextBox

Set tBox = Screen.ActiveControl

If TypeOf tBox Is TextBox Then

tBox.SelStart = 0

tBox.SelLength = Len(tBox)

End If

End Sub

عمل اتصال بالانترنت

Dim res

res = Shell("rundll32.exe rnaui.dll,RnaDial " _

& "connection_name", 1)

معرفة اذا كان البرنامج شغال

Put this code in the load event of the first form that the program loads.

If App.PrevInstance = True Then

Call MsgBox("This program is already running!",_

vbExclamation)

End

End If

الحصول على اسم الملف فقط

MsgBox OnlyFileName("c:windowswin.com","") 'gives you 'win.com'

Function OnlyFileName(vPath$, vSlash$) As String

Dim p%

OnlyFileName = vPath

For p% = Len(vPath$) To 0 Step -1

If Mid$(vPath$, p%, 1) = vSlash$ Then

OnlyFileName = Mid$(vPath$, p% + 1, Len(vPath$) - p% + 1)

Exit Function

End If

Next p%

End Function

استخدام الرقم الحر عند فتح وقراءة ملف

Private Sub GetFile(FileName$)

Dim nFilenumber%

Dim tmpLine$

Text1.Text = ""

nFilenumber = FreeFile

Open FileName$ For Input As #nFilenumber

Do While Not EOF(nFileNumber)

Input #nFileNumber, tmpLine

Text1.Text = Text1.Text & tmpline

Loop

Close #nFileNumber

End Sub

كيفية اعادة تشغيل الجهاز

Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long,

ByVal dwReserved As Long) As Boolean

Public Const EWX_FORCE = 4

Public Const EWX_LOGOFF = 0

Public Const EWX_REBOOT = 2

Public Const EWX_SHUTDOWN = 1

...

Dim res As Boolean

res = ExitWindowsEx (EWX_REBOOT, 0)

If Not res Then

MsgBox "Function failed"

Else

MsgBox "Shutting down Windows NOW!"

End

EndIf

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

Dim OldName, NewName

OldName = "OLDFILE": NewName = "NEWFILE" ' Define file names.

Name OldName As NewName ' Rename file.

OldName = "C:MYDIROLDFILE": NewName = "C:YOURDIRNEWFILE"

Name OldName As NewName ' Move and rename file.

كيفية حذف دليل

' Assume that MYDIR is an empty directory or folder.

RmDir "MYDIR" ' Remove MYDIR

اجراء عملية بحث داخل نص

Dim X As Integer

X = FindMatch(Text1.Text, Text2.Text)

If X = 0 Then

MsgBox "Word not found"

Else

MsgBox "Word found"

End If

End Sub

1. Create a new function called FindMatch. Add the following code to

this function:

Function FindMatch(Str1 As String, Str2 As String) As Integer

Dim Match As Integer

Dim Char1 As String

Dim Char2 As String

Match = InStr(Str1, Str2)

If Match <> 0 Then

Char1 = Mid$(Str1, Match - 1, 1)

If Codes(Char1) Then

Char2 = Mid$(Str1, Match + Len(Str2), 1)

If Codes(Char2) Then

FindMatch = True: Exit Function

End If

End If

End If

FindMatch = False

End Function

2. Create a new function called Codes. Add the following code to this

function:

Function Codes(PuncStr As String) As Integer

If PuncStr = "," Or PuncStr = "." Or PuncStr = " " Or _

PuncStr = Chr(10) Or PuncStr = Chr(13) Or PuncStr = Chr(9) Then

Codes = True

Else

Codes = False

End If

End Function

كيف تنشيء شريط تمرير مع نسبة مئوية

Sub Command1_Click ()

picture1.ForeColor = RGB(0, 0, 255) 'use blue bar

For i = 0 To 100 Step 2

updateprogress picture1, i

Next

picture1.Cls 'clear bar at they end

End Sub

Sub updateprogress (pb As Control, ByVal percent)

Dim num$ 'use percent

If Not pb.AutoRedraw Then 'picture in memory ?

pb.AutoRedraw = -1 'no, make one

End If

pb.Cls 'clear picture in memory

pb.ScaleWidth = 100 'new sclaemodus

pb.DrawMode = 10 'not XOR Pen Modus

num$ = Format$(percent, "###") + "%"

pb.CurrentX = 50 - pb.TextWidth(num$) / 2

pb.CurrentY = (pb.ScaleHeight - pb.TextHeight(num$)) / 2

pb.Print num$ 'print percent

pb.Line (0, 0)-(percent, pb.ScaleHeight), , BF

pb.Refresh 'show differents

End Sub

تغيير لون عنوان النموذج

You can globally change any Windows 95 desktop colour using the

SetSysColors function. It takes three parameters : The number

of colour elements to change, The Color object constant that

you want to change and the RGB value.

The Declaration for this API function is:

Declare Function SetSysColors Lib "user32" Alias _

"SetSysColors" (ByVal nChanges As Long, lpSysColor As _

Long, lpColorValues As Long) As Long

The Constants are:

Public Const COLOR_SCROLLBAR = 0 'The Scrollbar colour

Public Const COLOR_BACKGROUND = 1 'Colour of the background with no wallpaper

Public Const COLOR_ACTIVECAPTION = 2 'Caption of Active Window

Public Const COLOR_INACTIVECAPTION = 3 'Caption of Inactive window

Public Const COLOR_MENU = 4 'Menu

Public Const COLOR_WINDOW = 5 'Windows background

Public Const COLOR_WINDOWFRAME = 6 'Window frame

Public Const COLOR_MENUTEXT = 7 'Window Text

Public Const COLOR_WINDOWTEXT = 8 '3D dark shadow (Win95)

Public Const COLOR_CAPTIONTEXT = 9 'Text in window caption

Public Const COLOR_ACTIVEBORDER = 10 'Border of active window

Public Const COLOR_INACTIVEBORDER = 11 'Border of inactive window

Public Const COLOR_APPWORKSPACE = 12 'Background of MDI desktop

Public Const COLOR_HIGHLIGHT = 13 'Selected item background

Public Const COLOR_HIGHLIGHTTEXT = 14 'Selected menu item

Public Const COLOR_BTNFACE = 15 'Button

Public Const COLOR_BTNSHADOW = 16 '3D shading of button

Public Const COLOR_GRAYTEXT = 17 'Grey text, of zero if dithering is used.

Public Const COLOR_BTNTEXT = 18 'Button text

Public Const COLOR_INACTIVECAPTIONTEXT = 19 'Text of inactive window

Public Const COLOR_BTNHIGHLIGHT = 20 '3D highlight of button

To change the colour of the title bar, or caption, of an active

window, you would call the function in this way:

t& = SetSysColors(1, COLOR_ACTIVECAPTION, RGB(255,0,0))

معلومات عن المساحة الحرة على القرص الصلب

Use the function GetDiskFreeSpace. The declaration for this API

function is:

Declare Function GetDiskFreeSpace Lib "kernel32" Alias _

"GetDiskFreeSpaceA" (ByVal lpRootPathName As String, _

lpSectorsPerCluster As Long, lpBytesPerSector As Long, _

lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters _

As Long) As Long

Here is an example of how to find out how much free space a drive has:

Dim SectorsPerCluster&

Dim BytesPerSector&

Dim NumberOfFreeClusters&

Dim TotalNumberOfClusters&

Dim FreeBytes&

dummy& = GetDiskFreeSpace("c:", SectorsPerCluster, _

BytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters)

FreeBytes = NumberOfFreeClusters * SectorsPerCluster * _

BytesPerSector

The Long FreeBytes contains the number of free bytes on the drive.