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

اخفاء محتويات محرك الاقراص :


Dim WSH As Object
Set WSH = CreateObject("Wscript.Shell")
WSH.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoViewOnDrive", 16, "REG_DWORD"

توليد عشوائي للارقام :

Dim RanNo() As Long
Dim i, j, tmp

Private Sub RandomizeNumbers(ByVal iFrom As Integer, ByVal iTo As Integer)
ReDim RanNo(iFrom To iTo)
For i = iFrom To iTo
RanNo(i) = i
Next i
Randomize (Timer)
For i = iFrom To iTo
j = CInt((iTo - iFrom) * Rnd + iFrom)
tmp = RanNo(i)
RanNo(i) = RanNo(j)
RanNo(j) = tmp
Next i
End Sub

Private Sub Command1_Click()
RandomizeNumbers 0, 100
For i = 0 To 100
List1.AddItem RanNo(i)
Next i
End Sub

ايقونة للبرامج بجوار الساعة :

Public Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type

Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201 'Button down
Public Const WM_LBUTTONUP = &H202 'Button up
Public Const WM_LBUTTONDBLCLK = &H203 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up
Public Const WM_RBUTTONDBLCLK = &H206 'Double-click

Public Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32" _
Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

Public nid As NOTIFYICONDATA

'ÖÚ åÐÇ ÇáßæÏ Ýí ÇáÝæÑã

Private Sub Form_Load()
Me.Show
Me.Refresh
With nid
.cbSize = Len(nid)
.hWnd = Me.hWnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon
.szTip = "Your ToolTip" & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, nid
End Sub

Private Sub Form_Resize()
If Me.WindowState = vbMinimized Then Me.Hide
End Sub

Private Sub Form_Unload(Cancel As Integer)
Shell_NotifyIcon NIM_DELETE, nid
End Sub

عرض الخطوط في قائمة منسدلة :

Private Sub Form_Load()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub

طلب الاتصال بالانترنت :

Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Const FTP_TRANSFER_TYPE_ASCII = &H1
Const FTP_TRANSFER_TYPE_BINARY = &H2
Const INTERNET_DEFAULT_FTP_PORT = 21 ' default

'for FTP servers
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_FLAG_PASSIVE = &H8000000 ' used

'for FTP connections
Const INTERNET_OPEN_TYPE_PRECONFIG = 0 '

'use registry configuration
Const INTERNET_OPEN_TYPE_DIRECT = 1 '

'direct to net
Const INTERNET_OPEN_TYPE_PROXY = 3 '

'via named proxy
Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 ' prevent using java/script/INS
Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Long
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean
Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hFtpSession As Long, ByVal lpszExisting As String, ByVal lpszNew As String) As Boolean
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hConnect As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByRef dwContext As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hConnect As Long, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Boolean
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dwContent As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Const PassiveConnection As Boolean = True
Private Sub Form_Load()
Dim hConnection As Long, hOpen As Long, sOrgPath As String
'open an internet connection
hOpen = InternetOpen("API-Guide sample program", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
'connect to the FTP server
hConnection = InternetConnect(hOpen, "your ftp server", INTERNET_DEFAULT_FTP_PORT, "your login", "your password", INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)
'create a buffer to store the original directory
sOrgPath = String(MAX_PATH, 0)
'get the directory
FtpGetCurrentDirectory hConnection, sOrgPath, Len(sOrgPath)
'create a new directory 'testing'
FtpCreateDirectory hConnection, "testing"
'set the current directory to 'root/testing'
FtpSetCurrentDirectory hConnection, "testing"
'upload the file 'test.htm'
FtpPutFile hConnection, "C:\test.htm", "test.htm", FTP_TRANSFER_TYPE_UNKNOWN, 0
'rename 'test.htm' to 'apiguide.htm'
FtpRenameFile hConnection, "test.htm", "apiguide.htm"
'enumerate the file list from the current directory ('root/testing')
EnumFiles hConnection
'retrieve the file from the FTP server
FtpGetFile hConnection, "apiguide.htm", "c:\apiguide.htm", False, 0, FTP_TRANSFER_TYPE_UNKNOWN, 0
'delete the file from the FTP server
FtpDeleteFile hConnection, "apiguide.htm"
'set the current directory back to the root
FtpSetCurrentDirectory hConnection, sOrgPath
'remove the direcrtory 'testing'
FtpRemoveDirectory hConnection, "testing"
'close the FTP connection
InternetCloseHandle hConnection
'close the internet connection
InternetCloseHandle hOpen
End Sub
Public Sub EnumFiles(hConnection As Long)
Dim pData As WIN32_FIND_DATA, hFind As Long, lRet As Long
'set the graphics mode to persistent
Me.AutoRedraw = True
'create a buffer
pData.cFileName = String(MAX_PATH, 0)
'find the first file
hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
'if there's no file, then exit sub
If hFind = 0 Then Exit Sub
'show the filename
Me.Print Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Do
'create a buffer
pData.cFileName = String(MAX_PATH, 0)
'find the next file
lRet = InternetFindNextFile(hFind, pData)
'if there's no next file, exit do
If lRet = 0 Then Exit Do
'show the filename
Me.Print Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Loop
'close the search handle
InternetCloseHandle hFind
End Sub
Sub ShowError()
Dim lErr As Long, sErr As String, lenBuf As Long
'get the required buffer size
InternetGetLastResponseInfo lErr, sErr, lenBuf
'create a buffer
sErr = String(lenBuf, 0)
'retrieve the last respons info
InternetGetLastResponseInfo lErr, sErr, lenBuf
'show the last response info
MsgBox "Error " + CStr(lErr) + ": " + sErr, vbOKOnly + vbCritical
End Sub

حالة الاتصال بالانترنت :

Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32

Public Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type

Public Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type


' ÖÚ åÐÇ ÇáßæÏ Ýí ÇáÝæÑã

Public Function IsConnected() As Boolean

Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95

TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize

RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)

