Drehbares Lesezeichen

[Andreas Miethe]

Auf Anregung von hier : Layers für Zeichnungselemente?
ist ein drehbares Lesezeichen entstanden.
Es steht jedermann frei den Code an seine Bedürfnisse anzupassen.

'Drehbares Lesezeichen XProfan 11.2
'13.09.2009 - Andreas Miethe
'########################################
'
'Bedienung Tastatur :
'Pfeil links - Lesezeichen links drehen
'Pfeil rechts - Lesezeichen rechts drehen
'Pfeil runter - Lesezeichen nach unter
'Pfeil hoh - Lesezeichen nach oben
'Pos1(HOME) - Lesezeichen gerade richten
'Bild runter - Lesezeichen schneller nach unten
'Bild hoch - Lesezeichen schneller nach oben
'Ende - Lesezeichen mittig ausrichten
'
'Bedienung Maus :
'Linke Taste über Lesezeichen gedrückt halten und
'Lesezeichen verschieben.
'##########################################

$H Windows.ph
$H Messages.ph

'###############################
'Strukturen
'###############################
Struct RECT = left&,top&,right&,bottom&
Struct  XFORM =  eM11!,eM12!,eM21!,eM22!,eDx!,eDy!

'Hintergrundbild
Var hPic& = Create("hPic",0,"&DSKBMP")

Var XStart& = 0
Var RgnStart& = 0
Var RgnEnd& = 0
Var RgnHeight& = 10

Var IsInvert& = 0
Var Oldmx& = 0
Var Oldmy& = 0
CLS ~GetSysColor(~COLOR_BTNFACE)

~MoveWindow(%hwnd,0,0,%maxx,%maxy,1)
~SetClassLong(%hwnd,~GCL_STYLE,(~GetClassLong(%hwnd,~GCL_STYLE)- ~CS_HREDRAW - ~CS_VREDRAW))
Useicon "A"
SetDialogFont ~GetStockObject(~ANSI_VAR_FONT)

'Hintergrundbild anzeigen
DrawSizedPic hPic&,0,0-width(%hwnd),height(%hwnd);0

'SubClassing einschalten
'###############################
SubClass %HWnd, 1
'###############################

