Großes Fenster

Gerhard Putschalka · 11. Juni 2011

Wie kann ich ein Fenster, viel höher als der Bildschirm, erstellen und das Fenster beliebig in der Höhe mit einer Scroll-Leiste auf- und abschieben?

Geht das überhaupt?

Ähnlich wie das Fenster Arbeitsplatz bzw. Computer.

Schöne Feiertage.
Gruß
Gerhard.

Frank A. · 11. Juni 2011

Sowas hatte ich schonmal geschrieben, du findest den Code hier: http://www.paules-pc-forum.de/…ace-flaechen-control.html

Gerhard Putschalka · 12. Juni 2011

Hallo Frank,

wie immer erfolgte Deine Antwort sehr prompt!

Und sie beantwortet sehr gut meine Anfrage.

Vielen Dank.
Gerhard.

Gerhard Putschalka · 22. Juni 2011

Hallo Frank,

Ich möchte eine Prozedur erstellen mit der ich in einem Fenster mithilfe von CreateArea ein JPG-Bild in voller Größe anzeigen kann (mit scrollen).

Grundsätzlich funktioniert es schon.

Da ich bei DrawPic erfolglos ein Neuzeichnen versuchte zeige ich das Bild mit einem

Code

@Create("PicButton",Frame1&,HPic&,1,1,%BmpX,%BmpY)

an.
Nur ruckelt das Bild beim Scrollen.

Da ich meine, dass PicButton nur eine Ausweichlösung ist würde ich DrawPic bevorzugen.
Und möglicherweise würde es mit DrawPic nicht ruckeln.

Das Programm (erstellt mit XProfan11) mit 2 Bildern kann von http://www.gerhard-putschalka.xprofan.com/Test4.zip heruntergeladen werden (Ungef. 5,4MB).

Gruß
Gerhard.

THFR · 22. Juni 2011

Hallo Gerhard,
Anzeigen: warum nicht mit: @Create("Bitmap", Frame1&, HPic&, 0, 0) ?
Hatte damit bisher keine Probleme.

Gruß Thomas

Frank A. · 22. Juni 2011

Ja, damit geht es besser. Je einfacher das Control, desto weniger Störungen werden provoziert es. Buttons lösen viele Messages aus, werden oft neu gezeichnet (hovern), usw.

Gerhard Putschalka · 22. Juni 2011

Hallo Thomas, hallo Frank,

danke. Das funktioniert wesentlich besser.

Viele Grüße
Gerhard.

Gerhard Putschalka · 23. Juni 2011

Hallo,

Im Prinzip funktioniert es so wie ich möchte.
Leider wird der Schirm zwischen den Bildern immer grau anstatt schwarz zu bleiben.

Ich musste in der Prozedur (Zeile 59/60) das Fenster mit Create erstellen um am Prozedurenende dieses wieder zerstören zu können.
Dabei tritt das Problem auf, dass ich das erstellte Fenster trotz CLS @RGB(0, 0, 0) nicht schwarz setzen kann.

Zum Test muss nur das Programm Test4.prf durch den nachstehenden Code ersetzt werden.

Code

'
' Area-Control
' Beispiel von Detlef Jagolski
'
Set("ErrorLevel",0)


$I AN_AREA.INC


'$I Grossbild.inc
' zeige ein Bild in maximaler Größe an
' Einstiegsprozedur ist:
' Zeige_das_Bild   Parameters Pfad+Name des Bildes
' Return    nichts


'
' Area-Control Beispiel  von Detlef Jagolski
' Beispiel von Detlef Jagolski
'
' Mit Verwendung von an_area.inc von Frabbing für Paules-PC-Forum:
' http://www.paules-pc-forum.de/forum/xprofan/


Proc OnApplicationExit
  SubClass %hwnd, 0
  SubClass Frame1&, 0
EndProc


Proc OnApplicationInit
EndProc


SubClassProc
  SubclassArea
  return
  ' der Teil ist stillgelegt
  If (SubClassMessage(%hwnd, ~WM_SIZE) or SubClassMessage(%hwnd, ~WM_SIZING))
    x&=Width(%hwnd)
    Case x&>800:x&=800  'Darf nicht die maximale Breite überschreiten!
    y&=Height(%hwnd)
    Case y&>800:y&=800  'Darf nicht die maximale Höhe überschreiten!
    SetWindowPos Frame1& = 0,0-x&,y&;0
  EndIf