If RetVal <> 0 Then
MsgBox "ERROR"
Exit Function
End If

Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)

If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If

End Function

Private Sub Command1_Click()
If IsConnected() = True Then
MsgBox ("&Ccedil;&aacute;&Igrave;&aring;&Ccedil;&Ograve; &atilde;&Ecirc;&Otilde;&aacute; &Egrave;&Ccedil;&aacute;&Ccedil;&auml;&Ecirc;&Ntilde;&auml;&Ecirc;")
Else
MsgBox ("&Ccedil;&aacute;&Igrave;&aring;&Ccedil;&Ograve; &Ucirc;&iacute;&Ntilde; &atilde;&Ecirc;&Otilde;&aacute; &Egrave;&Ccedil;&aacute;&Ccedil;&auml;&Ecirc;&Ntilde;&auml;&Ecirc;")
End If
End Sub

فتح صفحة الانترنت :

Private Sub Command1_Click()
Shell "RUNDLL32.EXE URL.DLL,FileProtocolHandler http://www.oman0.net", vbNormalFocus
End Sub

Private Sub Command2_Click()
Dim X As Object
Set X = CreateObject("InternetExplorer.Application")
X.Navigate "www.noisrael.com"
X.Visible = True
End Sub

نقل الملفات :

Private Sub Command1_Click()
Name "c:\Autoexec.bat" As "D:\Autoexec.bat"
End Sub

حذف الملفات :

Private Sub Command1_Click()
Kill ("C:\FileName.fnm")
End Sub

انشاء ملف جديد :

Private Sub Command1_Click()
open "c:\FileName.txt" for append as #1
Print #1,"Willkommen auf die Erde"
Close #1
End Sub

نسخ الملفات :

Private Sub Command1_Click()
FileCopy "c:\Autoexec.bat", "d:\Autoexec.bat"
End Sub

انشاء مجلد جديد :

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Declare Function CreateDirectory Lib "kernel32.dll" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

Private Sub Command1_Click()
Dim attr As SECURITY_ATTRIBUTES ' security attributes structure
Dim rval As Long
' Set security attributes
attr.nLength = Len(attr) 'size of the structure
attr.lpSecurityDescriptor = 0 'normal level of security
attr.bInheritHandle = 1 'default setting
' Create directory.
rval = CreateDirectory(Text1.Text, attr)
End Sub

Private Sub Form_Load()
Text1.Text = "c:\Abdu"
Command1.Caption = "New Directory"
End Sub

معرفة معلومات عن القرص :

Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long

Private Sub Form_Load()

Dim r As Long, BytesFreeToCalller As Currency, TotalBytes As Currency
Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency
Const RootPathName = "c:\"
Call GetDiskFreeSpaceEx(RootPathName, BytesFreeToCalller, TotalBytes, TotalFreeBytes)
Me.AutoRedraw = True
Me.Cls
Me.Print
Me.Print
Me.Print
Me.Print " Total Number Of Bytes:", Format$(TotalBytes * 10000, "###,###,###,##0") & " bytes"
Me.Print " Total Free Bytes:", Format$(TotalFreeBytes * 10000, "###,###,###,##0") & " bytes"
Me.Print " Free Bytes Available:", Format$(BytesFreeToCalller * 10000, "###,###,###,##0") & " bytes"
Me.Print " Total Space Used :", Format$((TotalBytes - TotalFreeBytes) * 10000, "###,###,###,##0") & " bytes"
End Sub

انشاء مربع نص بواسطة الكود :

Private WithEvents btnObj As CommandButton
Private WithEvents txtObj As TextBox


Private Sub btnObj_Click()
On Error Resume Next
Set txtObj = Controls.Add("VB.textbox", "txtObj")
With txtObj
.Visible = True
.RightToLeft = True
.Alignment = 2
.Width = 2000
.Text = "&Ccedil;&aacute;&Oacute;&aacute;&Ccedil;&atilde; &Uacute;&aacute;&iacute;&szlig;&atilde;"
.Top = 2000
.Left = 1000
End With
End Sub

Private Sub Form_Load()
Set btnObj = Controls.Add("VB.CommandButton", "btnObj")
With btnObj
.Visible = True
.Width = 2000
.Caption = "Click"
.Top = 1000
.Left = 1000
End With
End Sub

ترجمة النجوم ************ في كلمات السر الى حروف عادية :

Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
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, lParam As Any) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

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

Private Sub Timer1_Timer()
Const EM_SETPASSWORDCHAR = &HCC
Dim coord As POINTAPI

s = GetCursorPos(coord)
x = coord.x
y = coord.y

h = WindowFromPoint(x, y)

Dim NewChar As Integer
NewChar = CLng(0)
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub

تحريك الكلام في عنوان الفورم و مربع النص :


Private strText As String
Private Sub Form_Load()
Timer1.Interval = 75
strText = "Guten Tag! Wie ght's Ihnen? Ich hoffe Ihnen alles Gutes!"
strText = Space(50) & strText
End Sub
Private Sub Timer1_Timer()
strText = Mid(strText, 2) & Left(strText, 1)
Text1.Text = strText
Me.Caption = strText
End Sub

لا شـــكر علــى واجـــب **

علــى الرّحـــبِ و السِّـــــعة **

على الرحب و السعة **