Мой Kbyte.Ru
Рассылка Kbyte.Ru
Группы на Kbyte.Ru
Партнеры Kbyte.Ru
Реклама
Сделано руками
Сделано руками
> Исходные коды - Алексей Иванов -

Visual Basic 5.0/6.0 - Разное

Все примеры / Разное

Defence

Автор: Алексей Иванов | добавлено: 06.03.2010, 12:05 | просмотров: 2258 (1+) | комментариев: 0 | рейтинг: *x3
Программа запрещает искать порнографию и не только :-)

Инструкции

'Открываем проет>exe
'Кидаем на форму 2 таймера, 1 метку и 2 текстовых поля
'далее установите
'Form1.Visible = False: Form1.BorderStyle = 0
'Text2.MultiLine = True: Text1.MultiLine = True
'Text2.ScrollBars = 3: Text1.ScrollBars = 3
'Timer2.Interval = 1000: Timer2.Enabled = False
'Timer1.Interval = 99:Timer1.Enabled = True

Код

'КОД МОДУЛЯ:
Option Explicit
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 GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long

Public 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
Global Const HWND_TOPMOST = -1
Global Const HWND_NOTOPMOST = -2
Global Const SWP_NOACTIVATE = &H10
Global Const SWP_SHOWWINDOW = &H40
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Long = 260
Private 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
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function CreateToolhelpSnapshot Lib "Kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlgas As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "Kernel32" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "Kernel32" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long)

Public Function GetCaption(lhWnd As Long) As String
Dim sA As String, lLen As Long
lLen = GetWindowTextLength(lhWnd)
sA = String(lLen, 0)
Call GetWindowText(lhWnd, sA, lLen + 1)
GetCaption = sA
End Function
Public Function DLHFindWin(frm As Form, WinTitle As String, CaseSensitive As Boolean) As Long
Dim lhWnd As Long, sA As String
lhWnd = frm.hwnd
Do
DoEvents
If lhWnd = 0 Then Exit Do
If CaseSensitive = False Then
sA = LCase(GetCaption(lhWnd))
WinTitle = LCase(WinTitle)
Else
sA = GetCaption(lhWnd)
End If
If InStr(sA, WinTitle) Then
DLHFindWin = lhWnd
Exit Do
Else
DLHFindWin = 0
End If
lhWnd = GetNextWindow(lhWnd, 2)
Loop
End Function
Public Function GetExeFromHandle(hwnd As Long) As String
Dim threadID As Long, processID As Long, hSnapshot As Long
Dim uProcess As PROCESSENTRY32, rProcessFound As Long
Dim i As Integer, szExename As String
' Get ID for window thread
threadID = GetWindowThreadProcessId(hwnd, processID)
' Check if valid
If threadID = 0 Or processID = 0 Then Exit Function
' Create snapshot of current processes
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
' Check if snapshot is valid
If hSnapshot = -1 Then Exit Function
'Initialize uProcess with correct size
uProcess.dwSize = Len(uProcess)
'Start looping through processes
rProcessFound = ProcessFirst(hSnapshot, uProcess)
Do While rProcessFound
If uProcess.th32ProcessID = processID Then
'Found it, now get name of exefile
i = InStr(1, uProcess.szexeFile, Chr(0))
If i > 0 Then szExename = Left$(uProcess.szexeFile, i - 1)
Exit Do
Else
'Wrong ID, so continue looping
rProcessFound = ProcessNext(hSnapshot, uProcess)
End If
Loop
Call CloseHandle(hSnapshot)
GetExeFromHandle = szExename
End Function

'КОД ФОРМЫ:
'Автор: Иванов Алексей
'http://vbrus.narod.ru

Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const EM_GETLINECOUNT = &HBA
Dim M(500) As String
Dim i, j, v As Integer
Dim yes As Boolean
Dim lngLineCount As Integer
Dim lngLineCount1 As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
Const EM_LINEINDEX = &HBB
Const EM_LINELENGTH = &HC1
Const EM_GETLINE = &HC4

Public Function GetLine(hwnd As Long, Line As Long) As String
Dim sBuf As String, nLen As Long, nIndex As Long
nIndex = SendMessage(hwnd, EM_LINEINDEX, Line - 1, ByVal 0&)
If nIndex < 0 Or Line <= 0 Then Exit Function
nLen = SendMessage(hwnd, EM_LINELENGTH, nIndex, ByVal 0&)
sBuf = Space(nLen + 1)
Mid$(sBuf, 1, 1) = Chr$(nLen And &HFF)
Mid$(sBuf, 2, 1) = Chr$(nLen \ 256)
SendMessage hwnd, EM_GETLINE, Line - 1, ByVal sBuf
GetLine = Left$(sBuf, nLen)
End Function


Private Sub Form_Load()
On Error Resume Next
If App.PrevInstance = True Then
MsgBox "Программа уже запущена", 64, "Defence"
End
End If

Dim FN As Integer
Dim FName As String
FN = FreeFile
FName = App.Path + "\data.dat"
Open FName For Input As #FN
Text1.Text = Input(LOF(FN), #FN)
Close #FN
FN = FreeFile
FName = App.Path + "\data1.dat"
Open FName For Input As #FN
Text2.Text = Input(LOF(FN), #FN)
Close #FN
lngLineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
lngLineCount1 = SendMessageLong(Text2.hwnd, EM_GETLINECOUNT, 0&, 0&)
If Text1.Text = "" Then
MsgBox "&#215;&#184;&#240;&#237;&#251;&#233; &#241;&#239;&#232;&#241;&#238;&#234; &#239;&#243;&#241;&#242;!", 64, "&#200;&#237;&#244;&#238;&#240;&#236;&#224;&#246;&#232;&#255;"
End
End If
Dim j As Integer
For j = 1 To lngLineCount
Label1.Caption = j
M(Label1.Caption) = GetLine(Text1.hwnd, Label1.Caption)
Next j
End Sub

Private Sub Timer1_Timer()
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW
For i = 1 To lngLineCount
s = (GetExeFromHandle(DLHFindWin(Me, M(i), False)))
yes = False
If s <> "" Then
If Text2.Text <> "" Then
  For v = 1 To lngLineCount1
  Label1.Caption = v
  If LCase(s) = LCase(GetLine(Text2.hwnd, Label1.Caption)) Then yes = True
  Next v
End If
  If yes = False Then
  Shell "Cmd /x/c taskkill /f /im " + s, vbvhite
  If LCase(s) = "explorer.exe" Then Timer2.Enabled = True
  End If
End If
Next i
End Sub

Private Sub Timer2_Timer()
Shell ("explorer.exe")
Timer2.Enabled = False
End Sub
Файлы defence.zip (12,74 Кб)
Обратите внимание
Язык Visual Basic 6.0 является устаревшим. Многие примеры, размещенные на нашем сайте, были созданы еще во времена Windows 98 и могут не работать в современных операционных системах.
Если у вас возникнут какие-либо проблемы или вопросы, вы можете обратиться за помощью на наш форум.
Об авторе

Алексей Иванов

Нет информации об авторе...

См. также:
Профиль автора
Алексей Иванов
Последние комментарии (всего: 0)

Добавлять комментарии могут только зарегистрированные пользователи сайта.
Если у Вас уже есть учетная запись на Kbyte.Ru, пройдите процедуру авторизации OpenID.
Если Вы еще не зарегистрированы на Kbyte.Ru - зарегистрируйтесь.


Нет комментариев...

Авторизация
 
OpenID
Зарегистрируйся и получи 10% скидку на добавление своего сайта в каталоги! Подробнее »
Поиск по сайту
Реклама
Счетчики