EndProc


Proc Zeige_das_Bild   ' die Prozedur wird mit der Esc-Taste verlassen
  Parameters Name$
  Declare Wx%,Wy%,Wv%,Ww%,Frame1&,Button1&,appexit%,WndH%
  Wx% = 00
  Wy% = 00
  Wv% = (%MaxX - 0)
  Ww% = (%MaxY - 0)

  Set("TrueColor",1)
  WindowStyle 16 + 64

  traceon   ' hier ist das Fenster noch schwarz (unverändert vom Aufruf)
  Traceoff

' anstelle von Window habe ich ein Fenster mit Create erstellt um am Ende der Prozedur dieses Fenster
' wieder zerstören zu können (DestroyWindow(%Hwnd) beendet das Hauptprogramm!!)
'  Window Wx%,Wy% - Wv%,Ww%
  WndH% = @Create("Window",%Hwnd,"",Wx%,Wy%,Wv%,Ww%)


  Cls @RGB(0, 0, 0)  ' hier sollte das eben erstellte Fenster schwarz werden. Ist aber hellgrau.
  traceon
  Traceoff

  ~SetClassLong(WndH%, ~GCL_STYLE, (~GetClassLong(%hwnd, ~GCL_STYLE)- ~CS_HREDRAW - ~CS_VREDRAW))
 
  UseFont "MS Sans Serif",13,0,0,0,0
  SetDialogFont 1
 
  OnApplicationInit


  HPic& = @Create("hPic",-1,Name$)


  ' erstelle Area in der Größe des Bildes
  Frame1& = CreateArea(%BmpX,%BmpY,$20000,$50300000,0,0,Width(WndH%),Height(WndH%),WndH%)

  @Create("Bitmap", Frame1&, HPic&, 0, 0)
  SubClass WndH%, 1
  SubClass Frame1&, 1


  SetWindowPos WndH% = Wx%,Wy% - Wv%,Ww%;0
  WhileNot appexit%
    WaitInput
    If %key = 2
      DeleteObject HPic&
      appexit%=1
    ElseIf (%ScanKey = $1B)   ' Esc
      DeleteObject HPic&
      appexit%=1

    EndIf
  EndWhile
  OnApplicationExit
  DestroyWindow(WndH%)
  Return
EndProc


' ==============
' Programm Start
' ==============


Declare HPic&
Set("TrueColor",1)
Window 0,0 - %MaxX,%MaxY
Cls @RGB(0, 0, 0)


Zeige_das_Bild "0003.jpg"
'messagebox("Zwischen","",0)
Zeige_das_Bild "0002.jpg"
End

Alles anzeigen

Beim Test sind 2 Traceon+Traceoff eingebaut. Diese zeigen, dass das durch Create Window erstellte neue Fenster nicht schwarz gesetzt wird.

Gibt es dafür eine Lösung?

Schönen Feiertag.

Gruß
Gerhard.

Frank A. · 23. Juni 2011

Das kann ich grad mit meinem Netbook nicht testen (löst Bluescreen aus).
Du musst eben dafür sorgen, dass der Hintergrund schwarz gehalten wird. So z.B.:

Code

~SetClassLong(%hwnd, ~GCL_STYLE, (~GetClassLong(%hwnd, ~GCL_STYLE)- ~CS_HREDRAW - ~CS_VREDRAW))

Ausdokumentieren, weil dadurch das Hintergrund-Löschen vor dem Neuzeichnen unterbunden wird.

Code

Def CreateSolidBrush(1) !"gdi32","CreateSolidBrush"
~SetClassLong(?_area_plus&, ~GCL_HBRBACKGROUND, CreateSolidBrush(0))

Der Area einen anderen Hintergrund-Brush verpassen.

Code

ElseIf (SubClassMessage(&sWnd, ~WM_ERASEBKGND))
  ~SelectObject(&sWParam, ~GetClassLong(&sWnd, ~GCL_HBRBACKGROUND))
  ~BitBlt(&sWParam, 0, 0, ?_virtx_plus&, ?_virty_plus&, &sWParam, 0, 0, ~BLACKNESS)
  Set("WinProc", 0)

