أكواد فجول بيسك7

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

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
End if
End sub
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
هذه دالة تفيد في الرسم مستطيل له حواف دائرية"

Command1_Click()
Dim i As Single
Dim a As Integer
i = Me.hdc
a = RoundRect(i, 0, 0, 100, 100, 50, 50)
End Sub

Public Declare Function RoundRect Lib "gdi32" Alias "RoundRect" (ByVal hdc As Long, 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 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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
تغيير ارتفاع قائمة مربع السرد Combobox

Private Declare Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, ByVal x As Long, ByVal y As _
Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long

Public Sub SetComboHeight(oComboBox As ComboBox, lNewHeight As Long)
Dim oldscalemode As Integer
If TypeOf oComboBox.Parent Is Frame Then Exit Sub

' Change the ScaleMode on the parent to Pixels.
oldscalemode = oComboBox.Parent.ScaleMode
oComboBox.Parent.ScaleMode = vbPixels

' Resize the combo box window.
MoveWindow oComboBox.hwnd, oComboBox.Left, _
oComboBox.Top, oComboBox.Width, lNewHeight, 1

' Replace the old ScaleMode
oComboBox.Parent.ScaleMode = oldscalemode
End Sub


Private Sub Form_Load()
Call SetComboHeight(Combo1, 400) ' 400 Pixels
End Sub
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
تغيير عرض قائمة مربع السرد Combobox

Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Long) As Long

Private Const CB_SETDROPPEDWIDTH = &H160

Public Sub SetComboWidth(oComboBox As ComboBox, lWidth As Long)
' lWidth is in pixels
SendMessage oComboBox.hwnd, CB_SETDROPPEDWIDTH, lWidth, 0
End Sub

Private Sub Form_Load()
SetComboWidth Combo1, 400
End Sub
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
كيف تقوم بتعيين مفتاح لبرنامجك (Hotkey)

Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Long) As Long

Private Declare Function DefWindowProc Lib "user32" _
Alias "DefWindowProcA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long

Private Const WM_SETHOTKEY = &H32
Private Const WM_SHOWWINDOW = &H18
Private Const HK_SHIFTA = &H141 'Shift + A
Private Const HK_SHIFTB = &H142 'Shift + B
Private Const HK_CONTROLA = &H241 'Control + A
Private Const HK_ALTZ = &H45A ' ALT+Z

Private Sub Form_Load()
Me.WindowState = vbMinimized
' ALT+Z نقوم بتعيين المفتاح
erg& = SendMessage(Me.hwnd, WM_SETHOTKEY, HK_ALTZ, 0)
'يتم التأكد من أن المفتاح الذي تم اختياره غير مستخدم من قبل تطبيق آخر
If erg& <> 1 Then
MsgBox "يجب عليك تعيين مفتاح آخر", vbOKOnly, "Error"
End If
'لإظهار النافذة عند الضغط على المفتاح المعين
DefWindowProc Me.hwnd, WM_SHOWWINDOW, 0, 0
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()

'تعريف المتغيرات
Dim objWord As New Word.Application

'تشغيل مايكروسوفت وورد
objWord.Visible = True

'ينشئ وثيقة جديدة
objWord.Documents.Add

' يضيف النص لوثيقة وورد
objWord.Selection.TypeText "اكتب النص الذي سيضاف لوثيقة مستند وورد"

'يختار كل النص
objWord.Selection.WholeStory

' تغيير حجم الخط
objWord.Selection.Font.Size = 100

' لتغيير لون الخط
objWord.Selection.Font.Color = wdColorRed

' لدفع المستخدم لحفظ الوثيقة
objWord.Documents.Save

'يطبع الوثيقة
objWord.PrintOut

Set objWord = Nothing

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