XProfan

Deutsch

Gemerkt/Separiert von http://xprofan.com/thread.core?t=5812
 {$cleq}
const appTitle=PicScrollDlg
const scrollBarsWidth=20
long hPic=create(hPic,-1,pic2.jpg)
casenot hPic : err(pic not loaded)
long hPic.szX=bmpx,hPic.szY=bmpy
windowstyle 2 | 8 | 16 | 512
long hDlg=createwindow(hwnd,appTitle,100,100,540,380)
long hDlg.hScrollY=create(vScroll,hDlg,,width(hDlg)-scrollBarsWidth,0,scrollBarsWidth,height(hDlg)-scrollBarsWidth)
long hDlg.hScrollX=create(hScroll,hDlg,,0,height(hDlg)-scrollBarsWidth,width(hDlg)-scrollBarsWidth,scrollBarsWidth)
long hBlindStatic=create(text,hDlg,,width(hDlg)-scrollBarsWidth,height(hDlg)-scrollBarsWidth,scrollBarsWidth,scrollBarsWidth)
usermessages wm_close

do {

    hPic.Paint(hPic,hDlg,hDlg.hScrollX,hDlg.hScrollY,hPic.szX,hPic.szY)
    invalidaterect(hBlindStatic,0,0)
    updatewindow(hBlindStatic)
    waitinput
    case umessage==wm_close:break

}

deleteobject hpic
destroywindow(hDlg)
end

err(string s){

    messagebox(s,appTitle,4096)
    end

}

hPic.Paint(long hPic,hDlg,hScrlX,hScrlY,picSzX,picSzY){

    long x=0-getScrollPos(hScrlX)/100*(picSzX-width(hDlg)+scrollBarsWidth)
    long y=0-getScrollPos(hScrlY)/100*(picSzY-height(hDlg)+scrollBarsWidth)
    startpaint hDlg
    drawpic hPic,x,y;0
    endpaint
    invalidaterect(hScrlX,0,0)
    updatewindow(hScrlX)
    invalidaterect(hScrly,0,0)
    updatewindow(hScrly)

}

pic2.jpg

86 kB

Hochgeladen:

25.09.2007

Ladeanzahl:

Herunterladen

picscrolldlg.exe

741 kB

Hochgeladen:

25.09.2007

Ladeanzahl:

Herunterladen

picscrolldlg.prf

2 kB

Hochgeladen:

25.09.2007

Ladeanzahl:

Herunterladen

25.09.2007 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

Frank
Abbing

Hab einige Sachen verbessert, wie: Flackern beseitigt, automatische Bildrestaurierung und Echtzeitscrollen.
Kompilieren Markieren Separieren

 {$cleq}
Const appTitle=PicScrollDlg
Const scrollBarsWidth=20
long hPic=create(hPic,-1,background.bmp)     Bildnamen anpassen
long hPic.szX=bmpx,hPic.szY=bmpy
windowstyle 2 | 8 | 16 | 512
long hDlg=createwindow(hwnd,appTitle,100,100,540,380)
long hDlg.hScrollY=create(vScroll,hDlg,,width(hDlg)-scrollBarsWidth,0,scrollBarsWidth,height(hDlg)-scrollBarsWidth)
long hDlg.hScrollX=create(hScroll,hDlg,,0,height(hDlg)-scrollBarsWidth,width(hDlg)-scrollBarsWidth,scrollBarsWidth)
long hBlindStatic=create(text,hDlg,,width(hDlg)-scrollBarsWidth,height(hDlg)-scrollBarsWidth,scrollBarsWidth,scrollBarsWidth)
SubClass hDlg.hScrollX, 1
SubClass hDlg.hScrollY, 1
SubClass hDlg, 1
usermessages wm_close

While 1

    hPic.Paint(hPic,hDlg,hDlg.hScrollX,hDlg.hScrollY,hPic.szX,hPic.szY)
    invalidaterect(hBlindStatic,0,0)
    updatewindow(hBlindStatic)
    waitinput
    case umessage==wm_close:break

EndWhile

deleteobject hpic
destroywindow(hDlg)
end

