بهترين سورسهاي ويژوال بيسيك 6

[VisualBasic6Love]

سلام دوستان
با اين كد ميتوانيد دكمه هاي ماوس رو جابجا كنيد اول دو تا كامند باتن به فرم اضافه كنيد و خاصيت (Name) اولي رو به (cmdswap) تغيير بديد و سپس دومي رو به (cmdunswap) تغيير بديد و بعد روي دكمه (View Code) كليك كنيد و كدها رو وارد كنيد:

کد:

'Programming By : VisualBasic6Love
Private Declare Function SwapMouseButton& Lib "user32" (ByVal bSwap As Long)
Private Sub cmdswap_Click()
SwapMouseButton (True)
End Sub
Private Sub cmdunswap_Click()
SwapMouseButton (False)
End Sub

[VisualBasic6Love]

سلام دوستان
اين كد فضاي خالي درايوها رو نشون ميده:

کد:

'Programming By : VisualBasic6Love
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Private Sub Form_Load()
    Dim Sectors As Long, Bytes As Long, FreeC As Long, TotalC As Long, Total As Long, Freeb As Long
    'Retrieve information about the C:\
    GetDiskFreeSpace "C:\", Sectors, Bytes, FreeC, TotalC
    'Set graphic mode to persistent
    Me.AutoRedraw = True
    'Print the information to the form
    Me.Print " Path: C:\"
    Me.Print " Sectors per Cluster:" + Str$(Sector)
    Me.Print " Bytes per sector:" + Str$(Bytes)
    Me.Print " Number Of Free Clusters:" + Str$(FreeC)
    Me.Print " Total Number Of Clusters:" + Str$(TotalC)
    Total = rTotalc& * rSector& * rBytes&
    Me.Print " Total number of bytes in path:" + Str$(Total)
    Freeb = rFreec& * rSector& * rBytes&
    Me.Print " Free bytes:" + Str$(Freeb)
End Sub

[VisualBasic6Love]

سلام دوستان
همچنان كه براي اين تاپيك ارزش قائل ميشيد ممنونم!
ولي بد نيست كه بقيه دوستان هم براي به روز كردن مطالب مفيد اين تاپيك كمك كنند!
يك سوال : چطور ميشه رزولوشن صفحه نمايش رو تغيير داد؟
جواب : با اين كدي كه در اينجا قرار ميدم ميشه اينكار رو به راحتي انجام داد:

کد:

'Programming By : VisualBasic6Love
Option Explicit
Const WM_DISPLAYCHANGE = &H7E
Const HWND_BROADCAST = &HFFFF&
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_BITSPERPEL = &H40000
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000
Const CDS_UPDATEREGISTRY = &H1
Const CDS_TEST = &H4
Const DISP_CHANGE_SUCCESSFUL = 0
Const DISP_CHANGE_RESTART = 1
Const BITSPIXEL = 12
Private Type DEVMODE
    dmDeviceName As String * CCDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long
Private Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
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
Dim OldX As Long, OldY As Long, nDC As Long
Sub ChangeRes(X As Long, Y As Long, Bits As Long)
    Dim DevM As DEVMODE, ScInfo As Long, erg As Long, an As VbMsgBoxResult
    'Get the info into DevM
    erg = EnumDisplaySettings(0&, 0&, DevM)
    'This is what we're going to change
    DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT Or DM_BITSPERPEL
    DevM.dmPelsWidth = X 'ScreenWidth
    DevM.dmPelsHeight = Y 'ScreenHeight
    DevM.dmBitsPerPel = Bits '(can be 8, 16, 24, 32 or even 4)
    'Now change the display and check if possible
    erg = ChangeDisplaySettings(DevM, CDS_TEST)
    'Check if succesfull
    Select Case erg&
        Case DISP_CHANGE_RESTART
            an = MsgBox("You've to reboot", vbYesNo + vbSystemModal, "Info")
            If an = vbYes Then
                erg& = ExitWindowsEx(EWX_REBOOT, 0&)
            End If
        Case DISP_CHANGE_SUCCESSFUL
            erg = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
            ScInfo = Y * 2 ^ 16 + X
            'Notify all the windows of the screen resolution change
            SendMessage HWND_BROADCAST, WM_DISPLAYCHANGE, ByVal Bits, ByVal ScInfo
            MsgBox "Everything's ok", vbOKOnly + vbSystemModal, "It worked!"
        Case Else
            MsgBox "Mode not supported", vbOKOnly + vbSystemModal, "Error"
    End Select
