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

[talaldc]

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

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//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 lCon 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 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

'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

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

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

Private Sub Command1_Click()

l "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_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 ("الجهاز متصل بالانترنت")

Else

MsgBox ("الجهاز غير متصل بالانترنت")

End If

End Sub

فيديو تشغيل ملف فيديو في picture

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

Private Sub Form_Load()

MMControl1.FileName = ("c:\FileName.dat")

MMControl1.Command = "open"

MMControl1.hWndDisplay = Picture1.hWnd

End Sub

تشغيل ملف من نوع avi بدون أوات

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

Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

Private Sub Form_Click()

Dim Ret As Long, A$, x As Integer, y As Integer

x = 10

y = 10

A$ = "c:\Filename.avi"

Ret = mciSendString("stop movie", 0&, 128, 0)

Ret = mciSendString("close movie", 0&, 128, 0)

Ret = mciSendString("open AVIvideo!" & A$ & " alias movie parent " & Form1.hWnd & " style child", 0&, 128, 0)

Ret = mciSendString("put movie window client at " & x & " " & y & " 0 0", 0&, 128, 0)

Ret = mciSendString("play movie", 0&, 128, 0)

End Sub

Private Sub Form_DblClick()

End

End Sub

Private Sub Form_Terminate()

Dim Ret As Long

Ret = mciSendString("close all", 0&, 128, 0)

End Sub

صورة التقاط صورة للشاشة

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

Const RC_PALETTE As Long = &H100

Const SIZEPALETTE As Long = 104

Const RASTERCAPS As Long = 38

Private Type PALETTEENTRY

peRed As Byte

peGreen As Byte

peBlue As Byte

peFlags As Byte

End Type

Private Type LOGPALETTE

palVersion As Integer

palNumEntries As Integer

palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors

End Type

Private Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(7) As Byte

End Type

Private Type PicBmp

Size As Long

Type As Long

hBmp As Long

hPal As Long

Reserved As Long

End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long

Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long

Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long

Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long

Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture

Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

'Fill GUID info

With IID_IDispatch

.Data1 = &H20400

.Data4(0) = &HC0

.Data4(7) = &H46

End With

'Fill picture info

With Pic

.Size = Len(Pic) ' Length of structure

.Type = vbPicTypeBitmap ' Type of Picture (bitmap)

.hBmp = hBmp ' Handle to bitmap

.hPal = hPal ' Handle to palette (may be null)

End With

'Create the picture

R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

'Return the new picture

Set CreateBitmapPicture = IPic

End Function

Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture

Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long

Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long

Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

'Create a compatible device con

hDCMemory = CreateCompatibleDC(hDCSrc)

'Create a compatible bitmap

hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)

'Select the compatible bitmap into our compatible device con

hBmpPrev = SelectObject(hDCMemory, hBmp)

'Raster capabilities?

RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster

'Does our picture use a palette?

HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette

'What's the size of that palette?

PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

If HasPaletteScrn And (PaletteSizeScrn = 256) Then

'Set the palette version

LogPal.palVersion = &H300

'Number of palette entries

LogPal.palNumEntries = 256

'Retrieve the system palette entries

R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))

'Create the palette

hPal = CreatePalette(LogPal)

'Select the palette

hPalPrev = SelectPalette(hDCMemory, hPal, 0)

'Realize the palette

R = RealizePalette(hDCMemory)

End If

'Copy the source image to our compatible device con

R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

'Restore the old bitmap

hBmp = SelectObject(hDCMemory, hBmpPrev)

If HasPaletteScrn And (PaletteSizeScrn = 256) Then

'Select the palette

hPal = SelectPalette(hDCMemory, hPalPrev, 0)

End If

'Delete our memory DC

R = DeleteDC(hDCMemory)

Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)

End Function

Private Sub Form_Load()

'Create a picture object from the screen

Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)

End Sub

كود بسيط لالتقاط صورة للشاشة في الحافظة

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

Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Sub Command1_Click()

keybd_event vbKeySnapshot, 0, 0, 0

DoEvents

End Sub

صوت تشغيل ملف صوتي من نوع ram

ضع هدا الكود في الفورم ولاحظ أنه يحتاج إلى الأداة الموجودة مع الريل بلاير

Private Sub Command1_Click()

RealAudio1.Source = "c:\AFR.ram"

RealAudio1.DoPlay

End Sub

تشغيل ملف صوتي من نوع midi

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

Private Sub Form_Load()

MMControl1.Visible = False

MMControl1.DeviceType = "sequencer"

MMControl1.FileName = ("c:\FileName.mid")

MMControl1.Command = "open"

MMControl1.Command = "play"

End Sub

التحكم في رفع وخفض الصوت

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

Private Declare Function waveOutSetVolume Lib "Winmm.dll" (ByVal DevID As Integer, ByVal Vol As Long) As Long

Sub SetVol(Volume As Long)

Dim Vol&

Vol = CLng("&H" & Hex(Volume + 65536))

waveOutSetVolume 0, Vol

End Sub

Private Sub Command1_Click()

SetVol 1.

End Sub

Private Sub Form_Load()

1. = "ضع قيمة عددية تنحصر ما بين 0 و65536"

End Sub

الوقت والتاريخ معرفة اليوم الحالي

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

Private Sub Command1_Click()

Dim Dday As Integer

Dday = Weekday(Date)

If Dday = 1 Then Print "الأحد"

If Dday = 2 Then Print "الاثنين"

If Dday = 3 Then Print "الثلاثاء"

If Dday = 4 Then Print "الأربعاء"

If Dday = 5 Then Print "الخميس"

If Dday = 6 Then Print "الجمعة"

If Dday = 7 Then Print "السبت"

End Sub

معرفة الشهر الحالي

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

