مكتبة الاكواد المنسوخة للغة الفجوال بيسك

[محمدعلى]

مكتبة الاكواد المنسوخة للغة الفجوال بيسك

[PHP]


إنشاء مجلد جديد
' ضع هذا الكود في الفورم




Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDe******or As Long
***heritHandle As Boolean
End Type
Private Declare Function CreateDirectory Lib "kernel32.dll" Alias "CreateDirectoryA" (ByVal lpPath**** 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.lpSecurityDe******or = 0 'normal level of security
attr.***heritHandle = 1 'default setting
' Create directory.
rval = CreateDirectory(****1.****, attr)
End Sub

Private Sub Form_Load()
****1.**** = "c:Abdu"
Command1.Caption = "New Directory"
End Sup






نسخ ملف
' ضع هذا الكود في الفورم




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






إنشاء ملف جديد
' ضع هذا الكود في الفورم




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





حذف ملف
' ضع هذا الكود في الفورم




Private Sub Command1_Click()
Kill ("C:File****.fnm")
End Sub






حجم الملف بالبايت
' ضع هذا الكود في الفورم




Private Sub Command1_Click()
Print FileLen("c:Autoexec.bat")
End Sub






التأكد من وجود ملف
' ضع هذا الكود في الفورم




Private Sub Command1_Click()
On Error GoTo Error:
Open "ضع مسار الملف الذي تريد التأكد من وجوده هنا" For Input As #1
Close
MsgBox ("الملف موجود")
Exit Sub
Error:
MsgBox ("الملف غير موجود")
End Sub





تغيير خصائص ملف
' ضع هذا الكود في الفورم




Private Sub COMMAND1_CLICK()
SetAttr "C:data.txt", vbHidden
SetAttr "C:data.txt", vbReadOnly
SetAttr "C:data.txt", vbArchive
End Sub






حساب عدد سطور ملف نصي
' ضع هذا الكود في الفورم

Private Sub Command1_Click()
Open "c:autoexec.bat" For Input As #1
Count:
SS = SS + 1
Line Input #1, x
If EOF(1) Then
Label1.Caption = SS
Exit Sub
Else
GoTo Count:
End If
Close
End Sub






نقل ملف
' ضع هذا الكود في الفورم


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







' ضع هذا الكود في الفورم


Private Sub Command1_Click()
Dim PhoneNumber As String
On Error GoTo WrongPort
MSComm1.CommPort = 3 'قم بتغيير البورت من 1 إلى 8 حتى تصل إلى البورت الصحيح
MSComm1.Settings = "300,n,8,1"
PhoneNumber = "07770777"
MSComm1.PortOpen = True
MSComm1.OutPut = "ATDT" + PhoneNumber + Chr$(13)
Exit Sub
WrongPort:
MsgBox "Title", 1048576 + 524288 + 16, "Prompt"
End Sub

Private Sub Command2_Click()
MSComm1.PortOpen = False
End Sub

Private Sub Form_Load()
Command1.Caption = "&Connect"
Command2.Caption = "&Disconnect"
End Sub





[/PHP]



[PHP]



فتح صفحة إنترنت
' ضع هذا الكود في الفورم


Private Sub Command1_Click()
***** "RUNDLL32.EXE URL.DLL,FileProtocolHandler http://www.al-ebda3.info/ib/", 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






حالة الاتصال بالإنترنت
' ضع هذا الكود في الموديول




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_MaxEntry**** = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDevice**** = 32

Public Type RASCONN95
dwSize As Long
hRasCon As Long
szEntry****(RAS95_MaxEntry****) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDevice****(RAS95_MaxDevice****) As Byte
End Type

Public Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDevice****(RAS95_MaxDevice****) 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 ("الجهاز متصل بالانترنت")
Else
MsgBox ("الجهاز غير متصل بالانترنت")
End If
End Sub







فتح برنامج المفكرة والإضافة عليه
'ضع هذا الكود في الفورم




Private Sub Command1_Click()
***** "notepad.exe", vbNormalNoFocus
AppActivate ("المفكرة")
SendKeys ("www.arab-team.com")
End Sub







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

' ضع هذا الكود في الفورم





Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Const FTP_TRANSFER_TYPE_ASCII = &H1
Const FTP_TRANSFER_TYPE_***ARY = &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 ****d proxy
Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 ' prevent using ****/******/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
cFile**** 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 sServer**** As String, ByVal nServerPort As Integer, ByVal sUser**** As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lCon**** As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxy**** 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 lpszFile**** As String) As Boolean
Private Declare Function FtpRe****File Lib "wininet.dll" Alias "FtpRe****FileA" (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 dwCon**** 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 dwCon**** 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 dw******* 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
're**** 'test.htm' to 'apiguide.htm'
FtpRe****File 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.cFile**** = 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 file****
Me.Print Left(pData.cFile****, InStr(1, pData.cFile****, String(1, 0), vb***aryCompare) - 1)
Do
'create a buffer
pData.cFile**** = 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 file****
Me.Print Left(pData.cFile****, InStr(1, pData.cFile****, String(1, 0), vb***aryCompare) - 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







طلب الاتصال بالإنترنت 2

Option Explicit

Public Declare Function InternetGetConnectedStateEx Lib "wininet.dll" Alias "InternetGetConnectedStateExA" _
(ByRef lpdwFlags As Long, _
ByVal lpszConnection**** As String, _
ByVal dw****Len As Long, _
ByVal dwReserved As Long _
) As Long

Public Enum EIGCInternetConnectionState
INTERNET_CONNECTION_MODEM = &H1&
INTERNET_CONNECTION_LAN = &H2&
INTERNET_CONNECTION_PROXY = &H4&
INTERNET_RAS_INSTALLED = &H10&
INTERNET_CONNECTION_OFFLINE = &H20&
INTERNET_CONNECTION_CONFIGURED = &H40&
End Enum

Public Property Get InternetConnected( _
Optional ByRef eConnectionInfo As EIGCInternetConnectionState, _
Optional ByRef sConnection**** As String _
) As Boolean
Dim dwFlags As Long
Dim s****Buf As String
Dim lR As Long
Dim iPos As Long
s****Buf = String$(513, 0)
lR = InternetGetConnectedStateEx(dwFlags, s****Buf, 512, 0&)
eConnectionInfo = dwFlags
iPos = InStr(s****Buf, vbNullChar)
If iPos > 0 Then
sConnection**** = Left$(s****Buf, iPos - 1)
ElseIf Not s****Buf = String$(513, 0) Then
sConnection**** = s****Buf
End If
InternetConnected = (lR = 1)
End Property
'
' Here's where we check if it's connected - place a ****box (****1 - multiline = true) on
' a form (FORM1) with a button (Command1)
'
Private Sub Command1_Click()
Dim eR As EIGCInternetConnectionState
Dim sMsg As String
Dim s**** As String
Dim bConnected As Boolean

' Determine whether we have a connection:
bConnected = InternetConnected(eR, s****)

' The connection state info parameter provides details
' about how we connect:
If (eR And INTERNET_CONNECTION_MODEM) = INTERNET_CONNECTION_MODEM Then
sMsg = sMsg & "Connection uses a modem." & vbCrLf
End If
If (eR And INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN Then
sMsg = sMsg & "Connection uses LAN." & vbCrLf
End If
If (eR And INTERNET_CONNECTION_PROXY) = INTERNET_CONNECTION_PROXY Then
sMsg = sMsg & "Connection is via Proxy." & vbCrLf
End If
If (eR And INTERNET_CONNECTION_OFFLINE) = INTERNET_CONNECTION_OFFLINE Then
sMsg = sMsg & "Connection is Off-line." & vbCrLf
End If
If (eR And INTERNET_CONNECTION_CONFIGURED) = INTERNET_CONNECTION_CONFIGURED Then
sMsg = sMsg & "Connection is Configured." & vbCrLf
Else
sMsg = sMsg & "Connection is Not Configured." & vbCrLf
End If
If (eR And INTERNET_RAS_INSTALLED) = INTERNET_RAS_INSTALLED Then
sMsg = sMsg & "System has RAS installed." & vbCrLf
End If

' Display the connection **** and info:
If bConnected Then
****1.**** = "Connected: " & s**** & vbCrLf & vbCrLf & sMsg
Else
****1.**** = "Not Connected: " & s**** & vbCrLf & vbCrLf & sMsg
End If

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.**** = Combo1.List(0)
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 SetForeground****** Lib "user32" _
(ByVal hWnd As Long) As Long
Public Declare Function *****_NotifyIcon Lib "*****32" _
Alias "*****_NotifyIconA" _
(ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean

Public nid As NOTIFYICONDATA




'ضع هذا الكود في الفورم



Private Sub Form_Load()
Me.Show
Me.*******
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
*****_NotifyIcon NIM_ADD, nid
End Sub

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

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







توليد عشوائي للأرقام
'ضع هذا الكود في الفورم




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







الوظيفة Split لمستخدمي الإصدارة الخامسة
' ضع هذا الكود في الفورم




Function Split(ByVal **** As String, Optional ByVal Delimiter As String = _
" ", Optional ByVal Limit As Long = -1, Optional CompareMethod As _
VbCompareMethod = vb***aryCompare) As Variant
ReDim res(0 To 100) As String
Dim resCount As Long
Dim length As Long
Dim startIndex As Long
Dim endIndex As Long

length = Len(****)
startIndex = 1

Do While startIndex < length And resCount <> Limit
' get the next delimiter
endIndex = InStr(startIndex, ****, Delimiter, CompareMethod)
If endIndex = 0 Then endIndex = length + 1

' make room in the array, if necessary
If resCount > UBound(res) Then
ReDim Preserve res(0 To resCount + 99) As String
End If
' store the new element
res(resCount) = Mid$(****, startIndex, endIndex - startIndex)
resCount = resCount + 1

startIndex = endIndex + Len(Delimiter)
Loop

' trim unused values
ReDim Preserve res(0 To resCount - 1) As String

' return the array inside a Variant
Split = res()

End Function







حفظ ما يتغير في الـ Form حتى بعد إغلاقها
' ضع هذا الكود في الفورم




Private Sub Form_Load()
****1.**** = GetSetting(App.Title, "Settings", "SaveIn****1")
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveSetting App.Title, "Settings", "SaveIn****1", Trim(****1.****)
End Sub



'يمكنك تغيير ال ****1 بأي شيء آخر image أو Picture أو ... الخ





[/PHP]

[بدر56]

مشكووووووور

المهندسين العرب فوق القمه كل الفخر للمهندسين العرب

[علاء نبيل محمد]

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

[عصام احمد حسن 20]

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

[alidaoud]

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

[hady306]

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

[waled_2010_12]

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

[L.AGANDOU]

Merci mon ami

[ابوالعنين]

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