Im Area-Subclassing einfügen, um den Brush beim Löschen zusätzlich schwarz zu zeichnen.

XProfans Subclassing eignet sich leider nicht wirklich für solche Dinge. Beispielsweise scheint es keine Möglichkeit zu geben, mit einem Returnwert in die originalen Windowsprozedur zu gehen. Das setzen aber einige Messages vorraus.
Musst halt mal bischen rumfummeln, wie gesagt, dein Code erzeugt bei mir auf dem kleinen Netbook einen Totalabsturz. Meine Democodes nicht.

Gerhard Putschalka · 25. Juni 2011

Hallo Frank,
auf meinem Notebook mit W7 funktioniert mein Testprogramm problemlos. Auf einem anderen Notebook und auf einem Tower, beide mit XP, erscheint auch der BlueScreen.

Da die Bildanzeige im endgültigen Programm auch (noch andere) Fehler zeigt werde ich versuchen einen anderen Weg zu finden.

Vorerst vielen Dank.
Gerhard.

THFR · 25. Juni 2011

Hallo Gerhard,
ich habe hier noch einen, warum auch immer, unvolledetes Beispiel mit Franks Sroll-Arera und Listview.dll. Vielleicht kanst du daraus einige Anregungen ziehen.

Code

$P+


Set("ErrorLevel", 1)


$H Windows.ph
$H messages.ph
$H commctrl.ph
$H Structs.ph
DEF PathFileExists(1) ! "shlwapi","PathFileExistsA"


Proc PFExists
parameters file$
return PathFileExists(addr(file$))
endproc


$I Listview_Funktionen.inc
If PFExists("Listview.dll")," "
var lvdll&=usedll("Listview.dll")
Else
MessageBox "Fehler beim Laden der Listview.dll!\nBitte Installation überprüfen.","Information",$40040
End
EndIf
Def ImageList_Create(5) !"comctl32.dll","ImageList_Create"
Def ImageList_Destroy(1) !"comctl32.dll","ImageList_Destroy"
Def ImageList_Add(3) !"comctl32.dll","ImageList_Add"


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Datensicherung
Def ShellExecuteEx(1) !"SHELL32","ShellExecuteExA"
Def @Enablemenuitem(3) !"USER32","EnableMenuItem"
Def GetSystemMenu(2) !"USER32","GetSystemMenu" '
DEF SHBrowseForFolder(1)   ! "Shell32","SHBrowseForFolder"
DEF SHGetPathFromIDList(2) !"Shell32","SHGetPathFromIDListA"
Def @Getdrivetype(1) !"KERNEL32","GetDriveTypeA"
Def SetProgressPos(2)   SendMessage(&(1), $0402, &(2), 0)
Def SetProgressRange(3) SendMessage(&(1), $0401, 0, &(2) | &(3) * $10000)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Statusbar
Def @Createstatuswindow(4) ! "comctl32","CreateStatusWindow"
Def @Createwindowex(12) !"USER32","CreateWindowExA"
Def @Getsyscolor(1) !"USER32","GetSysColor"
Def @Setparent(2) !"USER32","SetParent"
Declare Classname$,Progresshandle&,Hwnd&,Progresszähler&,Positions#
Dim Positions#,16
Long Positions#,0=550
Long Positions#,4=500
Long Positions#,8=-1
'............................................................................
Declare L.a&,L.x&,area&, klasse$
Declare isx&,isy&,xx!,yy!,maxx&,maxy&,rect#,vs#
Declare virtx&,virty&,so!
Dim rect#,16
Dim vs#,512
virtx&=2800
virty&=2800