Proc hPic.Paint

    Parameters hPic2&,hDlg&,hScrlX&,hScrlY&,picSzX&,picSzY&
    long x=0-getScrollPos(hScrlX&)/100*(picSzX&-width(hDlg&)+scrollBarsWidth)
    long y=0-getScrollPos(hScrlY&)/100*(picSzY&-height(hDlg&)+scrollBarsWidth)
    startpaint hDlg&
    CopyPic hPic2&, 0,0 - (width(hDlg&)-scrollBarsWidth)-x,(height(hDlg&)-scrollBarsWidth)-y > x,y; 0
    endpaint
    invalidaterect(hScrlX&,0,0)
    updatewindow(hScrlX&)
    invalidaterect(hScrly&,0,0)
    updatewindow(hScrly&)

EndProc

SubClassProc

    If ((%sMessage=SBM_GETRANGE) or (%sMessage=WM_PAINT))

        hPic.Paint(hPic,hDlg,hDlg.hScrollX,hDlg.hScrollY,hPic.szX,hPic.szY)
        invalidaterect(hBlindStatic,0,0)
        updatewindow(hBlindStatic)

    EndIf

EndProc

10.12.2008 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

RGH

Hier der XPSE-Code übersetzt nach XProfan:
Kompilieren Markieren Separieren

 $H Windows.ph
 $H Messages.ph
def $appTitle "PicScrollDlg"
def &scrollBarsWidth 20
var hPic& = create("hPic", -1, "hintergrund.bmp") Bildnamen anpassen
var hPic.szX& = %bmpx
var hPic.szY& = %bmpy
windowstyle 2 | 8 | 16 | 512
var hDlg& = create("window", %hwnd, $appTitle, 100, 100, 540, 380)
var hDlg.hScrollY& =
create("vScroll", hDlg&, "", width(hDlg&) - &scrollBarsWidth, 0,
&scrollBarsWidth, height(hDlg&) - &scrollBarsWidth)
var hDlg.hScrollX& =
create("hScroll", hDlg&, "", 0, height(hDlg&) - &scrollBarsWidth,
width(hDlg&) - &scrollBarsWidth, &scrollBarsWidth)
var hBlindStatic& =
create("text", hDlg&, "", width(hDlg&) - &scrollBarsWidth, height(hDlg&) - &scrollBarsWidth,
&scrollBarsWidth, &scrollBarsWidth)
SubClass hDlg.hScrollX&, 1
SubClass hDlg.hScrollY&, 1
SubClass hDlg&, 1
usermessages ~wm_close

While 1

    hPic.Paint(hPic&, hDlg&, hDlg.hScrollX&, hDlg.hScrollY&, hPic.szX&, hPic.szY&)
    ~invalidaterect(hBlindStatic&, 0, 0)
    ~updatewindow(hBlindStatic&)
    waitinput
    case %umessage = ~wm_close : break

EndWhile

deleteobject hpic&
destroywindow(hDlg&)
end

Proc hPic.Paint

    Parameters hPic2&,hDlg&,hScrlX&,hScrlY&,picSzX&,picSzY&
    var x& = 0 - getScrollPos(hScrlX&) / 100 * (picSzX& - width(hDlg&) + &scrollBarsWidth)
    var y& = 0 - getScrollPos(hScrlY&) / 100 * (picSzY& - height(hDlg&) + &scrollBarsWidth)
    startpaint hDlg&
    CopyPic hPic2&, 0,0 - (width(hDlg&) - &scrollBarsWidth - x&),
    (height(hDlg&) - &scrollBarsWidth - y&) > x&, y&; 0
    endpaint
    ~invalidaterect(hScrlX&, 0, 0)
    ~updatewindow(hScrlX&)
    ~invalidaterect(hScrly&, 0, 0)
    ~updatewindow(hScrly&)

EndProc

SubClassProc

    If ((%sMessage = ~SBM_GETRANGE) or (%sMessage = ~WM_PAINT))

        hPic.Paint(hPic&, hDlg&, hDlg.hScrollX&, hDlg.hScrollY&, hPic.szX&, hPic.szY&)
        ~invalidaterect(hBlindStatic&, 0, 0)
        ~updatewindow(hBlindStatic&)

    EndIf

EndProc

Gruß
Roland

