Quelltexte/ Codesnippets | | | | |  |
KompilierenMarkierenSeparierenGemerkt/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)
}
|
 | | | | | | |
| | 
Frank
Abbing | Hab einige Sachen verbessert, wie: Flackern beseitigt, automatische Bildrestaurierung und Echtzeitscrollen.
KompilierenMarkierenSeparieren {$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
|
| | | | | | |
| | 
RGH | Hier der XPSE-Code übersetzt nach XProfan:
KompilierenMarkierenSeparieren $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 ▲ |
| | |
| |
RGH | Und das Ganze deutlich kürzer:
KompilierenMarkierenSeparieren $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 ▲ |
| | |
| |
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.  |
| | | | | | |
| | | 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. |
| | | | | | |
| | 
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 ...  | 15.12.2008 ▲ |
| | |
|
Zum QuelltextThemenoptionen | 6.629 Betrachtungen |
ThemeninformationenDieses Thema hat 4 Teilnehmer: |
|
(1.100)
Deutsch
English
Français
Español
Italia