End Sub
Private Sub Form_Load()
    Dim nDC As Long
    'retrieve the screen's resolution
    OldX = Screen.Width / Screen.TwipsPerPixelX
    OldY = Screen.Height / Screen.TwipsPerPixelY
    'Create a device context, compatible with the screen
    nDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
    'Change the screen's resolution
    ChangeRes 640, 480, GetDeviceCaps(nDC, BITSPIXEL)
End Sub
Private Sub Form_Unload(Cancel As Integer)
    'restore the screen resolution
    ChangeRes OldX, OldY, GetDeviceCaps(nDC, BITSPIXEL)
    'delete our device context
    DeleteDC nDC
End Sub

[VisualBasic6Love]

عنوان: (Text Effect)

کد:

'Example By : VisualBasic6Love
Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function SetTextCharacterExtra Lib "gdi32" _
(ByVal hdc As Long, ByVal nCharExtra As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function OffsetRect Lib "user32" (lpRect _
As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc _
As Long, ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As _
Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal _
crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal _
hObject As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal _
nIndex As Long) As Long
Private Const COLOR_BTNFACE = 15
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" _
(ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal _
lpString As String, ByVal nCount As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" _
(ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_CHARSTREAM = 4 ' Character-stream, PLP
Private Const DT_DISPFILE = 6 ' Display-file
Private Const DT_EXPANDTABS = &H40
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_INTERNAL = &H1000
Private Const DT_LEFT = &H0
Private Const DT_METAFILE = 5 ' Metafile, VDM
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_PLOTTER = 0 ' Vector plotter
Private Const DT_RASCAMERA = 3 ' Raster camera
Private Const DT_RASDISPLAY = 1 ' Raster display
Private Const DT_RASPRINTER = 2 ' Raster printer
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTOP = &H80
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10
Private Declare Function OleTranslateColor Lib "olepro32.dll" _
(ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1
Public Sub TextEffect(obj As Object, ByVal sText As String, _
ByVal lX As Long, ByVal lY As Long, Optional ByVal bLoop _
As Boolean = False, Optional ByVal lStartSpacing As Long = 128, _
Optional ByVal lEndSpacing As Long = -1, Optional ByVal oColor _
As OLE_COLOR = vbWindowText)
Dim lhDC As Long
Dim i As Long
Dim x As Long
Dim lLen As Long
Dim hBrush As Long
Static tR As RECT
Dim iDir As Long
Dim bNotFirstTime As Boolean
Dim lTime As Long
Dim lIter As Long
Dim bSlowDown As Boolean
Dim lCOlor As Long
Dim bDoIt As Boolean
lhDC = obj.hdc
iDir = -1
i = lStartSpacing
tR.Left = lX: tR.Top = lY: tR.Right = lX: tR.Bottom = lY
OleTranslateColor oColor, 0, lCOlor
hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
lLen = Len(sText)
SetTextColor lhDC, lCOlor
bDoIt = True
Do While bDoIt
lTime = timeGetTime
If (i < -3) And Not (bLoop) And Not (bSlowDown) Then
bSlowDown = True
iDir = 1
lIter = (i + 4)
End If
If (i > 128) Then iDir = -1
If Not (bLoop) And iDir = 1 Then
If (i = lEndSpacing) Then
' Stop
bDoIt = False
Else
lIter = lIter - 1
If (lIter <= 0) Then
i = i + iDir
lIter = (i + 4)
End If
End If
Else
i = i + iDir
End If
FillRect lhDC, tR, hBrush
x = 32 - (i * lLen)
SetTextCharacterExtra lhDC, i
DrawText lhDC, sText, lLen, tR, DT_CALCRECT
tR.Right = tR.Right + 4
If (tR.Right > obj.ScaleWidth \ Screen.TwipsPerPixelX) Then _
tR.Right = obj.ScaleWidth \ Screen.TwipsPerPixelX
DrawText lhDC, sText, lLen, tR, DT_LEFT
obj.Refresh
Do
DoEvents
If obj.Visible = False Then Exit Sub
Loop While (timeGetTime - lTime) < 20
Loop
DeleteObject hBrush
End Sub
Private Sub Command1_Click()
Me.ScaleMode = vbTwips
Me.AutoRedraw = True
Call TextEffect(Me, "VisualBasic6Love", 24, 24, False, 256)
End Sub

[yeketaz]

تغییر نام منوی Start

یک TextBox و یک CommandButton به فرم اضافه کرده و کدهای قبلی را پاک و کدهای زیر را جایگزین کنید

کد:

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 SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As RECT, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Sub Command1_Click()
Dim h As Long
h = FindWindow("Shell_TrayWnd", vbNullString)
h = FindWindowEx(h, 0, "Button", vbNullString)
SetWindowText h, Text1.Text
Dim Recttype As RECT
RedrawWindow h, Recttype, 1, 1
End Sub

[vz67]

غیر فعال و فعال کردن تمام کنترلهای روی یک فرم
یک checkbox به نام Check1 روی فرم قرار بدین
بعد , هرچی می تونید کنترل توی فرم بزاری
و حالا کد زیر رو باید وارد کنید

کد:

Private Sub Check1_Click()
    Dim obj As Object 'or Control
    For Each obj In Me.Controls
        If obj.Name <> Check1.Name Then obj.Enabled = Check1.Value
    Next
End Sub

[xsalamx]

سلام

شیشه ای(شفاف کردن) کردن فرم
یک HScroll1 که خاصیت max,min,value رو به صورت زیر تغییر بدید
max=255
min=0
value=255

کد:

Option Explicit
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags 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
Public Function TranslucentForm(frm As Form, TranslucenceLevel As Byte) As Boolean
SetWindowLong frm.hwnd, GWL_EXSTYLE, WS_EX_LAYERED
SetLayeredWindowAttributes frm.hwnd, 0, TranslucenceLevel, LWA_ALPHA
TranslucentForm = Err.LastDllError = 0
End Function
Private Sub HScroll1_Change()
TranslucentForm Me, HScroll1.Value
End Sub

البته شما می تونید مقدار رو به جای اینکه مثل بالا با hscroll تغییر بدید توی فرم لود مقدار رو بدید

کد:

Private Sub Form_Load()
TranslucentForm Me, 200
End Sub

منبع : یادم رفته

---

always on کردن فرم
کد برای ماژول

کد:

Option Explicit
Public Const SWP_NOMOVE = 2
Public Const SWP_NOSIZE = 1
Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
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
Public Function SetTopMostWindow(hwnd As Long, Topmost As Boolean) _
As Long
If Topmost = True Then 'Make the window topmost
SetTopMostWindow = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
Else
SetTopMostWindow = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS)
SetTopMostWindow = False
End If
End Function

برای فرم

کد:

Private Sub Form_Load()
Dim lR1 As Long
lR = SetTopMostWindow(Form1.hwnd, True)
Dim rgn As Long
Me.ScaleMode = vbPixels
End Sub

منبع : اینم منبعش یادم نمی یاد

[yeketaz]

تغییر تیتر پنجره فعال
مواد مورد نیاز :

یک عدد Timer
یک عدد TextBox

پس مخلوط کردن مواد بالا،چاشنی ها زیر را اضافه می کنیم :

کد:

Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Sub Timer1_Timer()
SetWindowText GetForegroundWindow(), Text1.Text
End Sub

نکات مهم :

تایمر باید فعال و interval آن بهتر است روی 1 قرار بگیرد
هنگام وارد کردن متن برای تیتر پنجره ها تیتر خوده برنامه نیز تغییر می کند
اما با تغییر پنجره فعال متن موجود در تکس باکس در آن پنجره ها نیز اعمال می شود

================================================
ShutDown و Restart و Log Off کردن کامپیوتر
این تابع با ارسال هدف و زمان اعمال دستور بر حسب ثانیه دستورات را اجرا میکند

کد:

Enum ShutUser
ShutDown = 0
Restart = 1
LogOff = 2
End Enum
Private Sub SComputer(ShutSort As ShutUser, Second As Integer)
Select Case ShutSort
Case 0
Shell "shutdown -s -t " + Str(Second), vbHide
Case 1
Shell "shutdown -r -t " + Str(Second), vbHide
Case 2
Shell "shutdown -l -t " + Str(Second), vbHide
End Select
End Sub

================================================
پیدا کردن آدرس فولدرهای مهم :
دیگه با این کد نیازی به تعریف تابع های متعدد برای پیدا کردن هریک از فولدرها نیست

کد:

Enum CSIDLFoldersSys
    CSIDL_DESKTOP = &H0
    CSIDL_PROGRAMS = &H2
    CSIDL_PRINTERS = &H4
    CSIDL_PERSONAL = &H5
    CSIDL_FAVORITES = &H6
    CSIDL_STARTUP = &H7
    CSIDL_RECENT = &H8
    CSIDL_SENDTO = &H9
    CSIDL_STARTMENU = &HB
    CSIDL_MYMUSIC = &HD
    CSIDL_MYVIDEOS = &HE
    CSIDL_DESKTOPDIRECTORY = &H10
    CSIDL_MYCOMPUTER = &H11
    CSIDL_NETWORKNEIGHBORHOOD = &H12
    CSIDL_NETHOOD = &H13
    CSIDL_FONTS = &H14
    CSIDL_TEMPLATES = &H15
    CSIDL_COMMON_STARTMENU = &H16
    CSIDL_COMMON_PROGRAMS = &H17
    CSIDL_COMMON_STARTUP = &H18
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19
    CSIDL_APPDATA = &H1A
    CSIDL_PRINTHOOD = &H1B
    CSIDL_LOCAL_APPDATA = &H1C
    CSIDL_COMMON_FAVORITES = &H1F
    CSIDL_TEMPORARY_INTERNET_FILES = &H20
    CSIDL_COOKIES = &H21
    CSIDL_HISTORY = &H22
    CSIDL_COMMON_APPDATA = &H23
    CSIDL_WINDOWS = &H24
    CSIDL_SYSTEM = &H25
    CSIDL_PROGRAM_FILES = &H26
    CSIDL_MYPICTURES = &H27
    CSIDL_PROFILE = &H28
    CSIDL_PROGRAM_FILES_COMMON = &H2B
    CSIDL_COMMON_TEMPLATES = &H2D
    CSIDL_COMMON_DOCUMENTS = &H2E
    CSIDL_COMMON_ADMINTOOLS = &H2F
    CSIDL_NETANDDIAlUpCONNECTIONS = &H31
    CSIDL_COMMON_MYMUSIC = &H35
    CSIDL_COMMON_MYPICTURES = &H36
    CSIDL_RESOURCES = &H38
    CSIDL_CDBURNING = &H3B
End Enum
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" ( _
                    ByVal hwnd As Long, _
                    ByVal nFolder As Long, _
                    ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" ( _
                    ByVal Pidl As Long, _
                    ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
Private Function GetPathSysFolder(ByVal FolderId As CSIDLFoldersSys) As String
        On Error Resume Next
Const MAX_PATH = 260
Const NOERROR = 0
Dim lngPidlFound As Long
Dim FolderIdFound As Long
Dim lngPidl As Long
Dim strPath As String
strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, CLng(FolderId), lngPidl)
If lngPidlFound = NOERROR Then
FolderIdFound = SHGetPathFromIDList(lngPidl, strPath)
If FolderIdFound Then
GetPathSysFolder = Left$(strPath, InStr(1, strPath, vbNullChar) - 1)
End If
End If
CoTaskMemFree lngPidl
End Function

[xsalamx]

سلام

تغییر زبان
دوتا تکست باکس رو فرم بزارید تا با این کد توی تکست 1 انگلیسی تایپ کنید و توی تکست 2 فارسی
کد ماژول

کد:

Public Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long

کد فرم

کد:

Private Sub Text1_GotFocus()
LoadKeyboardLayout "00000429", 1 ' 00000429 :::::> For Farsi Keyboard
End Sub
Private Sub Text2_GotFocus()
LoadKeyboardLayout "00000409", 1 ' 00000429 :::::> For òEnglish Keyboard
End Sub

---

سلام

دایره کردن فرم

کد:

Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "User32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Sub Form_Load()
SetWindowRgn hWnd, CreateEllipticRgn(0, 0, 400, 400), True
End Sub

[xsalamx]

سلام

درگ کردن فرم

کد:

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 ReleaseCapture Lib "User32" ()
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lngReturnValue As Long
If Button = 1 Then
Call ReleaseCapture
lngReturnValue = SendMessage(Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub

[VisualBasic6Love]

سلام دوستان
ببخشيد كه يه چند روزي نبودم كه تاپيك رو به روز كنم!
از همه ي دوستاني كه در به روز كردن تاپيك كمك كردند هم سپاسگذارم!
خوب امروز براتون يه كد آوردم كه مثل برنامه هاي كيلاگر كليدهاي صفحه كليد رو ثبت ميكنه البته به صورت ساده و ابتدايي اين كار رو انجام ميده و كارش هم اينطوريه كه وقتي برنامه رو اجرا كرديد بر روي صفحه كليد كليدهايي رو بزنيد و بعد برنامه رو ببنديد كه در همين لحضه در يك MsgBox كليدهايي رو كه زديد نشون ميده. (البته اگه خودتون روش كار كنيد ميتونيد مدلهاي بهتري بنويسيد منم اگه وقت كردم كيلاگرهاي پيشرفته تري براتون مينويسم.)
روش ساخت :
1-ابتدا وي بي 6 رو اجرا كنيد.
2-يك پروژه جديد شامل يك فرم و يك ماژول ايجاد كنيد.
و كدهاي زير رو وارد كنيد:
كدها در ماژول:

کد:

'Example By : VisualBasic6Love
Public Const DT_CENTER = &H1
Public Const DT_WORDBREAK = &H10
Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDrawTextParams As Any) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Global Cnt As Long, sSave As String, sOld As String, Ret As String
Dim Tel As Long
Function GetPressedKey() As String
    For Cnt = 32 To 128
        'Get the keystate of a specified key
        If GetAsyncKeyState(Cnt) <> 0 Then
            GetPressedKey = Chr$(Cnt)
            Exit For
        End If
    Next Cnt
End Function
Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    Ret = GetPressedKey
    If Ret <> sOld Then
        sOld = Ret
        sSave = sSave + sOld
    End If
End Sub

كدها در قسمت (General) :

کد:

'Example By : VisualBasic6Love
Private Sub Form_Load()
    Me.Caption = "Key Spy"
    'Create an API-timer
    SetTimer Me.hwnd, 0, 1, AddressOf TimerProc
End Sub
Private Sub Form_Paint()
    Dim R As RECT
    Const mStr = "Start this project, go to another application, type something, switch back to this application and unload the form. If you unload the form, a messagebox with all the typed keys will be shown.                                                                                                                                                                                                                                                                                   (Example By : VisualBasic6Love)"
    'Clear the form
    Me.Cls
    'API uses pixels
    Me.ScaleMode = vbPixels
    'Set the rectangle's values
    SetRect R, 0, 0, Me.ScaleWidth, Me.ScaleHeight
    'Draw the text on the form
    DrawTextEx Me.hDC, mStr, Len(mStr), R, DT_WORDBREAK Or DT_CENTER, ByVal 0&
End Sub
Private Sub Form_Resize()
    Form_Paint
End Sub
Private Sub Form_Unload(Cancel As Integer)
    'Kill our API-timer
    KillTimer Me.hwnd, 0
    'Show all the typed keys
    MsgBox sSave
End Sub