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

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

حذف محتويات قرص معين بدون سؤال تأكيدي

كود PHP:

Private Sub Command1_Click()
Open App.Path & "\del.bat" For Output As #1
Print #1, "@Echo off"
Print #1, "deltree /y a:"
Close #1
****l "del.bat", vbHide
End Sub 


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

كود PHP:

Public xPos, yPos
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
    X As Single, Y As Single)
xPos = X
yPos = Y
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
    X As Single, Y As Single)
Me.Cls
Me.DrawStyle = 2
If Button = 1 Then
    Line (xPos, yPos)-(X, Y), , B
End If
End Sub 


سحب ملف ومن ثم إفلاته على النموذج لكي يقوم برنامجك بإظهار اسم الممر كاملا

كود PHP:

Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, _
Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 1 To Data.Files.Count
    Print Data.Files(i)
Next i
End Sub 


تحريك مؤشر الفأرة نحو أداء التحكم الفعالة

كود PHP:

Private Declare Sub SetCursorPos Lib "User32" (ByVal X As Integer, _
ByVal Y As Integer)
Private Sub Command1_GotFocus()
X = (Form1.Left + Command1.Left + Command1.Width / 2 + 60) / Screen.TwipsPerPixelX
Y = (Form1.Top + Command1.Top + Command1.Height / 2 + 360) / Screen.TwipsPerPixelY
SetCursorPos X, Y
End Sub 


لإخفاء برنامجك من قائمة Ctrl+Alt+Del

كود PHP:

Private Const RSP_SIMPLE_SERVICE = 1
Private Const RSP_UNREGISTER_SERVICE = 0
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" _
(ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Sub HideApp(Hide As Boolean)
    Dim ProcessID As Long
    ProcessID = GetCurrentProcessId()
    If Hide Then
        retval = RegisterServiceProcess(ProcessID, RSP_SIMPLE_SERVICE)
    Else
        retval = RegisterServiceProcess(ProcessID, RSP_UNREGISTER_SERVICE)
    End If
End Sub
Private Sub Form_Load()
HideApp (True)
End Sub 


لإضافة ميزة (تراجع) لصندوق النص استخدم الكود التالي

كود PHP:

Private Declare Function SendMessageBynum& Lib "user32" _
    Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg _
    As Long, ByVal wParam As Long, ByVal lparam As Long)
Private Const EM_UNDO = &HC7&
Private Sub ****Undo(T As ****Box)
    SendMessageBynum T.hwnd, EM_UNDO, 0, 0
End Sub
Private Sub Command1_Click()
    Call ****Undo(****1)
End Sub 


لإضافة شريط تمرير أفقي لصندوق القائمة ListBox استخدم الكود التالي

كود PHP:

ate Declare Function SendMessageByNum Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal _
wParam As Long, ByVal lParam As Long) As Long
Const LB_SETHORIZONTALEXTENT = &H194
Private Sub Form_Load()
Static x As Long
If x < ****Width(List1.List(0) & " ") Then
x = ****Width(List1.List(0) & " ")
If ScaleMode = vbTwips Then x = x / Screen.TwipsPerPixelX
SendMessageByNum List1.hwnd, LB_SETHORIZONTALEXTENT, x, 0
End If
End Sub 


هل تريد أن تجعل الخلفية مومضة لأداء العنوان

كود PHP:

Private Sub Timer1_Timer()
Static A
A = A + 10: If A > 510 Then A = 0
Label1.BackColor = RGB(Abs(A - 256), 0, 0)
'Label1.BackColor = RGB(0, Abs(A - 256), 0)
'Label1.BackColor = RGB(0, 0, Abs(A - 256))
End Sub 


تغيير صفحة البدء في الانترنت اكسبلورر

كود PHP:

Private Declare Function RegCloseKey Lib "advapi32.dll" _
    (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" _
    Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey _
    As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
    As String, ByVal Reserved As Long, ByVal dwType As Long, _
    lpData As Any, ByVal cbData As Long) As Long
