اكواد فيجوال بيسك 6
اكواد رياضيات
كود ايجاد مربع عدد ما
Dim a
A = val(text1.text)
Text2.text = a*a
كود ايجاد مساحة المستطيل والمربع
Dim a,b
A = val (text1.text)
B = val (text2.text)
Text3.text = a*b
كود الة حاسبة
Dim A,B
A=Val(Text1.text)
B=Val(Text2.text)
If Option1.Value=True Then
Text3.Text=A + B
End if
If Option2.Value=True Then
Text3.Text=A - B
End if
If Option3.Value=True Then
Text3.Text=A * B
End if
If Option4.Value=True Then
Text3.Text=A / B
End if
اكواد الكتابة والصور
كود جعل الصورة تتحرك باسهم الكيبورد
If KeyCode = vbKeyUp Then
Image1.Top = Image1.Top - 10
End If
If KeyCode = vbKeyDown Then
Image1.Top = Image1.Top + 10
End If
If KeyCode = vbKeyRight Then
Image1.Left = Image1.Left + 10
End If
If KeyCode = vbKeyLeft Then
Image1.Left = Image1.Left - 10
End If
كود لتصحيح الاخطاء الكتابية
ملاحظة يجب ان تملك معالج نصوص
Private Sub Command1_Click()
Dim objWord
Dim tmpObjWord
Dim strResults
' Only continue if user has typed text into the text box.
If Len(Text1.Text) < 1 Then Exit Sub
Set tmpObjWord = CreateObject("Word.Application")
' check if there are any spelling errors.
If tmpObjWord.CheckSpelling(Text1.Text) Then
MsgBox "The text spelled correctly"
' free memory
Set tmpObjWord = Nothing
' exit sub - No spelling errors are found.
Exit Sub
End If
'free memory
Set tmpObjWord = Nothing
Set objWord = CreateObject("Word.Application")
With objWord
' hide the Word application
.Visible = False
' Spell checker only works within a document
.Documents.Add
' Put the text in the document
.Selection.TypeText Text1.Text
' disallow grammer checking. To allow it set it to "True"
.Options.CheckGrammarWithSpelling = False
.Options.IgnoreUppercase = False
' Perform the spell checking
.ActiveDocument.CheckSpelling
' Select the new, corrected text
.Selection.WholeStory
' Copy Corrected text to Clipboard
.Selection.Copy
' strResults holds the text after the spell corrections
strResults = .Selection.Text
' close and free memory
.ActiveDocument.Close (0)
.Quit
End With
Set objWord = Nothing
' retrieve the corrected text from the clipboard
Text1.Text = Clipboard.GetText
End Sub
انشاء ملف وورد من برنامج
Private Sub Command1_Click()
Dim objWord As New Word.Application
'-- Show Microsoft Word
' if you want to hide it, replace
' the "True" below with "False"
objWord.Visible = True
'-- Add new Document
objWord.Documents.Add
'-- Add text to Document
objWord.Selection.TypeText "This is the text VB-Town.com"
'-- Select all Text
objWord.Selection.WholeStory
'-- Change Font Size
objWord.Selection.Font.Size = 50
'-- uncomment the following line to change the font color
'objWord.Selection.Font.Color = wdColorRed
'-- uncomment the following line if you want
'-- to prompt the user to save the document
' objWord.Documents.Save
'-- uncomment the following line if you want to
'-- print the document
'objWord.PrintOut
Set objWord = Nothing
End Sub
طباعة صورة
Private Sub Command1_Click()
' replace all "Picture1" below with name of the Picture Box or
' other control that you want to print its picture.
' replace the "0, 0" below with the coordinates of the picture
' on the printed paper. "0, 0" will print the picture in the
' upper left corner. If you want to print the picture where
' the printer's head is currently found, instead of "0, 0"
' use "Printer.CurrentX, Printer.CurrentY" (if you printed text
' and then you'll print the picture with the
' "Printer.CurrentX, Printer.CurrentY" coordinates, the picture
' will be printed immediately after the text).
' If you want to enlarge or to reduce the size of the picture,
' replace the "Picture1.Width, Picture1.Height" with your
' desirable picture width and height.
' for example: "Picture1.Width * 2, Picture1.Height * 2"
' will print the picture in double size, and:
' "Picture1.Width * 0.5, Picture1.Height * 0.5"
' will print the picture in half size.
Printer.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height
' use the EndDoc command if the picture is the last item you want
' to print on the paper
Printer.EndDoc
End Sub
طباعة نص
Private Sub Command1_Click()
' the following example will print hello on the form
Printer.Print "hello"
' use the EndDoc command if this text is the last thing you want
' to print on the paper
Printer.EndDoc
End Sub
البحث في النص
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
اكواد عامة
كود ترجمة النجوم الى حروف
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 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 Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4
Private Declare Function ExitWindowsEx Lib "user32" _
(ByVal uFlags As Long, ByVal dwReserved _
As Long) As Long
Private Sub Form_Load()
t& = ExitWindowsEx(EWX_FORCE Or EWX_REBOOT, 0)
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
Private Sub StopMIDI(MidiFileName As String)
Call mciSendString("stop " + MidiFileName, 0&, 0, 0)
Call mciSendString("close " + MidiFileName, 0&, 0, 0)
End Sub
Private Function PlayMIDI(MidiFileName As String)
On Error Resume Next
Call mciSendString("open " + MidiFileName + " type sequencer", 0&, 0, 0)
If mciSendString("play " + MidiFileName + Flags, 0&, 0, 0) = 0 Then
PlayMIDI = 0
Else
PlayMIDI = 1
End If
End Function
Private Sub Command1_Click()
'Replace c:\mydir\song1.mid with the Midi file name you want to play
PlayMIDI ("c:\mydir\song1.mid")
End Sub
Private Sub Command2_Click()
'Replace c:\mydir\song1.mid with the Midi file name you want to stop
StopMIDI ("c:\mydir\song1.mid")
End Sub
تشغيل ملف فيديو
Private Sub Command1_Click()
Dim returnstring As String
Dim FileName As String
returnstring = Space(127)
'Replace c:\MyMovie.avi with the AVI file you want to play
FileName = "c:\MyMovie.avi"
erg = mciSendString("open " & Chr$(34) & FileName & _
Chr$(34) & " type avivideo alias video", returnstring, 127, 0)
erg = mciSendString("set video time format ms", returnstring, 127, 0)
erg = mciSendString("play video from 0", returnstring, 127, 0)
End Sub
Private Sub Command2_Click()
erg = mciSendString("close video", returnstring, 127, 0)
--------------------------------------------------
(مشرف)
موضوع: اكواد الفيجوال بيسك 6 
