XProfan

 $P+
@Set("ErrorLevel", 2)
 $H Messages.ph
 $H Windows.ph
 $H ocx2.ph
 $I ocx2.inc
 $I EventDisp.inc'********** Pfad bitte anpassen ********
'------------------Diverses
declare x&,y&,raktiv&,handle&
declare a%,b%,c%,d%
declare a$,b$,c$,d$
declare a&,b&,c&,d&
declare a!,b!,c!,d!
declare a#,b#,c#,d#
dim a#,1024
dim b#,1024
dim c#,1024
Def @Mouse_event(5)!"User32","mouse_event"
def Redraw(1) ~RedrawWindow(&(1),0,0,$485)
def AtlAdvise(4) !"ATL.dll","AtlAdvise"
def AtlUnadvise(3) !"ATL.dll","AtlUnadvise"
declare pfad$,text$,suchen$,nutzer$,ak$,eingelesen$,anspp$,taktiv$,zeitst$
declare NewUrl$,WebObject&,WebControl&,ende%
parameters Mode$
declare Document&,Window&,History&
DECLARE DLG8&, DIALOGENDE%,anzeige$
anzeige$="0"
nutzer$="Test"
'###########################################################
 $I internetfilter.inc
raktiv&=0'<--- rechte Maustaste aktiv
raktiv&=1'<--- rechte Maustaste inaktiv
ocxInit()
windowstyle 16+8+4'+2'+1
window 0,0-%maxX,%maxY-40
windowtitle "Families-Shield Browsermodul            Aktueller Nutzer:  "+nutzer$+"     "+date$(2)
usermessages 16'----Beenden
usermessages 5000'--Intern verwendete selbstdefinierte Message
~GetClientRect(%hwnd,a#)'<-- Clientbereich auf Hauptfenster erstellen
WebObject&=ocxCreate("about:blank",%hwnd,0,0,long(a#,8),long(a#,12),$53b00000,addr(WebControl&))
appendmenubar 201,"         "
appendmenubar 101,"         "
appendmenubar 102,"         "
appendmenubar 103,"         "
appendmenubar 104," Suchen "'<--- hier noch Voreinstellung der Suchmaschine oder deaktivieren
appendmenubar 106," Gehe zu "'<--- hier noch Einstellung ob deaktiviert
appendmenubar 107," Internetseite merken "'<--- hier noch Einstellung ob deaktiviert
appendmenubar 108," Seite öffnen "
appendmenubar 202,"                    "
appendmenubar 109," Hilfe "
appendmenubar 110," BEENDEN "
EnableMenu 201, 1
EnableMenu 101, 1
EnableMenu 102, 1
EnableMenu 103, 1
EnableMenu 202, 1
InitDispatch(WebObject&)'---Aktiviert die Linküberwachung
Redraw(WebControl&)'--Neuzeichnen wg. Dialogbox bei Abbruch
case len(a$):ocxMethod(WebObject&,"Navigate",a$)
ocxMethod(WebObject&,"GoHome")'--Startseite öffnen

whilenot ende%

    if raktiv&=1

        if %MousePressed=2

            Let Y&=-%Maxy/2
            Let X&=-%Maxx/2
            beep
            @Mouse_event(1,x&,y&,0,0)'Maus bewegen

        endif

    endif

    '   if menuitem(101)'---------------------------------------Zurück
    '        Navigation("back")

    if menuitem(110)'-----------------------------------Beenden

        break
        '   elseif menuitem(102)'-----------------------------------Vorwärts
        '        Navigation("forward")

    elseif menuitem(104)'-----------------------------------Seitenaufruf Suchseite

        a$="www.google.de"
        Redraw(WebControl&)
        case len(a$):ocxMethod(WebObject&,"Navigate",a$)

    elseif menuitem(106)'-----------------------------------Direktaufruf

        'a$=input$("Bitte Web-Adresse eingeben:","URL:","")
        a$="google.de"

        ifnot a$=""

            Redraw(WebControl&)
            urldownload "https://"+a$,"c:\\Temp\\test.txt"
            ausführen
            case @Match$("goto", a$)<>"":fehler%=fehler%+2
            case @Match$("http", a$)<>"":fehler%=fehler%+2

        endif

        ifnot a$=""

            Redraw(WebControl&)
            case len(a$):ocxMethod(WebObject&,"Navigate",a$)

        endif

    elseif menuitem(107)'-----------------------------------Internetseite merken in Datei schreiben

        text$=@trim$(a$)
        case text$="":@MessageBox("Leere Seiten werden nicht gepeichert","Hinweis",0+48+262144 )
        case text$="www.families-shield.de/warnung.html":@MessageBox("Diese Seite kann nicht gepeichert werden","Hinweis",0+48+262144 )
        case text$="www.families-shield.de/warnung.html":text$=""

        if text$>""

            text$=UUEncode(text$)
            Assign #1,pfad$+"ilist.wli"
            Append #1
            Print #1,text$
            Close #1
            @MessageBox("Seite wurde gespeichert.","Hinweis",0+48+262144 )

        endif

    elseif menuitem(108)'-----------------------------------URL öffnen aus Liste

        ClearList
        a$ =""
        Assign #1,pfad$+"ilist.wli"
        Reset #1

        If %IOResult

            @MessageBox("Programm wurde manipuliert.","Schwerer Fehler",0+48+262144 )

        Else

            WhileNot @EOF(#1)

                Input #1, text$
                text$=UUDecode(text$)
                AddString text$

            EndWhile

            Close #1

        EndIf

        a$ = @ListBox$("Internetseite:", 7)

        ifnot a$=""

            urldownload "https://"+a$,"c:\\Temp\\test.txt"
            ausführen

        endif

    elseif menuitem(109)'-----------------------------------Hilfe anzeigen

        a$= "c:\\families-shield/programm/help/bh1.html"
        Redraw(WebControl&)'--Neuzeichnen wg. Dialogbox bei Abbruch
        case len(a$):ocxMethod(WebObject&,"Navigate",a$)

    endif'------------------------------------------------------------

    while 1'-------------------------Warten, bis Aktion ausgeführt ist

        casenot ocxGet(WebObject&,"Busy"):break
        sleep 400

    endwhile'---------------------------------------------------------

    ~GetClientRect(%hwnd,a#)'--Repositionieren wg. Scrolleisten bei Grössenänderung
    setwindowpos WebControl&=0,0-long(a#,8),long(a#,12)
    Redraw(WebControl&)'-------Neuzeichnen
    waitinput
    case %umessage=16:break'---Ende

    if %umessage=5000'-------------------------------Linküberwachung hat angesprochen

        messagebox("Geöffnet wird \n\n"+NewURL$,"Linkumleitung!",1)

        if %button=1'--OK

            ifnot NewURL$=""

                urldownload NewURL$,"c:\\Temp\\test.txt"
                ausführen

            endif

            if fehler%>1

                NewURL$="https://www.google.de"

            endif

            ifnot NewURL$=""

                ocxMethod(WebObject&,"Navigate",NewUrl$)'--URL öffnen im selben Fenster
                case besucht$="j":a$=NewURL$'<--- Hier speichern der aufgerufenen URL
                'case besucht$="j":aufzeichnen                 '<--- Hier speichern der aufgerufenen URL

            endif

        else'----------Abbrechen

            Redraw(WebControl&)'--Neuzeichnen wegen Messagebox bei Abbruch

        endif

    endif'---------------------------------------------------------------------------

endwhile'---------------------------------------------Ende Eingabeschleife

DeInitDispatch(WebObject&)
destroywindow(WebControl&)
ocxDeInit()
Dispose a#
Dispose b#
Dispose c#
destroywindow(%hwnd)
end

proc Navigation'-------------------------------------------

    Document&=ocxGet(WebObject&,"Document")
    Window&=ocxGet(Document&,"parentWindow")
    History&=ocxGet(Window&,"History")
    ocxMethod(History&,Mode$)
    ocxRelease(History&,Window&,Document&)

Endproc'---------------------------------------------------

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

'************************************* Globale Deklarationen **************
declare VTable#,IFace&,Puffer#,Cookie#,asm#

proc InvokeProc'-------------------------------------------InvokeProc

    if long(Puffer#,4)=273''----DISPID_NEWWINDOW3

        Disp#=long(Puffer#,20)'--DISPPARAMS [out][in]
        Var#=Disp#.rgvarg&'------BSTR bstrUrl
        NewUrl$=WideToMultiEx(Var#.val&)
        Var#=Disp#.rgvarg&+48'---DWORD dwFlags
        long Var#.val&,0=1'------Flag=1 : KEIN neues Fenster!
        sendmessage(%hwnd,5000,0,0)'--Duchbricht WaitInput in der Eingabeschleife

    endif

endproc'-------------------------------------------------------------

proc Query_Interface'----------------------------------QueryInterface

    parameters This&,IID&,That&
    long That&,0=This&
    return 0'--S_OK

endproc'-------------------------------------------------------------

proc AddRef'---------------------------------------------------AddRef

    return 0'--S_OK

endproc'-------------------------------------------------------------

proc Release'-------------------------------------------------Release

    return 0'--S_OK

endproc'-------------------------------------------------------------

proc InitDispatch'---------------------------------------InitDispatch

    '--Initialisiert ein eigenes IDispatch-Interface (Verwendung als DWebBrowserEvents2)
    parameters Object&
    dim Puffer#,1024
    dim Cookie#,2'--nur als Dummy
    dim asm#,56'--Wrapper für IDispatch::Invoke
    long asm#,0=-1192457387,Puffer#,2235,48640,216727552,-1993655157,-1065138632,79921924
    long asm#,32=1963589251,-1198485265,procaddr(InvokeProc,0),12112127,1560281088,9410
    '--An IDispatch::Invoke werden 9 Parameter übergeben.
    '--Profan's ProcAddr kann nur 5 übergeben.
    '--Diese Routine schreibt die 9 Parameter nacheinander in Puffer#
    '--und ruft anschliessend die Prozedur InvokeProc auf,
    '--die die Parameter auswertet.
    '--Damit lassen sich alle mögliche Ereignisse überwachen und manipulieren.
    dim VTable#,32
    clear VTable#
    long VTable#,0=procaddr("Query_Interface",3)
    long VTable#,4=procaddr("AddRef",1)
    long VTable#,8=procaddr("Release",1)
    '--Alle anderen Methoden werden garnicht angesprochen
    long VTable#,24=asm#
    long VTable#,28=VTable#
    IFace&=VTable#+28
    set("fastmode",1)
    StringToGUID(~IID_IDispatch,IID#)
    AtlAdvise(Object&,IFace&,IID#,Cookie#)'--Cookie# darf nicht Null sein

endproc'------------------------------------------------------------

proc DeInitDispatch'-----------------------------------DeInitDispatch

    parameters Object&
    StringToGUID(~IID_IDispatch,IID#)
    AtlUnadvise(Object&,IID#,Cookie#)
    dispose Cookie#
    dispose Puffer#
    dispose asm#
    dispose VTable#
    procaddr("Query_Interface",-3)
    procaddr("AddRef",-1)
    procaddr("Release",-1)
    set("fastmode",0)

endproc'------------------------------------------------------------

'Internetfilter
DEF URLDownloadToFile(5) ! "urlmon","URLDownloadToFileA"
Declare zeile$,worte&,zaehler%,wort$,fehler%,zeileneu$,zeilenanzahl%,positiv&,positiv$
DECLARE DLG&
declare zahl1%,zahl2%
'case fehler%>1:@messagebox("Diese Internetseite wurde gesperrt",@str$(fehler%),16)

proc Urldownload

    parameters url$,save$
    Declare result&
    result& = URLDownloadToFile(0,addr(url$),addr(save$),$10,0)
    casenot result& = 0:@Messagebox("Beim Download ist ein Fehler aufgetreten\nBitte überprüfen Sie die Url","Fehler",64)
    fehler%=0

endproc

proc ausführen

    dialog
    worte&= Create("List", 1)
    AddString(worte&, "sex")
    AddString(worte&, "porno")
    AddString(worte&, "lesbe")
    AddString(worte&, "hardcore")
    AddString(worte&, "schwanz")
    AddString(worte&, "votze")
    AddString(worte&, "fick")
    AddString(worte&, "poppen")
    AddString(worte&, "blasen")
    AddString(worte&, "bums")
    AddString(worte&, "vögeln")
    AddString(worte&, "gevögelt")
    AddString(worte&, "pisse")
    AddString(worte&, "pimmel")
    AddString(worte&, "xxx")
    AddString(worte&, "nacktfoto")
    AddString(worte&, "sexual")
    AddString(worte&, "teensex")
    AddString(worte&, "elder")
    AddString(worte&, "vagina")
    AddString(worte&, "porn")
    AddString(worte&, "fuck")
    AddString(worte&, "kinky")
    AddString(worte&, "cock")
    AddString(worte&, "suck")
    AddString(worte&, "anal")
    AddString(worte&, "nympho")
    AddString(worte&, "incest")
    AddString(worte&, "spunk")
    AddString(worte&, "blowjob")
    AddString(worte&, "perver")
    AddString(worte&, "sexkontakt")
    AddString(worte&, "swinger")
    AddString(worte&, "sextreffen")
    AddString(worte&, "refresh")
    AddString(worte&, "titten")
    AddString(worte&, "exitframe")
    AddString(worte&, "sexpic")
    AddString(worte&, "sexbilder")
    AddString(worte&, "sexpics")
    AddString(worte&, "teenpics")
    AddString(worte&, "keine Verantwortung")
    AddString(worte&, "extreme")
    AddString(worte&, "adult")
    positiv&= Create("List", 1)
    AddString(positiv&, "aufklärung")
    AddString(positiv&, "mensch")
    AddString(positiv&, "sexuelle aufklärung")
    AddString(positiv&,"sexualpädagogisch")
    AddString(positiv&,"sexualität")
    AddString(positiv&,"fortpflanzung")
    AddString(positiv&,"strafbarkeit")
    AddString(positiv&,"schutz")
    AddString(positiv&,"liebesbeziehung")
    AddString(positiv&,"aids")
    AddString(positiv&,"sexualhormone")
    AddString(positiv&,"biologisch")
    AddString(positiv&,"biologie")
    AddString(positiv&,"chemie")
    Assign #1,"c:\\Temp\\test.txt"
    Reset #1

    If %IOResult

        @Messagebox("Manipulation des Systems festgestellt !\nBitte überprüfen !","Fehler",64)

    Else

        WhileNot @EOF(#1)

            Input #1, Zeile$
            '################################ ACHTUNG: Abfangen von automatischen Weiterleitungen ############
            case @InStr("refresh", @Lower$(zeile$))>0:fehler%=fehler%+1
            case @Match$("adult",@Lower$(zeile$))<>"":fehler%=fehler%+2'<-------------- versteckte blocken
            'case @Match$("login",@Lower$(zeile$))<>"":fehler%=fehler%+2'<-------------- versteckte blocken
            '#################################################################################################
            prüfen
            zeilenanzahl%=zeilenanzahl%+1

        EndWhile

        Close #1

    EndIf

    @DESTROYWINDOW(DLG&)

endproc

proc prüfen

    'prüfen ################
    zaehler%=0

    Whilenot zaehler%=GetCount(worte&)

        wort$= GetString$(worte&,zaehler%)

        if @InStr(wort$, zeileneu$)<=0

            case @InStr(wort$, @Lower$(zeile$))>0:fehler%=fehler%+1
            case @InStr(wort$, @Lower$(zeile$))>0:zeileneu$=zeileneu$+", "+wort$

        endif

        casenot zaehler%=GetCount(worte&):zaehler%=zaehler%+1

    EndWhile

    zaehler%=0

    Whilenot zaehler%=GetCount(positiv&)

        positiv$= GetString$(positiv&,zaehler%)

        if @InStr(positiv$, zeileneu$)<=0

            case @InStr(positiv$, @Lower$(zeile$))>0:zeileneu$=zeileneu$+", "+positiv$
            case @InStr(positiv$, @Lower$(zeile$))>0:fehler%=fehler%-1

        endif

        casenot zaehler%=GetCount(positiv&):zaehler%=zaehler%+1

    EndWhile

endproc

'ausführen
'     @Messagebox(zeileneu$,@str$(fehler%),64)

PROC DIALOG'---------------------------------------------------------------------------> Dialoganfang

    DLG&=CREATE("WINDOW",%HWND,"                 FAMILIES-SHIELD überprüft die Seite               ",(%MaxX/2-165),%MaxY/2,330,0)
    'zahl1%=@GETSTYLE(DLG&)
    '@Messagebox("",@str$(zahl1%),64)
    'zahl2%=$80000
    'SETSTYLE DLG&,DEC zahl1%,zahl2%'$80000
    SetStyle dlg&,(GetStyle(dlg&) - $80000)
    SETFOCUS(%HWND)'(um Stil zu aktivieren!)
    'SETFOCUS(DLG&)

ENDPROC'--------------

proc MultiToWideEx'----------------------------------------------------------------------

    parameters Text$
    var Size&=len(Text$)*2+2
    dim ocxTemp#,Size&
    stringw ocxTemp#,0=Text$
    Text$=char$(ocxTemp#,0,Size&)
    return Text$

endproc