@iF: Hier ist es wirklich völlig unverständlich, warum einerseits links neben dem Posting eine große leere Fläche ist und dafür im Gegenzug das Listing ständig nach rechts zu scrollen ist, um ein bißchen was zu erfassen. Meiner unmaßgeblichen Meinung nach sollte das Einrücken der Postings zugunsten besserer Lesbarkeit ersatzlos gestrichen werden!

Intel Duo E8400 3,0 GHz / 4 GB RAM / 1000 GB HDD - ATI Radeon HD 4770 512 MB - Windows 7 Home Premium 32Bit - XProfan X4

11.12.2008 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

RGH

Und das Ganze deutlich kürzer:
Kompilieren Markieren Separieren

 $H Messages.ph
def $appTitle "PicScrollDlg"
def &scrollBarsWidth 16
var hPic& = create("hPic", -1, "hintergrund.bmp") Bildnamen anpassen
var hPic.szX& = %bmpx
var hPic.szY& = %bmpy
windowstyle 2 | 8 | 16 | 512
var hDlg& = create("window", 0, $appTitle, 100, 100, 540, 380)
var hDlg.hScrollY& =
create("vScroll", hDlg&, "", width(hDlg&) - &scrollBarsWidth, 0,
&scrollBarsWidth, height(hDlg&) - &scrollBarsWidth)
var hDlg.hScrollX& =
create("hScroll", hDlg&, "", 0, height(hDlg&) - &scrollBarsWidth,
width(hDlg&) - &scrollBarsWidth, &scrollBarsWidth)
SubClass hDlg.hScrollX&, 1
SubClass hDlg.hScrollY&, 1
hPic.Paint(hPic&, hDlg&, hDlg.hScrollX&, hDlg.hScrollY&, hPic.szX&, hPic.szY&)

While 1

    waitinput
    case %key = 2 : break

EndWhile

deleteobject hpic&
destroywindow(hDlg&)
end

Proc hPic.Paint

    Parameters hPic2&,hDlg&,hScrlX&,hScrlY&,picSzX&,picSzY&
    var x& = 0 - getScrollPos(hScrlX&) / 100 * (picSzX& - width(hDlg&) + &scrollBarsWidth)
    var y& = 0 - getScrollPos(hScrlY&) / 100 * (picSzY& - height(hDlg&) + &scrollBarsWidth)
    startpaint hDlg&
    CopyPic hPic2&, 0,0 - (width(hDlg&) - &scrollBarsWidth - x&),
    (height(hDlg&) - &scrollBarsWidth - y&) > x&, y&; 0
    endpaint

EndProc

SubClassProc

    If ((%sMessage = ~SBM_GETRANGE) or (%sMessage = ~WM_PAINT))

        hPic.Paint(hPic&, hDlg&, hDlg.hScrollX&, hDlg.hScrollY&, hPic.szX&, hPic.szY&)

    EndIf

EndProc

Intel Duo E8400 3,0 GHz / 4 GB RAM / 1000 GB HDD - ATI Radeon HD 4770 512 MB - Windows 7 Home Premium 32Bit - XProfan X4

11.12.2008 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

Frank
Abbing

Nur zur Information: Von ":=" für Wertzuweisungen innerhalb XProfan bin ich abgekommen, dass einfache Gleichheitszeichen für Zuweisungen und doppeltes Gleichheitszeichen für Vergleiche nutze ich heute nur noch.

Hab einfach nur deinen Code übernommen und dann erweitert. Ich benutze nur ein Gleichzeichen für Vergleiche und Zuweisungen. Dein Arbeiten ist ineffizient.

11.12.2008 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

RGH

@iF: Hier ist es wirklich völlig unverständlich, warum einerseits links neben dem Posting eine große leere Fläche ist und dafür im Gegenzug das Listing ständig nach rechts zu scrollen ist, um ein bißchen was zu erfassen.

Code "Separieren" für Code-Vollbild, mehr kann ich _im Moment_ nicht bieten.

15.12.2008 ▲

Vollständiges Zitat

Absatzweise zitieren Zeilenweise zitieren

Jörg
Sellmeyer

Warum nicht einfach alle Beiträge schön links ausgerichtet untereinander? Dieses links/rechts macht die Seite sehr unruhig. Ich komm mir vor wie beim Tennis.

Windows XP SP2 XProfan X4
... und hier mal was ganz anderes als Profan ...