Var Button& = Create("Button",%hwnd,"Ende",Width(%hwnd)-120,10,80,24)
'Button vom Neuzeichnen ausnehmen, so kann die Region hinter den Button geschoben werden
'###############################
Var Rect# = New(RECT)
~GetClientRect(Button&,Rect#)
~MapWindowpoints(Button&,%hwnd,Rect#,2)
~ExcludeClipRect(%hdc,Rect#.left&,Rect#.top&,Rect#.right&,rect#.bottom&)
Dispose rect#

'Region erzeugen
Var DC& = ~CreateCompatibleDC(0)
~BeginPath(DC&)
~MoveToEx(DC&,0,RgnStart&,0)
~LineTo(DC&,Width(%hwnd),0)
~LineTo(DC&,Width(%hwnd),RgnHeight&)
~LineTo(DC&,0,RgnStart&+RgnHeight&)
~CloseFigure(DC&)
~EndPath(DC&)
Var hRgn& = ~PathToRegion(DC&)
~DeleteDC(DC&)
DrawRgn(1)

Proc UpdateRgn
  Parameters Richtung&
  Var DC& = ~CreateCompatibleDC(0)
  If Richtung& = 1
    Dec RgnStart&
    Inc RgnEnd&
  Elseif Richtung& = 2
    Inc RgnStart&
    Dec RgnEnd&
    Dec XStart&
  Endif
  ~BeginPath(DC&)
  If Richtung& = 3
    ~Rectangle(DC&,XStart&,RgnStart&,Width(%hwnd),RgnStart&+RgnHeight&)
  Elseif Richtung& = 4
    ~Rectangle(DC&,0,((Height(%hwnd)/2)-(RgnHeight&/2)),Width(%hwnd),((Height(%hwnd)/2)+(RgnHeight&/2)))
  Else
    ~MoveToEx(DC&,XStart&,RgnStart&,0)
    ~LineTo(DC&,Width(%hwnd),RgnEnd&)
    ~LineTo(DC&,Width(%hwnd),RgnEnd&+RgnHeight&)
    ~LineTo(DC&,XStart&,RgnStart&+RgnHeight&)
    If Richtung& = 1
      ~LineTo(DC&,0,RgnEnd&)
    Elseif Richtung& = 2
      ~LineTo(DC&,XStart&,RgnStart&+RgnHeight&)
    Endif
  Endif
  ~EndPath(DC&)
  ~DeleteObject(hRgn&)
  hRgn& = ~PathToRegion(DC&)
  ~DeleteDC(DC&)
  Repaint
  DrawRgn(0)
EndProc

'Hautpschleife
'#############
Var Ende& = 0
Whilenot Ende&
  Waitinput
  If (%key = 2) Or Clicked(Button&)
    ~DeleteObject(hPic&)
    Ende& = 1
  Endif
EndWhile

'SubClassing-Procedur
'###############################
SubClassProc
  If SubClassMessage(%hWnd, ~WM_MOUSEMOVE)
    If (~PtInRegion(hRgn&,Loword(&sLParam),HiWord(&sLParam))) And (IsInvert& = 0)
      DrawRgn(0)
      IsInvert& = 1
    ElseIf ((~PtInRegion(hRgn&,Loword(&sLParam),HiWord(&sLParam)))=0) And (IsInvert& = 1)
      DrawRgn(1)
      IsInvert& = 0
    Endif
    If &swParam = ~MK_LBUTTON	
      If IsInvert& = 1
        Repaint
        ~OffsetRgn(hRgn&,0,Hiword(&sLParam)-OldmY&)
        DrawRgn(0)
        OldmX& = Loword(&sLParam)
        OldmY& = Hiword(&sLParam)
      Endif
    Endif
  Endif
  If SubClassMessage(%hWnd, ~WM_LBUTTONDOWN)
    If (~PtInRegion(hRgn&,Loword(&sLParam),HiWord(&sLParam))) and (IsInvert& = 1)
      DrawRgn(0)
      OldmX& = Loword(&sLParam)
      OldmY& = Hiword(&sLParam)
      UseCursor 10
    Endif
  Endif
  If SubClassMessage(%hWnd, ~WM_LBUTTONUP)
    If (~PtInRegion(hRgn&,Loword(&sLParam),HiWord(&sLParam))) and (IsInvert& = 1)
      DrawRgn(1)
    Endif
    UseCursor 0
    UpdateRgnBox()
  Endif
  If SubClassMessage(%hWnd, ~WM_KEYDOWN)
    Select &swParam
      Caseof ~VK_DOWN
      Repaint
      ~OffsetRgn(hRgn&,0,4)
      DrawRgn(0)
      UpdateRgnBox()
      
      Caseof ~VK_UP
      Repaint
      ~OffsetRgn(hRgn&,0,-4)
      DrawRgn(0)
      UpdateRgnBox()
      
      Caseof ~VK_NEXT
      Repaint
      ~OffsetRgn(hRgn&,0,40)
      DrawRgn(0)
      UpdateRgnBox()
      
      Caseof ~VK_PRIOR
      Repaint
      ~OffsetRgn(hRgn&,0,-40)
      DrawRgn(0)
      UpdateRgnBox()
      
      Caseof ~VK_LEFT
      UpdateRgn(2)
      
      Caseof ~VK_RIGHT
      UpdateRgn(1)
      
      Caseof ~VK_HOME
      UpdateRgn(3)
      UpdateRgnBox(1)
      
      Caseof ~VK_END
      UpdateRgn(4)
      UpdateRgnBox()
    Endselect
  Endif
  If SubClassMessage(%hWnd, ~WM_KEYUP)
    Repaint
    DrawRgn(1)
  Endif
EndProc
'###############################

Proc UpdateRgnBox
  Var RgnBox# = New(RECT)
  ~GetRgnBox(hRgn&,RgnBox#)
  If &(1)= 1
    RgnStart& = RgnBox#.Top&
    RgnEnd& = RgnBox#.Bottom&+RgnHeight&
  Else
    RgnStart& = RgnBox#.Bottom&-RgnHeight&
    RgnEnd& = RgnBox#.Top&
  Endif
  Dispose RgnBox#
EndProc

Proc DrawRgn
  Parameters F&
  If F& = 1
    UseBrush 1,$8080FF
    ~PaintRgn(%hdc,hRgn&)
    ~FrameRgn(%hdc,hRgn&,~GetStockObject(~BLACK_BRUSH),1,1)
  Else
    UseBrush 1,$FF
    ~PaintRgn(%hdc,hRgn&)
    ~FrameRgn(%hdc,hRgn&,~GetStockObject(~BLACK_BRUSH),1,1)
  Endif
EndProc

[Frabbing]

Drehen? Man kann es hoch und runter ziehen, aber wie dreht man?

[p. specht]

Mit Up / Down-Taste, geht sehr gut. Muß bloß noch die Titelzeile wegbekommen... Ich weiß schon, eigentlich hattest Du nach der API-Methode gefragt...

[Frabbing]

Ah, Cursor links/rechts zum Drehen. Tja, bin wohl ein echter Maus-User...