اكواد فيجوال بيسك 2

[ضمتني الين طاح عقالي]

لمعرفة عدد الاسطر في مربع النص ****Box

كود PHP:

Private 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
Private Const EM_GETLINECOUNT = &HBA
Private Sub Command1_Click()
    Dim lineCount As Long
    On Local Error Resume Next
    lineCount = SendMessageLong(****1.hwnd, EM_GETLINECOUNT, 0&, 0)
    MsgBox Format$(lineCount, "##,###")
End Sub 


لفتح وإغلاق سواقة الأقراص المدمجة

كود PHP:

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
'?E?
Private Sub cmdOpen_Click()
retvalue = mciSendString("set CDAudio door open", _
returnstring, 127, 0)
End Sub
'CU?C?
Private Sub cmdClose_Click()
retvalue = mciSendString("set CDAudio door closed", _
returnstring, 127, 0)
End Sub 


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

كود PHP:

Private Sub Form_Load()
If App.PrevInstance = True Then
    MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
    Unload Me
    Exit Sub
End If
End Sub 


اجعل برنامجك فوق الجميع always on top

كود PHP:

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal X As Long, _
ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, _
ByVal wFlags As Long) As Long
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean)
Dim lR As Long
If bSetOnTop Then
    lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
    lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End If
End Sub

Private Sub Form_Load()
    SetOnTop Form1.hwnd, True
End Sub 


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

كود PHP:

Private Sub Command1_Click()
Dim s
Dim a

s = Val(****1.****)
If s = 1 Or s = 0 Then
Label1.Caption = "عدد غير أولي"
GoTo 20
End If

For i = 2 To (s - 1)

If (s / i) = Int(s / i) Then

a = a + 1

Else
a = a
End If
Next i
If a = 0 Then

Label1.Caption = "عدد أولي"
Else
Label1.Caption = "عدد غير أولي"
End If

20 End Sub

Private Sub ****1_Change()
'هذا الكود يرسل رسالة للمستخدم إذا أدخل غير الارقام
If Not IsNumeric(****1.****) Then
'المفتاح ليس رقم
MsgBox ("أدخل أرقاما فقط")
****1.**** = ""
End If
End Sub 


كود يعمل إذا ضغط على حرف يكتبه

كود PHP:

Private Sub Form_KeyPress(KeyAscii As Integer)
Print Chr$(KeyAscii) & "=" & KeyAscii
End Sub 


تحويل الحروف الإنجليزية لأحرف كبيرة

كود PHP:

Private Sub ****1_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr$(KeyAscii)))
End Sub 


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

كود PHP:

Private Sub ****1_KeyPress(KeyAscii As Integer)
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
     KeyAscii = 0
     End If
End Sub 


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

كود PHP:

Private Sub Form_Load()
   ****1.**** = "Two of the peak human experiences"
   ****1.**** = ****1.**** & " 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 **** to be found:")
   Where = InStr(****1.****, Search)   ' Find string in ****.
   If Where Then   ' If found,
      ****1.SetFocus
      ****1.SelStart = Where - 1   ' set selection start and
      ****1.SelLength = Len(Search)   ' set selection length.
   Else 


هذه دالة تفيد في الرسم مستطيل له حواف دائرية"

كود PHP:

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 


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

كود 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:\my ********s\a.txt", "c:\a.txt"
End Sub 


تغيير ارتفاع قائمة مربع السرد Combobox

كود PHP:

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 ********
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

كود PHP:

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)

كود PHP:

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 


نسخ خلفية سطح المكتب إلى نموذجك

كود PHP:

'انسخ هذ الكودالى قسم التصريحات العامة
Private Declare Function PaintDesktop Lib "user32" _
    (ByVal hdc As Long) As Long

'انسخ هذ الكودالى حدث النقر في زر الامر
Private Sub Command1_Click()
    PaintDesktop Form1.hdc
End Sub 


أنشاء وتنسيق وطبع وثيقة وورد من داخل برنامج بنقرة زر الامر

كود PHP:

Private Sub Command1_Click()

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

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

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

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

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

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

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

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

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

Set objWord = Nothing

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

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 


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

كود PHP:

Dim startdate As String
Dim differenceofdate
Dim TRACEDATE As String
Dim newdate
Dim chk

    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 If
  End If
End Sub 


لتبديل أزرار الفأرة

كود PHP:

Const SPI_SETMOUSEBUTTONSWAP = 33
Const SPIF_UPDATEINIFILE = &H1
Private Declare Function SystemParametersInfo Lib "user32.dll" Alias _
    "SystemParametersInfoA" (ByVal uAction As Long, ByVal uiParam As Long, _
    pvParam As Any, ByVal fWinIni As Long) As Long
Private Sub Form_Load()
SystemParametersInfo SPI_SETMOUSEBUTTONSWAP, 1, 0, SPIF_UPDATEINIFILE
End Sub 


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

كود PHP:

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

Private Sub Form_Load()
Form1.KeyPreview = True
End Sub
 
'KeyPress انسخ هذا الكود لحدث النموذج

Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 27 Then
End
End If
End Sub
 
 
KeyPress بدلاً من كود الحدث  KeyDownويمكن ايضاًوضع الكود التالي في الحدث 

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then End
End Sub 


لاختبار وجود بطاقة إخراج الصوت

كود PHP:

Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
Private Sub Command1_Click()
    Get the number of installed waveout devices
    ret& = waveOutGetNumDevs
    If ret& > 0 Then
        MsgBox "يوجد بطاقة لإخراج الصوت مثبتة على هذا الجهاز"
    Else
        MsgBox "للأسف لايوجد بطاقة لإخراج الصوت على هذا الجهاز"
    End If
End Sub 


[جموح]

الله يعطيك العافية

جوزيت خيرا