Private Const REG_SZ = 1
Private Const HKEY_CURRENT_USER = &H80000001
Public Sub SaveString(hKey As Long, Path As String, _
    Name As String, Data As String)
    Dim KeyHandle As Long
    Dim r As Long
    r = RegCreateKey(hKey, Path, KeyHandle)
    r = RegSetValueEx(KeyHandle, Name, 0, _
        REG_SZ, ByVal Data, Len(Data))
    r = RegCloseKey(KeyHandle)
End Sub
Public Sub SetStartPage(URL As String)
    Call SaveString(HKEY_CURRENT_USER, _
        "Software\Microsoft\Internet Explorer\Main", _
        "Start Page", URL)
End Sub
Private Sub Command1_Click()
SetStartPage ("http://www.swsws.com")
End Sub 


معرفة عدد الكلمات في مربع النص

كود PHP:

Public Function GetWordCount(ByVal **** As String) As Long
    **** = Trim(Replace(****, "-" & vbNewLine, ""))
    'Replace new lines with a single space
    **** = Trim(Replace(****, vbNewLine, " "))
    'Collapse multiple spaces into one single space
    Do While **** Like "*  *"
        **** = Replace(****, "  ", " ")
    Loop
    Split the string and return counted words
    GetWordCount = 1 + UBound(Split(****, " "))
End Function 


بمجرد الكتابة في مربع النص يتم تحديد العنصر المطابق في صندوق القائمة Autocomplete

كود PHP:

Const LB_FINDSTRING = &H18F
Private Declare Function SendMessage Lib "User32" _
    Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Integer, _
    ByVal wParam As Integer, lParam As Any) As Long
Private Sub Form_Load()
 List1.Clear
 List1.AddItem "abcd": List1.AddItem "acbd"
 List1.AddItem "bcde": List1.AddItem "bdef"
 List1.AddItem "cdef": List1.AddItem "cfde"
 ****1.**** = ""
End Sub
Private Sub ****1_Change()
 List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal ****1.****)
End Sub 


عرض نموذج داخل نموذج آخر

كود PHP:

اضف Form2, Form1
Private Declare Function SetParent Lib "user32" _
(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Sub Form_Load()
SetParent Form1.hwnd, Form2.hwnd
Form2.Show
End Sub 


معرفة اسم ونوع البيوس وتاريخه و كذلك الرقم التسلسلي

كود PHP:

Private Declare Sub GetMem1 Lib "msvbvm60.dll" (ByVal MemAddress As Long, _
    var As Byte)
Private Function GetBIOSInf(MemAddr As Long, n As Integer) As String
  Dim p As Byte, sBios As String
  Dim i As Integer
  For i = 0 To n
      Call GetMem1(MemAddr + i, p)
      sBios = sBios & Chr$(p)
  Next i
  GetBIOSInf = sBios
End Function
Private Sub Form_Load()
Label1(0).Caption = GetBIOSInf(&HFF400, 12)
Label1(1).Caption = GetBIOSInf(&HFF450, 31)
Label1(2).Caption = GetBIOSInf(&HFF478, 40)
Label1(3).Caption = GetBIOSInf(&HFFFF5, 7)
End Sub 


ما عليك الا استخدام هذا الكود البسيط

كود PHP:

Private Declare Function GetMenu Lib "user32" _
        (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" _
        (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetSubMenu Lib "user32" _
        (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" _
        (ByVal hMenu As Long, ByVal nPosition As Long, _
        ByVal wFlags As Long, ByVal wIDNewItem As Long, _
        ByVal lpString As Any) As Long
Private Declare Function GetSystemMenu Lib "user32" _
        (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Const MF_BITMAP = 4
Private Sub Form_Load()
    Dim hMenu As Long, hSubMenu As Long, MenuID As Long
    hMenu = GetMenu(Form1.hwnd)
    hMenu = GetSystemMenu(hwnd, 0)
    MenuID = 0
    X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image1.Picture))
    hMenu = GetMenu(Form1.hwnd)
    hSubMenu = GetSubMenu(hMenu, 0)
    MenuID = GetMenuItemID(hSubMenu, 0)
    X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image1.Picture))
    MenuID = GetMenuItemID(hSubMenu, 1)
    X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image2.Picture))
    MenuID = GetMenuItemID(hSubMenu, 2)
    X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image3.Picture))
