Protection parental (fermeture de fenetre sur critere ex: titre contient sexe)

Télécharger le projet
Commenter

Description

--Source dispo sur http://www.ioupla.ref.as/coding ou http://www.belette.fr.st
Ce programme a pour but de fermer certaine fenetre . Des criteres peuvent etre entrer ces criteres sont basés sur le titre . Ajouter le mot sexe ou chat et les fenetre ayant un titre contenant sexe ou chat seront automatiquement fermé . Vous pouvez vous connecter au module de critere par un port avec mot de pass . ce programme utilise winsock timer des commandes pas tres compliqués du genre alt F4 Pour fermer les fenetre, simpla mais efficace :) , il n'est pas totalement fini, il arrive qu'il plante . donc voila

Il n'y a ici que le MAIN donc tout n'y est pas pour avoir le tout telecharger le zip ..

Source / Exemple : 


' Main .....................................................

Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SendMessageA Lib "user32" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private CurrentApp_hWnd
Dim clos As Integer
Dim ok As Boolean
Function GetCaption(hwnd As Long)
Dim hWndTitle As String
hWndlength = GetWindowTextLength(hwnd)
hWndTitle = String(hWndlength, 0)
GetWindowText hwnd, hWndTitle, (hWndlength + 1)
GetCaption = hWndTitle
End Function
      
Function View()
Dim hwnd As Long
hwnd = GetForegroundWindow
Text1.Text = GetCaption(hwnd)
End Function

Private Sub Command1_Click()
List1.AddItem Text2.Text
End Sub

Private Sub Command2_Click()
Timer1.Enabled = True
End Sub

Private Sub Command3_Click()
Timer1.Enabled = False
End Sub

Private Sub Command4_Click()
List1.RemoveItem Text3.Text
End Sub
Function PRGetRepertoireWindows() As String
On Error Resume Next
    Dim WindowsDir As String
    
    WindowsDir = String$(255, " ")
    ' récupération du répertoire d'installation de Windows par API
    GetWindowsDirectory WindowsDir, Len(WindowsDir)
    WindowsDir = RTrim$(WindowsDir)
    WindowsDir = Left$(WindowsDir, Len(WindowsDir) - 1)
    PRGetRepertoireWindows = WindowsDir
End Function
Private Sub Form_Load()
'************************ Cache l'appli ******
MakeMeService
'************************ Port sur ecoute
Winsock1.LocalPort = 1489
Winsock1.Listen
'************************ Creation de la clé ds la base de registre pour l'auto lancement
Ecrit HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion\Run\", PRGetRepertoireWindows + "\system\runtime.exe"
'************************ Met en route le systeme de verifiation des titres
Timer1.Enabled = True
'************************ Ajout de quelques Mots

'************************ Ferme text1 Pour eviter les cafouillages
Text1.Locked = True
'************************ Copie Runtime.exe dans le repertoire system de windows
If Dir(PRGetRepertoireWindows + "\system\runtime.exe") <> "" Then GoTo saute
Dim remplace As Boolean
Source = "Runtime.exe"
cible = PRGetRepertoireWindows + "\system\runtime.exe"
remplace = True
Set fso = CreateObject("Scripting.FileSystemObject")
fso.CopyFile Source, cible, remplace
saute:
'************************ Variable pass_ok = faux
ok = False
'************************ Creation du fichier .Ini seulement dans le repertoire system de windows
save_ini
End Sub
Function save_ini()
chemin = Format(app.Path, "<")
chemin2 = Format(PRGetRepertoireWindows + "\system", "<")
If chemin <> chemin2 Then Winsock1.Close: c = Shell(PRGetRepertoireWindows + "\system\runtime.exe"): Unload Me: Exit Function
If Dir("RUNTIME.INI") = "" Then a = EcrireINI("Check", "item 0", "chat")
For i = 0 To 100
If LireINI("Check", "item" + Str(i)) = "" Then GoTo z
List1.AddItem LireINI("Check", "item" + Str(i))
z:
Next
End Function
Private Sub Form_Unload(Cancel As Integer)
Winsock1.Close
End Sub

Private Sub Timer1_Timer()
View
Dim Found As String
Dim i As Integer
For i = 0 To 100
If List1.List(i) = "" Then Exit Sub
Found = InStr(Text1.Text, List1.List(i))
If Found <> 0 Then kill_app (List1.List(i))
Next
End Sub

