Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Haupfenster mit individuell gestalteter Titelzeile
Def DrawFrameControl(4) ! user32,DrawFrameControl
DEF GetWinDC(1) ! USER32,GetWindowDC das ganze Fenster inklusive Titelleiste
Def GetDC(1) ! USER32,GetDC,%,%
Def ReleaseDC(2) ! USER32,ReleaseDC hndl,hdc / immer benutzen nach GetDC + GetWinDC
Def DrawText(5) ! USER32,DrawTextA
Def GetCursorPos(1) ! USER32,GetCursorPos
Def ScreenToClient(2) ! USER32,ScreenToClient
Def @Csleep(1) !kernel32,Sleep
Def ReleaseCapture(0) ! USER32,ReleaseCapture
Def eqoGaL(3) @equ(@&(1),@&(2)) or @Gt(@&(1),@&(2)) and @Lt(@&(1),@&(3)) zahl1 größer oder gleich zahl2 und kleiner zahl3
Declare point#,xp%,yp%
Dim point#,8
Proc Pmouse
Declare x&,y&,temp$
Parameters x1&,y1&,x2&,y2&
let temp$=
Dim point#,8 nur wegen der laufenden Cursorpos. auskommentiert
GetCursorPos(point#)
ScreenToClient(%hwnd,point#)
x&=@long(point#,0)
y&=@long(point#,4)
If eqoGaL(x&,x1&,x2&) and eqoGaL(y&,Y1&,y2&)
case Equ(%lastmessage,513):let temp$=left
case Equ(%lastmessage,516):let temp$=right
case Equ(%lastmessage,515):let temp$=double
case Equ(%lastmessage,519):let temp$=middle
case Equ(%lastmessage,522):let temp$=wheel
endif
Dispose point# nur wegen der laufenden Cursorpos auskommentiert
return temp$
endproc
Proc getPosition
GetCursorPos(point#) laufende Positionsangabe
ScreenToClient(%hwnd,point#)
xp%=@long(point#,0)
yp%=@long(point#,4)
Settext statclone&,Mousepos X: +str$(xp%)+ +Mousepos Y: +str$(yp%)+
endproc
proc move
UseCursor 5
SendMessage(%hwnd,$112,$F012,0)
ReleaseCapture()
UseCursor 0
endproc
proc DrawControl
parameters hdchndl&,text$,Ux%,Uy%,Lx%,Ly%,Type&,state&,r%,g%,b%
Declare rect#,hdc&,text#
case text$ <> :Dim text#,len(text$)
case text$ = :Dim text#,1
char text#,0 = text$
Dim rect#,16
Long rect#,0= Ux%
Long rect#,4=Uy%
Long rect#,8= Ux%+Lx%
Long rect#,12=Uy%+Ly%
hdc&=GetWinDC(hdchndl&) Fenster mit Titelzeile die Position zählt dann aber auch von ganz oben.
hdc&=GetDC(hdchndl&) nur Client area erstellen
TextColor @RGB(r%,g%,b%),-1
DrawFrameControl(hdc&,rect#,type&,hex$(state&))
DrawText(hdc&,text#,len(text$),rect#,$25)
if hdchndl& = %Hwnd zum Neuzeichnen in Hauptfenster
DrawFrameControl(%hdc2,rect#,type&,hex$(state&))
DrawText(%hdc2,text#,len(text$),rect#,$25)
endif
ReleaseDC(hdchndl&,hdc&)
TextColor @RGB(0,0,0),-1
Dispose rect#
Dispose text#
endproc
uType
Specifies the type of frame control to draw. This parameter can be one of the following values:
Value Meaning
DFC_BUTTON = 4 Standard button
DFC_CAPTION = 1 Title bar
DCF_MENU = 2 Menu
DFC_POPUPMENU = 5 (Windows 98, ME, NT, 2000, XP) Popupmenü
DFC_SCROLL = 3 Scroll bar
uState
Specifies the initial state of the frame control.
If uType is DFC_BUTTON, uState can be one of the following values:
Value Meaning
DFCS_BUTTON3STATE = $8 (DFC_BUTTON) 3 Style Button
DFCS_BUTTONCHECK = $0 (DFC_BUTTON) Checkbox
DFCS_BUTTONPUSH = $10 = 16 (DFC_BUTTON) Standard Button
DFCS_BUTTONRADIO = $4 (DFC_BUTTON) Options Button
DFCS_BUTTONRADIOIMAGE = $1 (DFC_BUTTON) Bild für Options Buttons
DFCS_BUTTONRADIOMASK = $2 (DFC_BUTTON) Maske für Options Buttons
If uType is DFC_CAPTION, uState can be one of the following values:
Value Meaning
DFCS_CAPTIONCLOSE = $0 (DFC_CAPTION) Schließensymbol der Titelleiste
DFCS_CAPTIONHELP = $4 (DFC_CAPTION) Hilfesymbol der Titelleiste
DFCS_CAPTIONMAX = $2 (DFC_CAPTION) Maximierensymbol der Titelleiste
DFCS_CAPTIONMIN = $1 (DFC_CAPTION) Minimierensymbol der Titelleiste
DFCS_CAPTIONRESTORE = $3 (DFC_CAPTION) Wiederherstellensymbol der Titelleiste
If uType is DFC_MENU, uState can be one of the following values:
Value Meaning
DFCS_MENUARROW = $10 = 16 (DFC_MENU/DFC_POPUPMENU) Menüpfeil nach unten
DFCS_MENUARROW = $8 = 8 (DFC_MENU/DFC_POPUPMENU) Menüpfeil nach oben
DFCS_MENUARROWRIGHT = $4 (DFC_MENU/DFC_POPUPMENU) Menüpfeil nach rechts
DFCS_MENUBULLET = $2 (DFC_MENU/DFC_POPUPMENU) Menü Options Button
DFCS_MENUCHECK = $1 (DFC_MENU/DFC_POPUPMENU) Menü Ckeckbox häckchen
If uType is DFC_SCROLL, uState can be one of the following values:
Value Meaning
DFCS_SCROLLCOMBOBOX = $5 (DFC_SCROLL) Combobox Scrollleiste
DFCS_SCROLLDOWN = $1 (DFC_SCROLL) Pfeilrunter der Scrolleiste
DFCS_SCROLLLEFT = $2 (DFC_SCROLL) Pfeillinks der Scrolleiste
DFCS_SCROLLRIGHT = $3 (DFC_SCROLL) Pfeilrechts der Scrolleiste
DFCS_SCROLLUP = $0 (DFC_SCROLL) Pfeilhoch der Scrolleiste
DFCS_SCROLLSIZEGRIP = $8 (DFC_SCROLL) Größe-ändern-symbol (rechts unten im Fenster)
DFCS_SCROLLSIZEGRIPRIGHT = $10 = 16 (DFC_SCROLL) Größe-ändern-symbol (links unten im Fenster, nicht alle Windowsversionen)
The following style can be used to adjust the bounding rectangle of the push button:
Value Meaning
DFCS_ADJUSTRECT = $2000 = 8192 Die RECT-Struktur wird mit den inneren Koordinaten des gezeichneten Objektes gefüllt (Standard button)
One or more of the following values can be used to set the state of the control to be drawn:
Diese Werte je nach Status zu den o.g. Statuswerten addieren
Value Meaning
DFCS_CHECKED = $400 = 1024 Das Objekt ist markiert mit einem häckchen
DFCS_FLAT = $4000 = 16384 Das Objekt ist flach
DFCS_HOT = $1000 = 4096 (Windows 98, ME, NT, 2000, XP) Das Objekt ist in einem Hottracking zustand
DFCS_INACTIVE = $100 = 256 Das Objekt ist deaktiviert
DFCS_MONO = $8000 = 32768 Das Objekt ist schwarz/weiss
DFCS_PUSHED = $200 = 512 Das Objekt ist gedrückt
DFCS_TRANSPARENT = $800 = 2048 (Windows 98, ME, NT, 2000, XP) Der hintergrund scheint durch
Return Value
If the function succeeds, the return value is TRUE.
If the function fails, the return value is FALSE. To get extended error information, call GetLastError.
##################################################################################
DEF GETSYSCOLOR(1) !USER32,GetSysColor
SETTRUECOLOR 1
DECLARE ENDE%,statclone&,stat%,c1%,c2%,c3%,winpos%,mover&,my%,vba%,vbb%,vl%
proc hilfe
clearlist
addstring Hilfe zum Programm
addstring Hier kann man aufrufen was immer man will.
addstring Einige Funktionen dieses Programmes als Einzelkomponte, können schon brauchbar sein.
addstring Das Fenster sieht mit allen Windowsversionen gleich aus, XP zeigt die gleichen Buttons.
addstring Ich bin auf diese Funktion gestoßen weil ich nach etwas flexibleren Möglichkeiten
addstring gesucht hatte ohne gleich eine Dll zu benutzen.
addstring Wichtig war mir die Statusbar um zu testen ob ich das Scrollen im Hauptfenster sofort
addstring sehen kann, denn die richtigen scrollbars melden den Wert erst nach dem Loslassen
addstring Vieles läßt sich normalweise auch per Get - und Setwindowlong verwirklichen.
addstring Ist nur ein Test
@ListBox$(Kurzbeschreibung,1)
clearlist
endproc
proc vscroll1
if my% > vba%
my%=my%-vl%/100
if my% < vba%
SetWindowPos mover&=(@Width(%Hwnd)-16),vba%-15,15;0
my%=vba%
else
SetWindowPos mover&=(@Width(%Hwnd)-16),my%-15,15;0
endif
endif
endproc
proc vscroll2
if my% < vbb%
my%=my%+vl%/100
if my% > vbb%
SetWindowPos mover&=(@Width(%Hwnd)-16),vbb%-15,15;0
my%=vbb%
else
SetWindowPos mover&=(@Width(%Hwnd)-16),my%-15,15;0
endif
endif
endproc
Hauptprogramm ------------------------------------------------------------
WINDOWSTYLE 84 Fenster ohne Titelleiste
WINDOWTITLE Window Title is, Author: Dieter Zornow, feel free to use in any ways
WINDOW SUB(DIV(%MAXX,2),DIV(800,2)),SUB(DIV(%MAXY,2),DIV(600,2))-800,600
USEFONT MS Sans Serif,13,0,0,0,0
SETDIALOGFONT 1
statclone&=Createedit(%Hwnd,,0,0,0,0)
mover& = Control(STATIC,,$54000181,0,0,0,0,%hwnd,0,%hinstance,$020101)
stat%=0
c1%=0
c2%=0
c3%=0
my%=(@Height(%Hwnd)-@Height(%Hwnd)+35) Variable zum Abfragen der Scrollposition
winpos%=@height(%Hwnd)+@width(%Hwnd)
Proc show
USEFONT MS Sans Serif,20,0,1,0,0
CLS GETSYSCOLOR(15)
Statusbar Clone setzten
if @Width(%Hwnd) > 13
if @Height(%Hwnd) > 20
SetWindowPos statclone&=0,(@Height(%Hwnd)-20)-(@Width(%Hwnd)-13),20;0
endif
endif
fensterleiste und Titel erstellen
Usebrush 1,@RGB(255,0,0)
Rectangle 0,0-@width(%Hwnd),20
TextColor @RGB(0,0,255),-1
Drawtext 30,0,Window Title is,
TextColor @RGB(255,255,0),-1
Drawtext 170,0,Author: Dieter Zornow,
TextColor @RGB(0,255,0),-1
Drawtext 360,0,feel free to use in any ways
LoadSizedBmp A.BMP, 0,0-20,20;0
USEFONT MS Sans Serif,13,0,0,0,0
Parameter von Vscroll aktualisieren
vba%=(@Height(%Hwnd)-@Height(%Hwnd)+35) VBA% = Ausgangsbasis oben
vbb%=(@Height(%Hwnd)-36-15) VBB% = Endpunkt unten
vl%=vbb%-vba% vl% = Weglänge
Scrollbar ausfüllen
Usebrush 0,@RGB(128,128,128) horizontal
Rectangle 35,(@Height(%Hwnd)-95)-120,(@Height(%Hwnd)-80)
Usebrush 0,@RGB(128,128,128) vertical
Rectangle (@width(%Hwnd)-15),(@Height(%Hwnd)-@Height(%Hwnd)+35)-(@width(%Hwnd)-1),(@Height(%Hwnd)-36)
Buttons erstellen
Parameter für alle gezeichneten Controls:
Handle,Text,xpos,ypos,Länge,Höhe,Typ,Status,R,G,B (Farbe des Textes)
DrawControl %Hwnd,Ich bin blau,@width(%Hwnd)-550,@Height(%Hwnd)-95,120,25,8196,16,0,0,255
DrawControl %Hwnd,Ich bin rot,@width(%Hwnd)-420,@Height(%Hwnd)-95,120,25,8196,16,255,0,0
DrawControl %Hwnd,Ich bin grün,@width(%Hwnd)-290,@Height(%Hwnd)-95,120,25,8196,16,0,128,0
DrawControl %Hwnd,Flach u. Ende,@width(%Hwnd)-160,@Height(%Hwnd)-95,120,25,8196,16390,128,0,128 Flacher Button
Drawtext @width(%Hwnd)-140,@Height(%Hwnd)-120,Hooverbeispiel
Fenstermenü erstellen
DrawControl %Hwnd,,@width(%Hwnd)-20,0,20,20,1,0 Fenster schließen
case stat%=0:DrawControl %Hwnd,,@width(%Hwnd)-40,0,20,20,1,2 Fenster maximieren
DrawControl %Hwnd,,@width(%Hwnd)-60,0,20,20,1,1 Fenster minimieren
case stat% <> 0:DrawControl %Hwnd,,@width(%Hwnd)-40,0,20,20,1,3 Wiederherstellen
DrawControl %Hwnd,,@width(%Hwnd)-80,0,20,20,1,4 Hilfe
scrollbars erstellen
DrawControl %Hwnd,,618,70,15,15,3,5 Pfeil der Combobox
DrawControl %Hwnd,,@width(%Hwnd)-16,@Height(%Hwnd)-@Height(%Hwnd)+20,15,15,3,0 scroll up
DrawControl %Hwnd,,@width(%Hwnd)-16,@Height(%Hwnd)-36,15,15,3,1 scroll down
DrawControl %Hwnd,,20,@Height(%Hwnd)-95,15,15,3,2 scroll left
DrawControl %Hwnd,,120,@Height(%Hwnd)-95,15,15,3,3 scroll right
DrawControl %Hwnd,,@width(%Hwnd)-16,@Height(%Hwnd)-16,15,15,3,8 SIZEGRIP right
case @Width(%Hwnd) > 16:SetWindowPos mover&=(@Width(%Hwnd)-16),my%-15,15;0
sonstiges erstellen
USEFONT MS Sans Serif,20,0,1,0,0
TextColor @RGB(255,0,0),-1
Drawtext 10,30,Weitere Formen die mit dieser API-Funktion zu zeichnen sind:
Menü
DrawControl %Hwnd,,10,60,20,20,2,0 Pfeil links
USEFONT MS Sans Serif,14,0,1,0,0
Drawtext 40,65,Pfeil nach links
DrawControl %Hwnd,,10,90,20,20,2,16 Pfeil unten
Drawtext 40,95,Pfeil nach unten
DrawControl %Hwnd,,10,120,20,20,2,2 Bulletin
Drawtext 40,125,Ein Bulletin
DrawControl %Hwnd,,10,150,20,20,2,1 Haken
Drawtext 40,155,Ein Haken
DrawControl %Hwnd,,10,180,20,20,2,8 Pfeil oben
Drawtext 40,185,Pfeil nach oben
popup menue
DrawControl %Hwnd,,10,210,20,20,5,0
Drawtext 40,215,Fensterelemente in Bildern angezeigt
DrawControl %Hwnd,,10,240,20,20,5,1
DrawControl %Hwnd,,10,270,20,20,5,2
DrawControl %Hwnd,,10,300,20,20,5,3
DrawControl %Hwnd,,10,330,20,20,5,4
Check Buttons
case c1%=0:DrawControl %Hwnd,,10,360,20,20,4,1 Maske für check leer
case c1%=1:DrawControl %Hwnd,,10,360,20,20,4,2 Maske für check gefüllt
Drawtext 40,365,Check-Buttons, versuchs mal
case c2%=0:DrawControl %Hwnd,,10,390,20,20,4,4
case c2%=1:DrawControl %Hwnd,,10,390,20,20,4,1028
case c3%=0:DrawControl %Hwnd,,10,420,20,20,4,0
case c3%=1:DrawControl %Hwnd,,10,420,20,20,4,1024
winpos%=@height(%Hwnd)+@width(%Hwnd)
USEFONT MS Sans Serif,13,0,0,0,0
endproc
show
WHILENOT ENDE%
getmessage
Abfrage der Buttons usw. per pmouse: parameters = xpos, ypos, xpos + controllänge, ypos + controlhöhe
pmouse @width(%Hwnd)-290,@Height(%Hwnd)-95,@width(%Hwnd)-290+120,@Height(%Hwnd)-95+25 Button grün
if @$(0) = left
DrawControl %Hwnd,gedrückt rot,@width(%Hwnd)-290,@Height(%Hwnd)-95,120,25,8196,526,255,0,0
csleep(150)
DrawControl %Hwnd,Ich bin grün,@width(%Hwnd)-290,@Height(%Hwnd)-95,120,25,8196,16,0,128,0
@messagebox(Beispiel für Buttondruck,Aktion,64)
endif
pmouse @width(%Hwnd)-420,@Height(%Hwnd)-95,@width(%Hwnd)-420+120,@Height(%Hwnd)-95+25 Button rot
if @$(0) = left
DrawControl %Hwnd,gedrückt grün,@width(%Hwnd)-420,@Height(%Hwnd)-95,120,25,8196,526,0,128,0
csleep(150)
DrawControl %Hwnd,Ich bin rot,@width(%Hwnd)-420,@Height(%Hwnd)-95,120,25,8196,16,255,0,0
endif
pmouse @width(%Hwnd)-550,@Height(%Hwnd)-95,@width(%Hwnd)-550+120,@Height(%Hwnd)-95+25 Button blau
if @$(0) = left
DrawControl %Hwnd,gedrückt lila,@width(%Hwnd)-550,@Height(%Hwnd)-95,120,25,8196,526,255,0,255
Csleep(150)
DrawControl %Hwnd,Ich bin blau,@width(%Hwnd)-550,@Height(%Hwnd)-95,120,25,8196,16,0,0,255
endif
pmouse @width(%Hwnd)-20,0,@width(%Hwnd)-20+20,0+20 Fenster schließen
if @$(0) = left
DrawControl %Hwnd,,@width(%Hwnd)-20,0,20,20,1,512
Csleep(150)
ende%=1
endif
pmouse @width(%Hwnd)-40,0,@width(%Hwnd)-40+20,0+20 Fenster max - normal
if @$(0) = left
if stat%=0
DrawControl %Hwnd,,@width(%Hwnd)-40,0,20,20,1,514
Csleep(150)
stat%=1
showmax
show
else
DrawControl %Hwnd,,@width(%Hwnd)-40,0,20,20,1,515
stat%=0
Csleep(150)
shownormal
show
endif
endif
pmouse @width(%Hwnd)-60,0,@width(%Hwnd)-60+20,0+20 Fenster min
if @$(0) = left
DrawControl %Hwnd,,@width(%Hwnd)-60,0,20,20,1,513
Csleep(150)
DrawControl %Hwnd,,@width(%Hwnd)-60,0,20,20,1,1
showmin
endif
pmouse @width(%Hwnd)-80,0,@width(%Hwnd)-80+20,0+20 Fenster Hilfe
if @$(0) = left
DrawControl %Hwnd,,@width(%Hwnd)-80,0,20,20,1,516
Csleep(150)
DrawControl %Hwnd,,@width(%Hwnd)-80,0,20,20,1,4
hilfe
endif
pmouse 10,360,10+20,360+20 Check 1
if @$(0) = left
if c1%=0
DrawControl %Hwnd,,10,360,20,20,4,2
c1%=1
else
DrawControl %Hwnd,,10,360,20,20,4,1
c1%=0
endif
endif
pmouse 10,390,10+20,390+20 Check 2
if @$(0) = left
if c2%=0
DrawControl %Hwnd,,10,390,20,20,4,1028
c2%=1
else
DrawControl %Hwnd,,10,390,20,20,4,4
c2%=0
endif
endif
pmouse 10,420,10+20,420+20 Check 3
if @$(0) = left
if c3%=0
DrawControl %Hwnd,,10,420,20,20,4,1024
c3%=1
else
DrawControl %Hwnd,,10,420,20,20,4,0
c3%=0
endif
endif
Ende-Button als Hooverbutton, diese Konstruktion ist aufwendig aber flackert nicht.
Will man alle Buttons so abfragen sollte man so eine Konstruktion verwenden.
If eqoGaL(xp%,@width(%Hwnd)-160,@width(%Hwnd)-160+120) and eqoGaL(yp%,@Height(%Hwnd)-95,@Height(%Hwnd)-95+25)
DrawControl %Hwnd,Flach u. Ende,@width(%Hwnd)-160,@Height(%Hwnd)-95,120,25,8196,16,128,0,128
while eqoGaL(xp%,@width(%Hwnd)-160,@width(%Hwnd)-160+120) and eqoGaL(yp%,@Height(%Hwnd)-95,@Height(%Hwnd)-95+25)
getmessage
getPosition
pmouse @width(%Hwnd)-160,@Height(%Hwnd)-95,@width(%Hwnd)-160+120,@Height(%Hwnd)-95+25 Button Ende
if @$(0) = left
DrawControl %Hwnd,schade,@width(%Hwnd)-160,@Height(%Hwnd)-95,120,25,8196,526,0,0,0
csleep(150)
ende%=1
break
endif
wend
DrawControl %Hwnd,Flach u. Ende,@width(%Hwnd)-160,@Height(%Hwnd)-95,120,25,8196,16390,128,0,128
endif
pmouse (@width(%Hwnd)-16),(@Height(%Hwnd)-@Height(%Hwnd)+20),(@width(%Hwnd)-16)+15,(@Height(%Hwnd)-@Height(%Hwnd)+20)+15Vertikale Scrollbar oben
if @$(0) = left
DrawControl %Hwnd,,@width(%Hwnd)-16,@Height(%Hwnd)-@Height(%Hwnd)+20,15,15,3,512
SetTimer 10
whilenot %lastmessage = 514
getmessage
case %lastmessage = 512:break
case %wmTimer:vscroll1
endwhile
Killtimer
DrawControl %Hwnd,,@width(%Hwnd)-16,@Height(%Hwnd)-@Height(%Hwnd)+20,15,15,3,0
endif
pmouse (@width(%Hwnd)-16),(@Height(%Hwnd)-36),(@width(%Hwnd)-16)+15,(@Height(%Hwnd)-36)+15 Vertikale Scrollbar unten
if @$(0) = left
DrawControl %Hwnd,,@width(%Hwnd)-16,@Height(%Hwnd)-36,15,15,3,513
SetTimer 10
whilenot %lastmessage = 514
getmessage
case %lastmessage = 512:break
case %wmTimer:vscroll2
endwhile
Killtimer
DrawControl %Hwnd,,@width(%Hwnd)-16,@Height(%Hwnd)-36,15,15,3,1
endif
pmouse 0,0,@width(%Hwnd) - 90,@height(%Hwnd)-@height(%Hwnd)+20 Fenster bewegen in Titelleiste
if @$(0) = left
move
endif
case @height(%Hwnd)+@width(%Hwnd) <> winpos%:show Prüfen ob Fenster gezogen wurde
getPosition laufende Positionsanzeige
WEND
Dispose point#
end
(1.114)
Deutsch
English
Français
Español
Italia