Private Sub Command1_Click()

Mmonth = Mid(Date, 4, 2)

Print MonthName(Mmonth)

End Sub

الفرق بين تاريخين باليوم

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

Private Sub Command1_Click()

On Error GoTo 1

Dim Form1Date As Date

Dim Form2Date As Date

Form1Date = 1.

Form2Date = 2.

3. = DateDiff("d", 1., 2.) & " اليوم"

Exit Sub

MsgBox ("من فضلك أدخل التاريخ بشكل صحيح")

End Sub

عرض الزمن والتاريخ

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

Private Sub Form_Load()

Timer1.Interval = 1000

End Sub

Private Sub Timer1_Timer()

Label1 = Time & Date

End Sub

الحماية نسخة مشتركة من البرنامج (تشتغل لعدد معين)

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

Private Sub Form_Load()

retvalue = GetSetting("A", "0", "Runcount")

GD$ = Val(retvalue) + 1

SaveSetting "A", "0", "RunCount", GD$

If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل

MsgBox ("انتهت مدة تشغيل البرنامج,قم بشراء النسخة الكاملة من المنتج")

Unload Me

End If

End Sub

منع النسخ أو اللصق

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

Private Sub Form_Load()

Timer1.Interval = 1

End Sub

Private Sub Timer1_Timer()

R = Clipboard.Get

If Len® = 0 Then

Clipboard.Clear

End If

End Sub

منع تشغيل أكثر من نسخة من البرنامج

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

Private Sub Form_Load()

If App.PrevInstance = True Then

MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"

Unload Me

Exit Sub

End If

End Sub

التأكد من عمل البرنامج من على ال CD-ROM

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

Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

Private Sub Form_Load()

Dim driveType As Long

driveType = GetDriveType(Mid(App.Path, 1, 3))

If driveType <> 5 Then

'إنهاء البرنامج ادا كان لا يشتغل من القرص المدمج

End

End If

End Sub

التعامل مع النماذج جعل الفورم في المقدمة

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

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, ByVal wFlags As Long) As Long

Private Const SWP_NOMOVE = 2

Private Const SWP_NOSIZE = 1

Private Const HWND_TOPMOST = -1

Private Const HWND_NOTOPMOST = -2

Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean)

Dim lR As Long

If bSetOnTop Then

lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

Else

lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

End If

End Sub

Private Sub Form_Load()

SetOnTop Form1.hwnd, True

End Sub

إبطال مفعول زر × في النافدة

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

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

Cancel = True

End Sub

إلغاء تفعيل زر الإغلاق في أعلى النافدة

ضع هدا الكود في الموديول

Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Public Const MF_BYPOSITION = &H400&

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

Public Sub DisableCloseWindowButton(frm As Form)

Dim hSysMenu As Long

'Get the handle to this windows system menu

hSysMenu = GetSystemMenu(frm.hwnd, 0)

'Remove the Close menu item This will also disable the close button

RemoveMenu hSysMenu, 6, MF_BYPOSITION

'Lastly, we remove the seperator bar

RemoveMenu hSysMenu, 5, MF_BYPOSITION

End Sub

Private Sub Form_Load()

DisableCloseWindowButton Me

End Sub

إلغاء تفعيل زر التكبير في أعلى النافدة

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

Option Explicit

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Sub Form_Load()

Const WS_MAXIMIZEBOX = &H10000

Const GWL_STYLE = (-16)

Const SWP_FRAMECHANGED = &H20

Const SWP_NOMOVE = &H2

Const SWP_NOSIZE = &H1

Dim nStyle As Long

nStyle = GetWindowLong(Me.hWnd, GWL_STYLE)

Call SetWindowLong(Me.hWnd, GWL_STYLE, nStyle And Not WS_MAXIMIZEBOX)

SetWindowPos Me.hWnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE

End Sub

كود بسيط لجعل الفورم في المقدمة

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

Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)

Private Sub Form_Load()

Timer1.Interval = 1

End Sub

Private Sub Timer1_Timer()

SetWindowPos Form1.hwnd, -1, 0, 0, 0, 0, 3

End Sub

التعامل المجلدات إنشاء مجلد جديد

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

Private Type SECURITY_ATTRIBUTES

nLength As Long

lpSecurityDeor 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.lpSecurityDeor = 0 'normal level of security

attr.bInheritHandle = 1 'default setting

' Create directory.

rval = CreateDirectory(1., attr)

End Sub

Private Sub Form_Load()

1. = "c:\Abdu"

Command1.Caption = "New Directory"

End Sub

البيانات نقل الملفات

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

Private Sub Command1_Click()

Name "c:\Autoexec.bat" As "D:\Autoexec.bat"

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()

SetAttr "C:\data.txt", vbHidden

SetAttr "C:\data.txt", vbReadOnly

SetAttr "C:\data.txt", vbArchive

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()

Print FileLen("c:\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 Sub Command1_Click()

l "notepad.exe", vbNormalNoFocus

AppActivate ("المفكرة")

SendKeys ("أهلا بك ")

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 SetForegroundWindow Lib "user32" _

(ByVal hWnd As Long) As Long

Public Declare Function l_NotifyIcon Lib "l32" _

Alias "l_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

l_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)

l_NotifyIcon NIM_DELETE, nid

End Sub

تأجيل تنفيذ الكود لفترة معينة

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

Public Sub Delay(HowLong As Date)

TempTime = DateAdd("s", HowLong, Now)

While TempTime > Now

DoEvents

Wend

End Sub

Private Sub Command1_Click()

Delay 5

MsgBox "Test"

End Sub

[gelani]

رائع جداً .

وفقك الله

[محمد عسكر]

السلام عليكم

أخى / talaldc

رائع و جميل

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

تحياتى