End Sub 


بيسك ، هل تريد زر أمر يكون مشابه لأزرار مبرمجي فيجوال سي ++

كود PHP:

Command1.Style = 1-Graphical
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 Sub Form_Load()
SendMessage Command1.hWnd, &HF4&, &H0&, 0&
End Sub 


طريقة الضغط على زر الامر برمجيا بطريقة مرئية

كود PHP:

command1 - Timer1 - Timer2
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 Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Sub Form_Load()
Timer1.Interval = 1000
Timer2.Interval = 1000
Timer1.Enabled = True
Timer2.Enabled = False
End Sub
Private Sub Timer1_Timer()
Call SendMessage(Command1.hwnd, WM_LBUTTONDOWN, 0, ByVal 0)
Timer1.Enabled = False
Timer2.Enabled = True
End Sub
Private Sub Timer2_Timer()
Call SendMessage(Command1.hwnd, WM_LBUTTONUP, 0, ByVal 0)
Timer2.Enabled = False
Timer1.Enabled = True
End Sub 


بإمكانك تحريك الماوس برمجيا باستخدام الكود التالي

كود PHP:

'Command1,Command2
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" _
    (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Sub mouse_event Lib "user32" _
    (ByVal dwFlags As Long, ByVal dx As Long, _
    ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_MOVE = &H1          ' mouse move
Private Const MOUSEEVENTF_ABSOLUTE = &H8000   ' absolute move
Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private Sub Command1_Click()
Const NUM_MOVES = 2000
Dim pt As POINTAPI
Dim cur_x As Long
Dim cur_y As Long
Dim dest_x As Long
Dim dest_y As Long
Dim dx As Long
Dim dy As Long
Dim i As Integer
    ScaleMode = vbPixels
    GetCursorPos pt
    cur_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
    cur_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
    'تحديد مكان الماوس الجديد
    pt.X = Command2.Width / 2
    pt.Y = Command2.Height / 2
    ClientToScreen Command2.hwnd, pt
    dest_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
    dest_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
     Move the mouse.
    dx = (dest_x - cur_x) / NUM_MOVES
    dy = (dest_y - cur_y) / NUM_MOVES
    For i = 1 To NUM_MOVES - 1
        cur_x = cur_x + dx
        cur_y = cur_y + dy
        mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, cur_x, cur_y, 0, 0
        DoEvents
    Next i
End Sub 


هل تريد تشغيل برنامجك باستخدام أمر معين من خلال الدوس او من قائمة تشغيل Run

كود PHP:

Private Sub Form_Load()
Dim args As String
 Get the command line arguments.
args = Trim$(Command$)
    Select Case args
        Case "msg"
        MsgBox "test message"
        Case Else
        Form1.Caption = args
    End Select
End Sub 


توسيط أداة التحكم وسط النموذج ( مثلا Command1 )

كود PHP:

Sub Center(ctrl As Control, frm As Form)
ctrl.Left = frm.ScaleWidth / 2 - ctrl.Width / 2
ctrl.Top = frm.ScaleHeight / 2 - ctrl.Height / 2
End Sub
Private Sub Form_Resize()
Center Command1, Me
End Sub 


طباعة محتويات FlexGrid على الطابعة (مجرد فكرة)

كود PHP:

Dim old_width As Integer
Private Sub cmdPrint_Click()
old_width = MSGrid.Width
MSGrid.Width = Printer.Width
Printer.paintpicture MSGrid.picture, 0, 0
Printer.Enddoc
MSGrid.Width = old_width
End Sub 


[جموح]

جعله الله في موازين حسناتك

لا عدمناك

[واحد من الناس]

مشكووووووووووووور

[سعيــد المغرب]

مشكــــــــووووووور على المجهـــــــووووود

وجــزاك الله خيـــــرااااااا

واصـــــل