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

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

لمعرفة رقم المنفذ الخاص بالمودم بدون تدخل المستخدم وتهيئته لإنتظار مكالمه

كود PHP:

Private Sub Form_Load() 
MSComm1.Settings = "9600,N,8,1" 
 لوب للتشييك على عشرة منافذ وإستخراج رقم منفذ المودوم الصحيح 

For i = 1 To 10 
MSComm1.CommPort = i 

On Error GoTo N 
MSComm1.PortOpen = True 

N: 
If MSComm1.PortOpen = True Then 
Exit For 
End If 

Next 

End Sub 

Private Sub MSComm1_OnComm() 

If MSComm1.CommEvent Then 
MsgBox " وصول إتصال لك " 
End If 


End Sub 


لإخفاء البرنامج من قائمة إنهاء المهام

كود PHP:

'Module File هذا الجزء في ملف برمجي 

Public Declare Function GetCurrentProcessId _ 
Lib "kernel32" () As Long 
Public Declare Function GetCurrentProcess _ 
Lib "kernel32" () As Long 
Public Declare Function RegisterServiceProcess _ 
Lib "kernel32"

Private Sub Command1_Click() 
Dim pid As Long 
Dim reserv As Long 
' لإخفاء البرنامج من قائمة إنهاء المهام 
pid = GetCurrentProcessId() 
regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE) 
End Sub 

Private Sub Command2_Click() 
Dim pid As Long 
Dim reserv As Long 
لإعادة البرنامج في قائمة إنهاء المهام 
pid = GetCurrentProcessId() 
regserv = RegisterServiceProcess(pid, _ 
RSP_UNREGISTER_SERVICE) 
End Sub 


معرفة إذا كان الرقم زوجي أو فردي

كود PHP:

Function isEven(n As Integer) As Boolean
isEven = True
If n And 1 Then isEven = False
End Function
Private Sub Command1_Click()
MsgBox isEven(4)
End Sub 


منع المستخدم من استخدام المسافة في صندوق النص

كود PHP:

Private Sub ****1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 32 Then
        KeyAscii = 0
    End If
End Sub 


اذا اردت تجميد الويندوز
لن تستطيع العمل مرة أخرى الا بإعادة تشغيل الجهاز

كود PHP:

Public Declare Function SetParent Lib "user32" (ByVal _
hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Sub Command1_Click()
SetParent Me, Me
End Sub 


لتشغيل حافظة الشاشة للويندوز

كود PHP:

Private Const WM_SYSCOMMAND = &H112&
Private Const SC_SCREENSAVE = &HF140&
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
لبدء تشغيل حافظة شاشة الويندوز
Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0) 


لتحديد دقة عرض الشاشة

كود PHP:

Private Sub Command1_Click()
Dim intWidth As Integer
Dim intHeight As Integer
intWidth = Screen.Width  Screen.TwipsPerPixelX
intHeight = Screen.Height  Screen.TwipsPerPixelY
MsgBox "Screen Resolution:" + Str$(intWidth) + " x" + Str$(intHeight)
End Sub 


لقراءة سطر معين من ملف

كود PHP:

Public Function readLine(ByRef strFilePath As String, ByRef nLine _
    As Integer) As String
    
    Dim NextLine As String
    Dim n As Integer
    FileNum = FreeFile
    Open strFilePath For Input As FileNum
    Do Until EOF(FileNum)
        Line Input #FileNum, NextLine
        n = n + 1
        If n = nLine Then readLine = NextLine
    Loop
Close
End Function
Private Sub Command1_Click()
'autoexec.bat لقراءة السطر الثالث من الملف
****1.**** = readLine("c:\autoexec.bat", 3)
End Sub

'أضف ****1 و Command1 ثم أضف الكود التالي 


لإضافة الطابعات إلى صندوق القائمة Listbox

كود PHP:

Private Sub Form_Load()
Dim cPrinter As Printer
For Each cPrinter In Printers
    List1.AddItem Printer.DeviceName
Next
End Sub 


تحريك اداة الشكل Shape control بشكل لطيف وعشوائي

كود PHP:

set Timer1.interval=100
Private Sub Timer1_Timer()
Shape1.Move Shape1.Left + ScaleWidth * (Rnd - 0.5) / 50, _
Shape1.Top + ScaleHeight * (Rnd - 0.5) / 50
End Sub 


تغيير الصورة من ملونة الى متدرجة باللون الرمادي

كود PHP:

Private Sub Command1_Click()
Picture1.ScaleMode = vbPixels
x = Picture1.ScaleWidth
y = Picture1.ScaleHeight
For i = 0 To y - 1
    For j = 0 To x - 1
    pixel = Picture1.Point(j, i)
    red = pixel Mod 256
    green = ((pixel And &HFF00) / 256) Mod 256
    blue = (pixel And &HFF0000) / 65536
    g = ((red * 30) + (green * 60) + (blue * 20)) / 100
    Picture1.PSet (j, i), RGB(g, g, g)
    Next
Next 


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

كود PHP:

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
    X As Single, Y As Single)
Me.Cls
Line (X, 0)-(X, Me.ScaleHeight), vbRed
Line (0, Y)-(Me.ScaleWidth, Y), vbGreen
End Sub 


فتح برنامج المفكرة ويكتب جملة نصيه فيه

كود PHP:

Private Sub Command1_Click()
****l "notepad.exe", vbNormalNoFocus
AppActivate ("Untitled - Notepad")
SendKeys ("أهلا بكم في منتديات المبرمج العربي")
End Sub 


رسم دائرة صغيرة حول مؤشر الماوس تتبع حركتها

كود PHP:

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
    X As Single, Y As Single)
Me.Cls
Circle (X, Y), 100, vbRed
End Sub 


غلق الفورم بشكل انزلاق لليمين ثم للأسفل

كود PHP:

Sub SlideWindow(frmSlide As Form, iSpeed As Integer)
While frmSlide.Left + frmSlide.Width < Screen.Width
    DoEvents
    frmSlide.Left = frmSlide.Left + iSpeed
Wend
While frmSlide.Top - frmSlide.Height < Screen.Height
    DoEvents
    frmSlide.Top = frmSlide.Top + iSpeed
Wend
Unload frmSlide
End Sub
Private Sub Command1_Click()
Call SlideWindow(Form1, 250)
End Sub 


قطع الاتصال بالانترنت بمعرفة اسم الاتصال بدون استخدام API

كود PHP:

Private Sub Form_Load()
    Dim sDuName As String
    sDuName = InputBox("أدخل اسم الاتصال")
    If DisconnectDUN(sDuName) = True Then
        MsgBox "تم قطع الاتصال"
    Else
        MsgBox "لا يوجد اتصال بهذا الاسم"
    End If
    End
End Sub
Function DisconnectDUN(DUNName As String) As Boolean
    On Error GoTo errhandler
    AppActivate "Connected to " & DUNName
    SendKeys "c"
    DisconnectDUN = True
errhandler:
End Function 


[جموح]

اخي لعيونها جوزيت خيرا ولا شُلت يمينك