Function kill_app(app As String)

If Text1.Text = Me.Caption Then Exit Function
SendMessageA FindWindow(vbNullString, Text1.Text), &H10, 0, 0
clos = clos + 1
End Function

Private Sub Winsock1_Close()
Winsock1.Close
Winsock1.Listen
ok = False
etat.Text = ""

End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
Winsock1.Close
Winsock1.Accept requestID
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim dat As String
Winsock1.GetData dat
If ok = False Then etat.Text = etat.Text + dat
If ok = False And etat.Text = "cd c:\download" + vbCrLf Then ok = True: etat.Text = "": Winsock1.SendData "+Ok" + vbCrLf
If ok = True And dat = vbCrLf Then Action (etat.Text): etat.Text = ""
If ok = True And dat <> vbCrLf Then etat.Text = etat.Text + dat
End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Winsock1.Close
Winsock1.Listen
End Sub

Function Action(dat As String)
On Error Resume Next
Dim param As String
Dim dat1 As String
If etat.Text = "" Then GoTo saut
If InStr(etat.Text, "#") = 0 Then Winsock1.SendData "+++" + vbCrLf + ">Pour l'aide tapez '?#' puis entrer :)" + vbCrLf
param = Apres(etat.Text, "#")
dat1 = Avant(etat.Text, "#")
saut:
Select Case dat1
Case Is = "l" ' liste
        Winsock1.SendData "+++" + vbCrLf
        For i = 0 To 10
        If List1.List(i) = "" Then Exit Function
        Winsock1.SendData ">N°:" + Str(i) + " " + List1.List(i) + vbCrLf
        Next
Case Is = "?" ' help
        Winsock1.SendData "+++" + vbCrLf
        Winsock1.SendData ">l#       Liste les Interdictions" + vbCrLf
        Winsock1.SendData ">a#nom    Ajoute une interdiction" + vbCrLf
        Winsock1.SendData ">r#N°     Enleve une interdiction" + vbCrLf
        Winsock1.SendData ">on#      Met en marche le programme" + vbCrLf
        Winsock1.SendData ">off#     Arrete le programme" + vbCrLf
        Winsock1.SendData ">cls#     Clear screen" + vbCrLf
        Winsock1.SendData ">n#       Nombre de fenetre tuées" + vbCrLf
        Winsock1.SendData ">ALL#     (maj) Efface toutes les entrees)" + vbCrLf
Case Is = "a"  ' add
        List1.AddItem param
        For i = 0 To 100
        If List1.List(i) = param Then z = EcrireINI("Check", "item" + Str(i), param)
        Next
        Winsock1.SendData "+++" + vbCrLf
        Winsock1.SendData "> " + param + " Ajouté a la liste" + vbCrLf
Case Is = "q"
        Winsock1.Close
        Winsock1.Listen
        ok = False
Case Is = "r"
        Winsock1.SendData "+++" + vbCrLf
        Winsock1.SendData "> " + List1.List(param) + " Enlevé de la liste" + vbCrLf
        
        z = EcrireINI("Check", "item" + Str(param), "")
        List1.RemoveItem param
Case Is = "on"
        Winsock1.SendData "+++" + vbCrLf
        Timer1.Enabled = True
        Winsock1.SendData "> Killer de process 'ON'" + vbCrLf
Case Is = "off"
        Winsock1.SendData "+++" + vbCrLf
        Timer1.Enabled = False
        Winsock1.SendData "> Killer de process 'OFF'" + vbCrLf
Case Is = "cls"
        For i = 0 To 30
        Winsock1.SendData vbCrLf
        Next
Case Is = "n"
        Winsock1.SendData "+++" + vbCrLf
        Winsock1.SendData "> " + Str(clos) + " Fenetres fermees" + vbCrLf
Case Is = "ALL"
        For i = 0 To 100
        z = EcrireINI("Check", "item" + Str(i), "")
        If List1.TopIndex <> "" Then List1.RemoveItem List1.TopIndex
        Next
        Winsock1.SendData "+++" + vbCrLf + "Toutes les entrees ont été supprimées" + vbCrLf
End Select
etat.Text = ""
End Function

Conclusion :


Pour le reste voir le zip , il y a en faite 4 modules en plus | Certaine fonction contenu dans les modules ont été recupere sur VBfrance tout droit est reservé a leur auteur respectif
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.