SubClassProc
   L.x&=~GetKeyState(1) & $8000
   If L.x&
      If ( SubClassMessage(area&, ~WM_VSCROLL) and (&sLParam=0) )
         ~GetWindowRect(area&,rect#)
         maxy&=Long(rect#,12)-Long(rect#,4)+1
         L.x&=&sWParam & $0000ffff
         L.a&=1
         If L.x&=~SB_LINEDOWN
            isy&=8
         ElseIf L.x&=~SB_PAGEDOWN
            isy&=maxy&
         ElseIf L.x&=~SB_LINEUP
            isy&=-8
         ElseIf L.x&=~SB_PAGEUP
            isy&=-maxy&
         ElseIf L.x&=~SB_THUMBTRACK
            so!=yy!
            yy!=&sWParam >> 16
            isy&=-(so!-yy!)
            L.a&=0
         EndIf


         If L.a&
            yy!=yy!+isy&
            If yy!<0
               isy&=(isy&+(0-yy!))
               yy!=0
            EndIf
            If yy!>(virty&-maxy&)
               isy&=isy&-(yy!-(virty&-maxy&))
               yy!=virty&-maxy&
            EndIf
         Endif


         Long vs#,0=28
         Long vs#,4=~SIF_ALL
         Long vs#,12=virty&
         Long vs#,16=maxy&
         Long vs#,20=yy!
         ~SetScrollInfo(area&,~SB_VERT,vs#,1)
         ~ScrollWindow(area&,0,-isy&,0,0)
         ~UpdateWindow(area&)


      ElseIf (SubClassMessage(area&, ~WM_HSCROLL) and (&sLParam=0))
         ~GetWindowRect(area&,rect#)
         maxx&=Long(rect#,8)-Long(rect#,0)+1
         L.x&=&sWParam & $0000ffff
         L.a&=1


         If L.x&=~SB_LINERIGHT
            isx&=8
         ElseIf L.x&=~SB_PAGERIGHT
            isx&=maxx&
         ElseIf L.x&=~SB_LINELEFT
            isx&=-8
         ElseIf L.x&=~SB_PAGELEFT
            isx&=-maxx&
         ElseIf L.x&=~SB_THUMBTRACK
            so!=xx!
            xx!=&sWParam >> 16
            isx&=-(so!-xx!)
            L.a&=0
         EndIf


         If L.a&
            xx!=xx!+isx&
            If xx!<0
               isx&=(isx&+(0-xx!))
               xx!=0
            EndIf
            If xx!>(virtx&-maxx&)
               isx&=isx&-(xx!-(virtx&-maxx&))
               xx!=virtx&-maxx&
            EndIf
         Endif


         Long vs#,0=28
         Long vs#,4=~SIF_ALL
         Long vs#,12=virtx&
         Long vs#,16=maxx&
         Long vs#,20=xx!
         ~SetScrollInfo(area&,~SB_HORZ,vs#,1)
         ~ScrollWindow(area&,-isx&,0,0,0)
         ~UpdateWindow(area&)
      EndIf


   EndIf


   Case %sMessage=~WM_COMMAND: SendMessage(%hwnd,%sMessage,&sWParam,&sLParam)
   Case (SubClassMessage(area&, ~WM_HSCROLL) and (&sLParam<>0)): SendMessage(%hwnd,%sMessage,&sWParam,&sLParam)
   Case (SubClassMessage(area&, ~WM_VSCROLL) and (&sLParam<>0)): SendMessage(%hwnd,%sMessage,&sWParam,&sLParam)
EndProc


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Browser
Proc Browser_S
    Declare Buf#
    Dim Buf#,4
    DEF &BIF_EDITBOX $10
    DEF &BIF_BROWSEFORCOMPUTER $1000
    DEF &BIF_BROWSEFORPRINTER $2000
    DEF &BIF_BROWSEINCLUDEFILES $4000
    DEF &BIF_BROWSEINCLUDEURLS&80
    DEF &BIF_DONTGOBELOWDOMAIN $2
    DEF &BIF_NEWDIALOGSTYLE $40
    DEF &BIF_RETURNFSANCESTORS $8
    DEF &BIF_RETURNONLYFSDIRS &1
    DEF &BIF_SHAREABLE &8000
    DEF &BIF_STATUSTEXT $4
    DEF &BIF_USENEWUI $40
    DEF &BIF_VALIDATE $20
    Declare BrowseStyle&
    BrowseStyle& = &BIF_RETURNONLYFSDIRS+&BIF_STATUSTEXT'+&BIF_USENEWUI'+&BIF_EDITBOX'+&BIF_NEWDIALOGSTYLE'
    Declare Title$
    Title$ = "Bitte Ordner wählen:"
    Declare ReturnBuffer#,pidl&
    Dim ReturnBuffer#,260
    Declare BROWSEINFO#
    Dim BrowseInfo#,32
    Long BROWSEINFO#,0=%hwnd
    Long BROWSEINFO#,4=0
    Long BROWSEINFO#,8=ReturnBuffer#
    Long BROWSEINFO#,12=Addr(Title$)
    Long BROWSEINFO#,16=BrowseStyle&
    Long BROWSEINFO#,20=0
    Long BROWSEINFO#,24=0
    Long BROWSEINFO#,28=0
    pidl& = SHBrowseForFolder(BROWSEINFO#)


    If (SHGetPathFromIDList(pidl&,ReturnBuffer#)<>0)
      Text$=String$(ReturnBuffer#,0)
      Pfad$= Text$+"\"
    EndIf
    Dispose ReturnBuffer#
    Dispose BROWSEINFO#
    Dispose Buf#


    Add_List
EndProc


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Bilder-Liste
Proc Add_List


  ImageList_Destroy(ilist&)
  DestroyWindow(st&)
  DeleteAllItems(listview&)
  ClearList
  ChDir Pfad$
  AddFiles "*.png"
  AddFiles "*.jpg"
  AddFiles "*.bmp"
  AddFiles "*.gif"
'  AddFiles "*.wmf"
'  AddFiles "*.emf"
'  AddFiles "*.ico"
  Anz%= %GetCount+1
  Set("Decimals",0)
  text$="Ordner: "+Pfad$+"... mit " +str$(Anz%)+ " Bild"
  case %GetCount > 0 : text$=text$+"ern"
  @Sendmessage(Status&,$401,0,@Addr(Text$))


  ilist&=ImageList_Create(130,100,33,0,0)


  If Anz%>0
    Dim bereich#,400000
    text$=Chr$(13)
    bytes&=@MoveListToMem(bereich#,text$)
    CsvToListview(listview&,bereich#,bytes&,1)
    Dispose bereich#
    Dim bereich#,400000
    SetImageList(listview&,ilist&)
    SetColumnWidth(listview&,0,132)

    Whileloop GetLines(Listview&)
    GetItemText(listview&,bereich#,0,(&loop-1))
    text$=String$(bereich#,0)
    bild1&=Create("hSizedPic",-1,text$,130,100,1)
    MCls 130, 100 ,rgb(255,255,255)
    StartPaint -1
    DrawPic bild1&, 0, 0; 0
    EndPaint -1
    bild2&=@Create("hPic",0,"&MEMBMP")
    ImageList_Add(ilist&,bild2&,0)
    SetIcon(listview&,(&loop-1),(&loop-1))
    If &loop=1
      bild2&=Create("hPic",-1,text$)
      If (%BmpY > 600) AND (voll%=0)
          bild1&=Create("hSizedPic", -1, text$, 640, 480, 1)
          Else
          bild1&=Create("hPic",-1,text$)
      EndIf
      st& = Create("Bitmap",area&,bild1&,1,1)
    EndIf
    @Sendmessage(Progresshandle&,$0400+2,Progresszähler&,0)
    Progresszähler&=Progresszähler&+1
    Wend

    Else
    MessageBox "Dieser Ordner enthält\nkeine Bilder!","Information",$40040
  EndIf


  @Sendmessage(Progresshandle&,$0400+2,0,0)
  ~RedrawWindow(area&, 0, 0, ~RDW_FRAME | ~RDW_INVALIDATE | ~RDW_ALLCHILDREN | ~RDW_UPDATENOW | ~RDW_INTERNALPAINT)
  Dispose bereich#
EndProc






Declare a&,x&,y&,text$, st&, BildNr&
Declare listview&,z&,ilist&,bild1&,bild2&
declare bereich#,bytes&




Windowstyle 538
Windowtitle "Bildbetrachter für JPG - PNG - BMP - GIF"
Window 1000,640


Cls RGB(0,90,180)


AppendMenuBar 109,"Beenden"
AppendMenuBar 101,"Ordner öffnen"
PopUp "Anzeige"
  AppendMenu 102,"angepasst"
  AppendMenu 103,"100 %"


  CheckMenu 102,1
  CheckMenu 103,0
  var voll%=0


var Status&=@Createstatuswindow($50000920,@Addr(Text$),%Hwnd,1000)
@Sendmessage(Status&,$404,3,Positions#)
Dispose Positions#
Classname$="msctls_progress32"
Progresshandle&=@Createwindowex(0,@Addr(Classname$),0,$40000000,700+3,3,280-6,@Height(Status&)-6,%Hwnd,0,%Hinstance,0)
@Setparent(Progresshandle&,Status&)
@Showwindow(Progresshandle&,1)


Usefont "MS Sans Serif",10,0,0,0,0
SetDialogFont 1


InitMessages(%hwnd)


klasse$="#32770"
text$=""
area&=~CreateWindowEx($20000,addr(klasse$),addr(text$),$50300000,8 ,8 ,670 ,514 ,%hwnd,0,%hinstance,0)
SendMessage(area&,~wm_Hscroll,0,0)
SubClass area&, 1


Listview&=CreateListView(%hwnd,%hinstance,0,GetSysColor(15),-1,$3)
InsertColumn listview&,"Bilder",300,0
ShowListView(listview&,700,8,282,514)


var Pfad$ = @GetDir$("@")
text$="Ordner: "+Pfad$+"... "
@Sendmessage(Status&,$401,0,@Addr(Text$))


var Anz%=0
Browser_S


  
Usermessages $1405


While 1


  waitinput
  Case (%key=2) OR @MenuItem(109):BREAK
  dim bereich#,512
  If %umessage=$1405
    GetItemText(listview&,bereich#,0,str$(&ulParam))
 
    Text$=Translate$(Pfad$+"\\"+String$(bereich#,0),"\","\\")
    DeleteObject bild1&
    DeleteObject bild2&
    bild2&=Create("hPic",-1,text$)
      If (%BmpY > 600) AND (voll%=0)
          bild1&=Create("hSizedPic", -1, text$, 640, 480, 1)
          Else
          bild1&=Create("hPic",-1,text$)
      EndIf
    DestroyWindow(st&)
    st& = Create("Bitmap",area&,bild1&,1,1)
    SetFocus(listview&)
    UpdateListview(listview&)



  Elseif @MenuItem(101)
        Browser_S
  ElseIf @MenuItem(102)
        voll% = 0
        CheckMenu 103,0
        CheckMenu 102,1
        GetItemText(listview&,bereich#,0,BildNr&)
        text$=String$(bereich#,0)
        bild1&=Create("hPic",-1,text$)
        If %BmpY > 600
           case voll%=0:  bild1&=Create("hSizedPic", -1, text$, 640, 480, 1)
        EndIf
        DestroyWindow(st&)
        st& = Create("Bitmap",area&,bild1&,1,1)


  ElseIf @MenuItem(103)
        voll% = 1
        CheckMenu 103,1
        CheckMenu 102,0
        GetItemText(listview&,bereich#,0,BildNr&)
        text$=String$(bereich#,0)
        bild1&=Create("hPic",-1,text$)
        DestroyWindow(st&)
        st& = Create("Bitmap",area&,bild1&,1,1)


  Endif
    ~RedrawWindow(area&, 0, 0, ~RDW_FRAME | ~RDW_INVALIDATE | ~RDW_ALLCHILDREN | ~RDW_UPDATENOW | ~RDW_INTERNALPAINT)
  dispose bereich#
EndWhile
SubClass area&, 0
Dispose bereich#
Dispose rect#
Dispose vs#
ChDir Pfad$
ImageList_Destroy(ilist&)
DestroyWindow(%hwnd)


DeleteObject bild1&
DeleteObject bild2&


freedll lvdll&


End

Alles anzeigen

Gruß Thomas

PS.: Grund war sicher, weil mir zu langsam, gelegentlicher Abbruch und unvollständiger Bildneuaufbau, wenn das vorherige gescrollt wurde (läßt sich sicher einfach beheben).

Frank A. · 25. Juni 2011

Zitat

Auf einem anderen Notebook und auf einem Tower, beide mit XP, erscheint auch der BlueScreen.

Wie gesagt, bei mir ebenfalls.
Die Area-Democodes hingegen sind niemals abgestürzt. Da ist bei dir irgendwo der Wurm drin.

Gerhard Putschalka · 25. Juni 2011

Hallo Frank,

ich versuche jetzt einen anderen Weg. Dein Beispiel Grosse_Bitmap-Icons.prf schien mir dazu geeignet.

Zwar kann ich ein Bild 3008x2000 einfügen jedoch gelang es mir nur mit dem hor. Scoll-Balken das Bild in der Breite ganz anzuzeigen. Leider gibt es keinen vertikalen Scoll-Balken um das Bild auch in der Höhe zu verschieben.
Meine Frage: geht das überhaupt? Wenn ja: wie kann ich die Zeilenhöhe (für dieses Beispiel) auf 2000 einstellen?

Es wäre schön wenn das möglich wäre.

Von http://www.gerhard-putschalka.xprofan.com/test1.zip kannst Du meinen Versuch herunterladen.

Vielen Dank (für meine Lästigkeit).

Gerhard

Frank A. · 26. Juni 2011

Nein, Gerhard. Ich glaube nicht, dass sich das Listview vertikal so steuern lässt. Du kannst bei BuildListview mehrere Zeilen erzeugen und bekommst dann den Scroller, aber wirklich vernünftig scrollen ist nicht.
Habe aber noch einen Code bei mir gefunden, der dir evt. weiterhilft:

Code

declare cf1&,cf2&
def cf1(2) !"kernel32","GetProcAddress"
def cf2(1) !"kernel32","GetModuleHandleA"
cf1&=cf1(cf2("user32.dll"),"InvalidateRect")
cf2&=cf1(cf2("user32.dll"),"UpdateWindow")


var hpic&=create("hpic",-1,"background.bmp")
var hpic.szx&=%bmpx
var hpic.szy&=%bmpy
windowstyle 312 | 8 | 16 | 512
var hdlg&=(create("window",(%hwnd),"picscrolldlg",(((%maxx/2)-(%maxx/3))),(((%maxy/2)-(%maxy/3))),(%maxx/1.5),(%maxy/1.5)))
var hdlg.hscrolly&=create("vscroll",hdlg&,"",width(hdlg&)-20,0,20,height(hdlg&)-20)
var hdlg.hscrollx&=create("hscroll",hdlg&,"",0,height(hdlg&)-20,width(hdlg&)-20,20)
var hblindstatic&=create("text",hdlg&,"",width(hdlg&)-20,height(hdlg&)-20,20,20)
subclass hdlg.hscrollx&, 1
subclass hdlg.hscrolly&, 1
subclass hdlg&, 1
usermessages $0010
while 1
  hpic.paint(hpic&,hdlg&,hdlg.hscrollx&,hdlg.hscrolly&,hpic.szx&,hpic.szy&)
  call(cf1&,hblindstatic&,0,0)
  call(cf2&,hblindstatic&)
  waitinput
  if %umessage=$0010
    break
  endif
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&)+20)
  var y&=0-getscrollpos(hscrly&)/100*(picszy&-height(hdlg&)+20)
  startpaint hdlg&
  copypic hpic2&, 0,0 - (width(hdlg&)-20)-x&,(height(hdlg&)-20)-y& > x&,y&;0
  endpaint
  call(cf1&,hscrlx&,0,0)
  call(cf2&,hscrlx&)
  call(cf1&,hscrly&,0,0)
  call(cf2&,hscrly&)
endproc


subclassproc
  if ((%smessage=227) or (%smessage=$000f))
    hpic.paint(hpic&,hdlg&,hdlg.hscrollx&,hdlg.hscrolly&,hpic.szx&,hpic.szy&)
    call(cf1&,hblindstatic&,0,0)
    call(cf2&,hblindstatic&)
  endif
endproc

Alles anzeigen

Müsste das sein, was du suchst. Quelle leider unbekannt, dürfte umgewandelter Xps-Codes ein. Schau ihn dir einfach an.

THFR · 26. Juni 2011

Und wie wär's mit einem WebControl "HTMLWin"

Code

' Arbeitspfad im Interpretermodus , in der *. exe dann $ProgDir
Var old_file$ = GetDir$("@")'$ProgDir'


WindowStyle 16 + 64
Window %maxX,%maxY
AddHotKey 7001, 13, 0


var a$="mshtml: <b>Bild 0003.jpg</b><div style='font-size:12; '>und weiter mit Enter</div><img src='"+old_file$+"\0003.jpg'/>"
var h& = @create("htmlWin",%hWnd,a$,4,0,0,%maxX-4,%maxY-4)
While 0=0
waitInput
case MenuItem(7001) : Break
EndWhile
DestroyWindow(h&)


a$="mshtml: <b>Bild 0002.jpg</b><div style='font-size:12; '>und weiter mit Enter</div><img src='"+old_file$+"\0002.jpg'/>"
h& =@create("htmlWin",%hWnd,a$,4,0,0,%maxX-4,%maxY-4)


While 0=0
waitInput
case MenuItem(7001) : Break
EndWhile
DestroyWindow(h&)


end

Alles anzeigen

Gruß Thomas

Gerhard Putschalka · 26. Juni 2011

Hallo Thomas, hallo Frank,

vorerst vielen Dank. Jetzt habe ich einiges zum Probieren. :smile:

Wenn ich eine brauchbare Lösung gefunden habe melde ich mich wieder.

Gerhard.

Gerhard Putschalka · 2. Juli 2011

Hallo Thomas,

ich denke Deine WEB-Version ist die einfachste und erscheint mir als die braubarste Lösung.
Bist Du einverstanden dass ich sie in meiner BidlShow verwende und auf meine H.P. stelle?
Auch vielen Dank an Frank.

Gruß
Gerhard.

THFR · 2. Juli 2011

Hallo Gerhard,
das kannst du.
Ich hatte Weiteres versucht (html style) und bin aber mit dem Bildwechsel nicht zufrieden.
Vielleicht sollte man es mit eingebautem JS machen.
Du kennst dich da ja auch aus oder hast eine bessere Lösung gefunden.

Gruß Thomas

Code

' Arbeitspfad im Interpretermodus , in der *. exe dann $ProgDir
Var old_file$ = GetDir$("@")'$ProgDir'


var text1$="style='font-family: Arial; font-size:14px; font-weight:bold; color:#0000A0;'"
var text2$="style='font-family: Arial; font-size:12px; font-weight:normal; color:#0000A0;'"




WindowStyle 16 + 64
Window %maxX,%maxY


UseFont "Arial",14,0,0,0,0
SetDialogFont 1


var SMenue&=@Create("Window",%hwnd, "", 0, 0, 0, 0)
var box&=@Create("ChoiceBox", SMenue&,0, 1, 1,98 , 90)
ClearList
AddFiles "*.jpg"
@MoveListToHandle(box&)
var Ed17$=@GetString$(box&,0)
SendMessage(box&,$014D,-1,addr(Ed17$))
SetWindowPos SMenue&=(%maxX-120),0 - 100,24;-1


AddHotKey 7001, 13, 0


Declare a$, h&


Html_Fenster Ed17$


While 0=0
waitInput


case MenuItem(7001) : Break
If GetFocus(box&)
  waitInput
  If @GetString$(box&,@GetCurSel(box&))<>ed17$
    ed17$= @GetString$(box&,@GetCurSel(box&))
    Html_Fenster Ed17$
  EndIf
  SetFocus(%hwnd)
EndIf
EndWhile
DestroyWindow(h&)
end


Proc Html_Fenster
  DestroyWindow(h&)
  a$="mshtml: <div "+text1$+"><b>Bild "+Ed17$+"</b><font "
  a$=a$+text2$+">....neu wählen oder beenden mit Enter</Font></div><img src='"
  a$=a$+old_file$+"\"+ed17$+"'/>"
  h& = @create("htmlWin",%hWnd,a$,4,0,0,%maxX-4,%maxY-4)
EndProc

Alles anzeigen

Gerhard Putschalka · 3. Juli 2011

Hallo Thomas,

mit HTML bin ich nicht sehr vertraut.

Meine neue Version der BildShow ist jetzt auf meiner HP. Vielleicht kannst Du Teile davon brauchen.

Gruß
Gerhard.

Großes Fenster

Jetzt mitmachen!

Teilen