ali_1234
جمعه 06 فروردین 1389, 11:06 صبح
سلام دوستان من در حال نوشتن یه برنامه هستم امروز وقتی ازش exe گرفتم کاسپر به من اخطار داد که ممکن است این برنامه یک keylogger باشه من کدها رو براتون می زارم امیدوارم بتونید کمکم کنید. با تشکر...........................:قلب:
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const SW_SHOWNORMAL As Long = 1
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function PostMessage _
Lib "user32" _
Alias "PostMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDOWN = &H201
Dim intIndex As Integer
Private ArrWord() As String, ArrMeaning() As String
Private getWord As String, getMeaning As String
Private isArrChanged As Boolean, isTxtChanging As Boolean
Private isTop As Boolean
Private Const EM_UNDO = &HC7
Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Private Sub AGP2_PopUpClick(ByVal ItemName As String)
If ItemName = "mnup" Then
If Clipboard.GetFormat(vbCFText) = True Then
TextBoxX1.SelText = Clipboard.GetText(vbCFText)
End If
End If
End Sub
Private Sub Form_Load()
Form1.Text1.RightToLeft = True
Form1.List1.RightToLeft = True
Form1.TextBoxX1.RightToLeft = True
LoadKeyboardLayout "00000429", 1
ReadLanguageOnForms
Dim font As String
font = ReadIniFile(App.Path & "\LNG.ini", "font", "font", "")
If font = "Tahoma" Then
List1.font = "Tahoma"
Text1.font = "Tahoma"
End If
If font = "Arial" Then
List1.font = "Arial"
Text1.font = "Arial"
End If
ReadLanguageOnForms
Dim fontstyl As String
fontstyl = ReadIniFile(App.Path & "\LNG.ini", "fontstyl", "fontstyl", "")
If fontstyl = "Bold" Then
Form1.List1.FontBold = True
Form1.Text1.FontBold = True
Form1.List1.FontItalic = False
Form1.Text1.FontItalic = False
End If
If fontstyl = "Italic" Then
Form1.List1.FontItalic = True
Form1.Text1.FontItalic = True
Form1.List1.FontBold = False
Form1.Text1.FontBold = False
End If
If fontstyl = "reg" Then
Form1.List1.FontItalic = False
Form1.Text1.FontItalic = False
Form1.List1.FontBold = False
Form1.Text1.FontBold = False
End If
Dim Y As Byte, i As Integer
Dim getDays As Variant, getMonths As Variant
isArrChanged = False
ReDim ArrWord(0)
ReDim ArrMeaning(0)
Open App.Path & "\sdb.db" For Input As #1
Do While Not EOF(1)
Input #1, getMeaning, getWord
ArrWord(UBound(ArrWord)) = getWord
ArrMeaning(UBound(ArrMeaning)) = getMeaning
ReDim Preserve ArrWord(UBound(ArrWord) + 1)
ReDim Preserve ArrMeaning(UBound(ArrMeaning) + 1)
If getWord = "" Then Exit Do
List1.AddItem getWord
Text1.Text = getMeaning
Loop
Close #1
If List1.ListCount > 0 Then TextBoxX1.Text = List1.List(0)
If UBound(ArrWord) > 0 Then
ReDim Preserve ArrWord(UBound(ArrWord) - 1)
ReDim Preserve ArrMeaning(UBound(ArrMeaning) - 1)
End If
End Sub
Private Sub List1_Click()
If List1.ListCount <= 0 Then Exit Sub
If isTxtChanging = True Then
TextBoxX1.Text = Left(List1.List(List1.ListIndex), Len(Trim(TextBoxX1.Text)))
Else
TextBoxX1.Text = List1.List(List1.ListIndex)
TextBoxX1.SelStart = 0
TextBoxX1.SelLength = Len(Trim(TextBoxX1.Text))
End If
Dim a As String
Dim B, c As String
c = Text1.MultiLine = True
B = List1.Text
isTxtChanging = False
Text1.Text = B + ":" + vbCrLf + ArrMeaning(List1.ListIndex)
TextBoxX1.ForeColor = vbBlack
End Sub
Private Sub List1_DblClick()
B = Text1.Text
dbclickfrm.Show
dbclickfrm.Text1.Text = B
End Sub
Private Sub List1_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
On Error Resume Next
If Button = 2 Then
p.ShowPopUp
PostMessage List1.hwnd, WM_LBUTTONDOWN, 0, 2&
Timer2.Interval = 1
End If
End Sub
Private Sub p_PopUpClick(ByVal ItemName As String)
If ItemName = "mnucopy" Then
If List1 <> "" Then
Clipboard.Clear
Clipboard.SetText List1
End If
End If
End Sub
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Button = 2 Then
text1pup.ShowPopUp
End If
End Sub
Private Sub text1pup_PopUpClick(ByVal ItemName As String)
If ItemName = "mnucop" Then
If Text1.Text <> "" Then
Clipboard.Clear
Clipboard.SetText Text1.Text
End If
End If
End Sub
Private Sub TextBoxX1_Change()
Dim i As Integer
isTxtChanging = True
If List1.ListCount <= 0 Then Exit Sub
For i = 0 To List1.ListCount - 1
If UCase(Trim(TextBoxX1.Text)) = UCase(Left(List1.List(i), Len(Trim(TextBoxX1.Text)))) Then
List1.ListIndex = i
Exit For
End If
Next
End Sub
Private Sub TextboxX1_GotFocus()
TextBoxX1.Text = ""
TextBoxX1.ForeColor = vbBlack
End Sub
Private Sub TextBoxX1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Button = 2 Then
AGP2.ShowPopUp
End If
End Sub
Private Sub Timer1_Timer()
If GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyC) Then
If Text1.SelText <> "" Then
Clipboard.Clear
Clipboard.SetText Text1.SelText
End If
If List1 <> "" Then
Clipboard.Clear
Clipboard.SetText List1
End If
End If
If GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyV) Then
If Clipboard.GetFormat(vbCFText) = True Then
Exit Sub
TextBoxX1.SelText = Clipboard.GetText(vbCFText)
End If
End If
If GetAsyncKeyState(vbKeyF1) Then
End If
End Sub
Private Sub Timer2_Timer()
On Error Resume Next
intIndex = List1.ListIndex
PostMessage List1.hwnd, WM_LBUTTONUP, 0, 2&
List1.ListIndex = intIndex
Timer2.Interval = 0
End Sub
Private Sub Timer3_Timer()
If GetMouseOver(Me.hwnd) = True Then
Label4 = "Yes"
Label4.ForeColor = vbBlue
Else
Label4 = "No"
Label4.ForeColor = vbRed
End If
End Sub
Public Function GetMouseOver(hwnd As Long) As Boolean
Dim wRect As RECT
Dim Mouse As POINTAPI
GetCursorPos Mouse
GetWindowRect hwnd, wRect
If (Mouse.x <= wRect.Right And Mouse.x >= wRect.Left) And (Mouse.Y <= wRect.Bottom And Mouse.Y >= wRect.Top) Then
GetMouseOver = True
Else
GetMouseOver = False
End If
End Function
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const SW_SHOWNORMAL As Long = 1
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function PostMessage _
Lib "user32" _
Alias "PostMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const WM_LBUTTONUP = &H202
Private Const WM_LBUTTONDOWN = &H201
Dim intIndex As Integer
Private ArrWord() As String, ArrMeaning() As String
Private getWord As String, getMeaning As String
Private isArrChanged As Boolean, isTxtChanging As Boolean
Private isTop As Boolean
Private Const EM_UNDO = &HC7
Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long
Private Sub AGP2_PopUpClick(ByVal ItemName As String)
If ItemName = "mnup" Then
If Clipboard.GetFormat(vbCFText) = True Then
TextBoxX1.SelText = Clipboard.GetText(vbCFText)
End If
End If
End Sub
Private Sub Form_Load()
Form1.Text1.RightToLeft = True
Form1.List1.RightToLeft = True
Form1.TextBoxX1.RightToLeft = True
LoadKeyboardLayout "00000429", 1
ReadLanguageOnForms
Dim font As String
font = ReadIniFile(App.Path & "\LNG.ini", "font", "font", "")
If font = "Tahoma" Then
List1.font = "Tahoma"
Text1.font = "Tahoma"
End If
If font = "Arial" Then
List1.font = "Arial"
Text1.font = "Arial"
End If
ReadLanguageOnForms
Dim fontstyl As String
fontstyl = ReadIniFile(App.Path & "\LNG.ini", "fontstyl", "fontstyl", "")
If fontstyl = "Bold" Then
Form1.List1.FontBold = True
Form1.Text1.FontBold = True
Form1.List1.FontItalic = False
Form1.Text1.FontItalic = False
End If
If fontstyl = "Italic" Then
Form1.List1.FontItalic = True
Form1.Text1.FontItalic = True
Form1.List1.FontBold = False
Form1.Text1.FontBold = False
End If
If fontstyl = "reg" Then
Form1.List1.FontItalic = False
Form1.Text1.FontItalic = False
Form1.List1.FontBold = False
Form1.Text1.FontBold = False
End If
Dim Y As Byte, i As Integer
Dim getDays As Variant, getMonths As Variant
isArrChanged = False
ReDim ArrWord(0)
ReDim ArrMeaning(0)
Open App.Path & "\sdb.db" For Input As #1
Do While Not EOF(1)
Input #1, getMeaning, getWord
ArrWord(UBound(ArrWord)) = getWord
ArrMeaning(UBound(ArrMeaning)) = getMeaning
ReDim Preserve ArrWord(UBound(ArrWord) + 1)
ReDim Preserve ArrMeaning(UBound(ArrMeaning) + 1)
If getWord = "" Then Exit Do
List1.AddItem getWord
Text1.Text = getMeaning
Loop
Close #1
If List1.ListCount > 0 Then TextBoxX1.Text = List1.List(0)
If UBound(ArrWord) > 0 Then
ReDim Preserve ArrWord(UBound(ArrWord) - 1)
ReDim Preserve ArrMeaning(UBound(ArrMeaning) - 1)
End If
End Sub
Private Sub List1_Click()
If List1.ListCount <= 0 Then Exit Sub
If isTxtChanging = True Then
TextBoxX1.Text = Left(List1.List(List1.ListIndex), Len(Trim(TextBoxX1.Text)))
Else
TextBoxX1.Text = List1.List(List1.ListIndex)
TextBoxX1.SelStart = 0
TextBoxX1.SelLength = Len(Trim(TextBoxX1.Text))
End If
Dim a As String
Dim B, c As String
c = Text1.MultiLine = True
B = List1.Text
isTxtChanging = False
Text1.Text = B + ":" + vbCrLf + ArrMeaning(List1.ListIndex)
TextBoxX1.ForeColor = vbBlack
End Sub
Private Sub List1_DblClick()
B = Text1.Text
dbclickfrm.Show
dbclickfrm.Text1.Text = B
End Sub
Private Sub List1_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
On Error Resume Next
If Button = 2 Then
p.ShowPopUp
PostMessage List1.hwnd, WM_LBUTTONDOWN, 0, 2&
Timer2.Interval = 1
End If
End Sub
Private Sub p_PopUpClick(ByVal ItemName As String)
If ItemName = "mnucopy" Then
If List1 <> "" Then
Clipboard.Clear
Clipboard.SetText List1
End If
End If
End Sub
Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Button = 2 Then
text1pup.ShowPopUp
End If
End Sub
Private Sub text1pup_PopUpClick(ByVal ItemName As String)
If ItemName = "mnucop" Then
If Text1.Text <> "" Then
Clipboard.Clear
Clipboard.SetText Text1.Text
End If
End If
End Sub
Private Sub TextBoxX1_Change()
Dim i As Integer
isTxtChanging = True
If List1.ListCount <= 0 Then Exit Sub
For i = 0 To List1.ListCount - 1
If UCase(Trim(TextBoxX1.Text)) = UCase(Left(List1.List(i), Len(Trim(TextBoxX1.Text)))) Then
List1.ListIndex = i
Exit For
End If
Next
End Sub
Private Sub TextboxX1_GotFocus()
TextBoxX1.Text = ""
TextBoxX1.ForeColor = vbBlack
End Sub
Private Sub TextBoxX1_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
If Button = 2 Then
AGP2.ShowPopUp
End If
End Sub
Private Sub Timer1_Timer()
If GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyC) Then
If Text1.SelText <> "" Then
Clipboard.Clear
Clipboard.SetText Text1.SelText
End If
If List1 <> "" Then
Clipboard.Clear
Clipboard.SetText List1
End If
End If
If GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyV) Then
If Clipboard.GetFormat(vbCFText) = True Then
Exit Sub
TextBoxX1.SelText = Clipboard.GetText(vbCFText)
End If
End If
If GetAsyncKeyState(vbKeyF1) Then
End If
End Sub
Private Sub Timer2_Timer()
On Error Resume Next
intIndex = List1.ListIndex
PostMessage List1.hwnd, WM_LBUTTONUP, 0, 2&
List1.ListIndex = intIndex
Timer2.Interval = 0
End Sub
Private Sub Timer3_Timer()
If GetMouseOver(Me.hwnd) = True Then
Label4 = "Yes"
Label4.ForeColor = vbBlue
Else
Label4 = "No"
Label4.ForeColor = vbRed
End If
End Sub
Public Function GetMouseOver(hwnd As Long) As Boolean
Dim wRect As RECT
Dim Mouse As POINTAPI
GetCursorPos Mouse
GetWindowRect hwnd, wRect
If (Mouse.x <= wRect.Right And Mouse.x >= wRect.Left) And (Mouse.Y <= wRect.Bottom And Mouse.Y >= wRect.Top) Then
GetMouseOver = True
Else
GetMouseOver = False
End If
End Function