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

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

نوعية القرص (قرص مرن،سي دي،..

كود PHP:

'Declarations
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
    Public Const DRIVE_CDROM = 5
    Public Const DRIVE_FIXED = 3
    Public Const DRIVE_RAMDISK = 6
    Public Const DRIVE_REMOTE = 4
    Public Const DRIVE_REMOVABLE = 2

'وهذا في الفورم 
Dim strDrive As String
Dim strMessage As String
Dim intCnt As Integer


For intCnt = 65 To 86
    strDrive = Chr(intCnt)


    Select Case GetDriveType(strDrive + ":\")
        Case DRIVE_REMOVABLE
        rtn = "Floppy Drive"
        Case DRIVE_FIXED
        rtn = "Hard Drive"
        Case DRIVE_REMOTE
        rtn = "Network Drive"
        Case DRIVE_CDROM
        rtn = "CD-ROM Drive"
        Case DRIVE_RAMDISK
        rtn = "RAM Disk"
        Case Else
        rtn = ""
    End Select


If rtn <> "" Then
    strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn
End If
Next intCnt
MsgBox (strMessage) 


تأثيرات على الفورم

كود PHP:

Public Sub Pause(Duration As Long)
    '//i didn't write this so i can't docume
    '     nt it
    Dim Current As Long
    Current = Timer


    Do Until Timer - Current >= Duration


        DoEvents
        Loop
    End Sub


Public Sub SlideRight(FirstForm As Form, SecondForm As Form)
    '//the second form is the one that does 
    '     the transition
    SecondForm.Show '//show the form
    SecondForm.Top = FirstForm.Top '//make the .Top equal for both form
    SecondForm.Height = FirstForm.Height '//make the .Height equal
    SecondForm.Width = FirstForm.Width '//make the .Width equal
    SecondForm.Left = SecondForm.Width * -1 '//make .Left negative


    Do Until SecondForm.Left = 0
        '//do the loop until the form is all the
        '     way to the right
        SecondForm.Left = SecondForm.Left + 15 '//add 15 (duh)
        Pause 0.3 '//pause
    Loop
End Sub


Public Sub SlideDown(FirstForm As Form, SecondForm As Form)
    '//the second form is the one that does 
    '     the transition
    SecondForm.Show '//show the form
    SecondForm.Top = FirstForm.Height * -1 'make .Top negative
    SecondForm.Height = FirstForm.Height '//make the .Height equal
    SecondForm.Width = FirstForm.Width '//make the .Width equal
    SecondForm.Left = FirstForm.Left '//make the .Left equal


    Do Until SecondForm.Top = 0
        '//do the loop until the form is all the
        '     way to the bottom
        SecondForm.Top = SecondForm.Top + 15
        Pause 0.3
    Loop
End Sub


Public Sub SlideLeft(FirstForm As Form, SecondForm As Form)
    '//the second form is the one that does 
    '     the transition
    SecondForm.Show
    SecondForm.Top = FirstForm.Top
    SecondForm.Height = FirstForm.Height
    SecondForm.Width = FirstForm.Width
    SecondForm.Left = FirstForm.Width '//put on right side of screen


    Do Until SecondForm.Left = 0
        SecondForm.Left = SecondForm.Left - 15
        Pause 0.3
    Loop
End Sub


Public Sub SlideUp(FirstForm As Form, SecondForm As Form)
    '//the second form is the one that does 
    '     the transition
    SecondForm.Show
    SecondForm.Top = FirstForm.Height '//put form to bottom of screen
    SecondForm.Height = FirstForm.Height
    SecondForm.Width = FirstForm.Width
    SecondForm.Left = FirstForm.Left


    Do Until SecondForm.Top = 0
        SecondForm.Top = SecondForm.Top - 15
        Pause 0.3
    Loop
End Sub 


فورم دائري

كود PHP:

Sub formcircle (frm As Form, Size As Integer)


    For e% = Size% - 1 To 0 Step -1
        frm.Left = frm.Left - e%
        frm.Top = frm.Top + (Size% - e%)
    Next e%


    For e% = Size% - 1 To 0 Step -1
        frm.Left = frm.Left + (Size% - e%)
        frm.Top = frm.Top + e%
    Next e%


    For e% = Size% - 1 To 0 Step -1
        frm.Left = frm.Left + e%
        frm.Top = frm.Top - (Size% - e%)
    Next e%


    For e% = Size% - 1 To 0 Step -1
        frm.Left = frm.Left - (Size% - e%)
        frm.Top = frm.Top - e%
    Next e%
End Sub 


أسماء المجلدات الرئيسية والفرعية في قائمة

كود PHP:

'Declarations
Sub Listdir(path)
    Dim d(1000)
    Dir1.path = path


    For lop = 0 To Dir1.ListCount - 1
        d(cnt) = Dir1.List(lop)
        cnt = cnt + 1
    Next lop


    For lop = 0 To cnt - 1
        List1.AddItem d(lop)
        cur_depth = cur_depth + 1
        listdir d(lop)
    Next lop
    cur_depth = curr_depth - 1
End Sub

'ضع هذا في الفورم 
Listdir(اسم المجلد) 


كلام متحرك في TITLEBAR

كود PHP:

Private Sub Timer1_Timer()
    On Error Resume Next
    If Val(Timer1.Tag) < Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
    Me.Caption = Right(****1.****, Len(****1.****) - Val(Timer1.Tag))
    Timer1.Tag = Val(Timer1.Tag) + 1


    If Me.Caption = "" Then
        If Val(Timer1.Tag) > Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
        Me.Caption = Left(****1.****, Len(****1.****) - Val(Timer1.Tag))
        Timer1.Tag = Val(Timer1.Tag) + 1
    End If
End Sub


Private Sub Form_Load()
    Timer1.Enabled = True
End Sub 


استقبال مكالمة هاتفية

كود 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:

ضع هذه الأكواد داخل اداة timer وأجعل الخاصية interval ب1
If Me.Height > 405 Then 
Me.Height = Me.Height - 200 
Me.Top = Me.Top + 100 
Else 
Form1.Visible = True 
Unload Me 
End If 


كيف أقرأ أي كلمة تكون تحت موقع الفأرة

كود PHP:

أضف أداة Timer ثم استخدم الشيفرة التالية
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, ByVal lParam As Any) _
 As Long
Private Declare Function SendMessageByString Lib _
 "user32" Alias "SendMessageA" (ByVal hwnd As _
 Long, ByVal wMsg As Long, ByVal wParam As Long, _
 ByVal lParam As String) As Long
Private Declare Function GetCursorPos Lib "user32" _
 (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib _
 "user32" (ByVal xPoint As Long, ByVal yPoint _
 As Long) As Long

Private Function Win****(hwnd As Long) As String
 Dim Trm&, Buf$
 Trm = SendMessage(hwnd, 14, 0&, 0&)
 Buf = String(Trm, " ")
 SendMessageByString hwnd, 13, Trm + 1, Buf
 Win**** = Buf
End Function

Private Sub Form_Load()
 Timer1.Interval = 50
End Sub

Private Sub Timer1_Timer()
 Dim lng_hWnd&, pt As POINTAPI
 GetCursorPos pt
 lng_hWnd = WindowFromPoint(pt.x, pt.y)
 Label1 = Win****(lng_hWnd)
End Sub 


أخفاء المجلدات و الملفات عن طريق فجوال بيسك

كود PHP:

'SetAttr pathname, attributes
'folder
SetAttr "c:\x", vbHidden
file
SetAttr "c:\file.txt", vbHidden 


شفرة التعامل مع الأداة AVI

كود PHP:

Private Sub Command1_Click() 
Dim z: Dim zz 
zz = " c:boxGrolierspace1.avi" ' أكتب هنا مسا ر ملف الفيديو 
MMControl1.DeviceType = "AVIVideo" 
z = App.Path 'تستخدم هذه الشفرة إذا كان ملف الفيديو في نفس مسار المشروع 
zz = z + "" + "5.avi" ' تكمل السابقة 
MMControl1.FileName = zz 
MMControl1.hWndDisplay = Form1.hWnd ' هذه تستخدم لتحديد المكان الذي سيظهر فيه الفيديو 
MMControl1.Command = "open" 
MMControl1.Command = "prev" 
MMControl1.Command = "play" 
End Sub 

Private Sub MMControl1_Done(NotifyCode As Integer) 
If MMControl1.Position = MMControl1.Length Then 
Dim z: Dim zz 
zz = " c:boxGrolierspace2.avi" ' أكتب هنا مسا ر ملف الفيديو 
MMControl1.DeviceType = "AVIVideo" 
z = App.Path 'تستخدم هذه الشفرة إذا كان ملف الفيديو في نفس مسار المشروع 
zz = z + "" + "5.avi" ' تكمل السابقة 
MMControl1.FileName = zz 
MMControl1.hWndDisplay = Form1.hWnd ' هذه تستخدم لتحديد المكان الذي سيظهر فيه الفيديو 
MMControl1.Command = "open" 
MMControl1.Command = "prev" 
MMControl1.Command = "play" 
End If 
End Sub 


إبطال عمل Ctrl+c

كود PHP:

'فى موديول
Public Const WM_KEYDOWN = &H100
Public Const WM_CHAR = &H102
Public Const GWL_WNDPROC = (-4)
Public Declare Function SetWindowLong Lib "user32" Alias _
 "SetWindowLongA" (ByVal hwnd As Long, ByVal _
 nIndex As Long, ByVal dwNewLong As Long) _
 As Lo

'فى الفورم
Private Sub Form_Load()
  hPrevWndProc = SetWindowLong(Rich****Box1.hwnd, _
   GWL_WNDPROC, AddressOf WindowProc)
End Sub 


إظهار نافذة الخطأ البيضاء

كود PHP:

Private Declare Sub FatalAppExit Lib "kernel32" Alias "FatalAppExitA" (ByVal uAction As Long, ByVal lpMessage**** As String) 

Private Sub Form_Load() 
FatalAppExit 0, "Contactez le revendeur de ce programme" & vbLf & vbLf & "(Cette source provient de http://www.vbfrance.com/)" 
End Sub 


إفراغ سلة المحذوفات

كود PHP:

'إفراغ سلة المحذوفات 
Private Declare Function SHEmptyRecycleBin Lib "****l32.dll" Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long 
Private Declare Function SHUpdateRecycleBinIcon Lib "****l32.dll" () As Long 

Private Sub Form_Load() 
'الإفراغ 
SHEmptyRecycleBin Me.hwnd, vbNullString, 0 
التحديث 
SHUpdateRecycleBinIcon 
End Sub 


اتصل تليفونيا

كود PHP:

Private Declare Function tapiRequestMakeCall Lib "TAPI32.DLL" (ByVal Dest As String, ByVal AppName As String, ByVal CalledParty As String, ByVal Comment As String) As Long
Private Sub Command1_Click()
a = tapiRequestMakeCall((1014557524), "Program Name", (Name), "Addition Comments")
End Sub 


اخفاء واظهار زر ابدء

كود PHP:

Const SW_SHOWNORMAL = 1
Private Declare Function FindWindow Lib "user32" Alias _
   "FindWindowA" (ByVal lpClassName As String, _
   ByVal lpWindowName As String) As Long
   
Private Declare Function FindWindowEx Lib "user32" Alias _
   "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
   ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function ShowWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Const SW_HIDE = 0



Public Function hideStartButton()
   'This Function Hides the Start Button'
   OurParent& = FindWindow("****l_TrayWnd", "")
   OurHandle& = FindWindowEx(OurParent&, 0, "Button", _
       vbNullString)
   ShowWindow OurHandle&, SW_HIDE
End Function

Public Function showStartButton()
   'This Function Shows the Start Button'
   OurParent& = FindWindow("****l_TrayWnd", "")
   OurHandle& = FindWindowEx(OurParent&, 0, "Button", _
        vbNullString)

   ShowWindow OurHandle&, SW_SHOWNORMAL
End Function

Private Sub Command1_Click()
hideStartButton
End Sub

Private Sub Command2_Click()
showStartButton
End Sub 


اظهار واخفاء مؤشر الماوس

كود PHP:

'فى الموديول
Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

'Command1 + command2
Private Sub Command1_Click()
Dim x As Long
x = ShowCursor(True) 'اظهار المؤشر
End Sub

Private Sub Command2_Click()
Dim x As Long
x = ShowCursor(False) 'اخفاء المؤشر

End Sub 


اعداد الطابعة

كود PHP:

Dim X As Integer

Private Sub Command2_Click()
Printer.Print “October; War”
End Sub 


الاصوات في فيجوال بيسك

كود PHP:

Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

Private Const SND_SYNC = &H0 ' play synchronously (default)
Private Const SND_ASYNC = &H1 ' play asynchronously
Private Const SND_LOOP = &H8 ' loop the sound until next sndPlaySound
Private Const SND_NOSTOP = &H10 ' don't stop any currently playing sound

Private Sub Command1_Click()
res = sndPlaySound(App.Path & "\97", SND_ASYNC)
'لتشغيل ملف ويعود التنفيذ للبرنامج بمجرد بدء تشغيل ملف الصوت
End Sub

Private Sub Command2_Click()
res = sndPlaySound(App.Path & "\97", SND_SYNC)
'تشغيل ملف صوت ولا يعود التحكم للبرنامج إلا بعد الإنتهاء من تشغيل ملف الصوت بالكامل

End Sub

Private Sub Command3_Click()
rse = sndPlaySound(App.Path & "\97", SND_LOOP Or SND_ASYNC)
'ولتشغيل الملف بشكل تكراري

End Sub

Private Sub Command4_Click()
res = sndPlaySound(App.Path & "\97.wav", SND_NOSTOP Or SND_ASYNC)
ولتشغيل الملف بشرط أنه لا يكون هناك ملف صوتي آخر قيد التشغيل


End Sub

Private Sub Form_Load()

End Sub 


الدخول للانترنت عن طريق الكود

كود PHP:

'modeul
Declare Function ****lExecute Lib "****l32.dll" Alias "****lExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Const conSwN
'command1
Private Sub Command1_Click()
****lExecute hwnd, "open", "http://arafa.4mg.com/ash.htm", vbNullString, vbNullString, conSwNormal
End Sub 


الكود الذي يقوم بقراءة رقم الهاردسك

كود PHP:

استخدام المكتبة Microsoft ******ing Runtime 
Private Sub Command1_Click()
 Dim obj_FSO As Object, obj_Drive As Object
 Set obj_FSO = CreateObject("******ing.FileSystemObject")
 Set obj_Drive = obj_FSO.GetDrive("c:\")
 MsgBox obj_Drive.SerialNumber
 Set obj_FSO = Nothing
 Set obj_Drive = Nothing
End Sub 


النسخ الاحتياطي للبيانات

كود PHP:

'لعمل الفولدر 
Private Sub CMDmak_Click() 

'MkDir "D:\BACKUP" 
'MkDir "D:\BACKUP\SITRAWI" 
End Sub 
'لنسخ الملف 
Private Sub CMDBAK_Click() 
SOURCE = "D:\hus\Aig.bmp" 
dESTN = "D:\BACKUP\SITRAWI\AIG.BMp" 
FileCopy SOURCE, dESTN 
End Sub 


[جموح]

سلمت اناملك ولا شلت يمينك