http://www.purearea.net/temp/CodeArchiv ... ast_Len.pb
Ist bei mir um 300 ms schneller, unterstuetzt nur kein Unicode.
http://www.purearea.net/temp/CodeArchiv ... ndow_xx.pb
Keine Ahnung ob es vorher genauso 'gesprungen' ist
Skinwin hab ich auskommentiert.
Code: Alles auswählen
; German forum: http://www.purebasicforums.com/german/viewtopic.php?t=2890&highlight=
; Author: Konne
; Date: 08. April 2005
; OS: Windows
; Demo: No
; Make a physical correct jumping of a window...
; Lustige Procedure, um ein Fenster physikalisch korrekt springen zu lassen
; _________Physik_Fenster___________
; | |
; |Programmierer: Konstantin ***** |
; |Firma: KoMaNi |
; | |
; |--------|Beschreibung|------------|
; |Ist eine lustige Procedure um ein |
; |Fenster springen zu lassen |
; |__________________________________|
Procedure PhysikFenster()
Protected Anziehung ;Gibt die Geschwindigkeit der Anziehung an
Protected Huepfen ;Gibt die Hüpfkraft an
Protected Abweichung ;Gibt die Geschwindigkeit der Abweichung an
Protected Abweichung2 ;Gibt die Seitliche Abweichung nach rechts + | links- an
Protected Anziehung2 ;Gibt die Anziehung nach unten + | oben- an
Protected Geschwindigkeit ;Gibt an wie oft das Fenster verschoben wird
Protected WHoehe ;Bild Hoehe
Protected WBreite ;Bildbreite
Protected Breite ;Breiten koordinaten start punkt
Protected Hoehe ;Gibt die Hoehe des Fensters aus (zB zum Debugen)
Protected oldHoehe ;Brechnung der max. Hoehe
Protected AufHoehe ;Auflösung Hoehe
Protected AufBreite ;Auflösung Breite
Protected i ;Zähl Variable
Protected v ;Zähl Variable
Protected c ;Zähl Variable
Protected l ;Zähl Variable
Protected a ;Zähl Variable
Protected x ;Zähl Variable
;______Hier_können_die_einzelnen_Faktoren_geändert_werden___________________________________________
Anziehung =10 ;Je mehr desto schwächer
Huepfen =15 ;Je mehr deto höher
Abweichung =1 ;weniger is mehr
;______Änderungen_hier_können_zu_einem_Ruckeln_führen_______________________________________________
Abweichung2 =5 ;5 ist gut, mehr is mehr
Anziehung2 =3 ;3 ist gut
Geschwindigkeit=10 ;Bild refresh zeit
;______Fenstereinstellungen_________________________________________________________________________
WHoehe =369 ;Hoehe des Bildes
WBreite =548 ;Breite des Bildes
Breite =100 ;Je mehr desto weiter rechts
;___________________________________________________________________________________________________
;UseJPEGImageDecoder() ;Um JPGs einbinden zu können
If OpenWindow(1,Breite,0, WBreite, WHoehe, "Physik", #PB_Window_Invisible|#PB_Window_SystemMenu) ;Fenster erstellen
;SkinWin(WindowID(1),CatchImage(0,?SkinPicture)) ;Fenster erstellen
HideWindow(1,0) ;Fenster anzeigen
EndIf
i=1
v=0
oldHoehe=8000 ;NUR zur höhenmessung benötigt
ExamineDesktops() ;Die Auflösung auslesen um das Bild dynamisch zur Auflösung springen zu lassen
AufHoehe=DesktopHeight(0) ;Hoehe ermitteln
AufBreite=DesktopWidth(0) ;Breite ermitteln
Repeat ;Hauptschleife öffnen
e = WaitWindowEvent(Geschwindigkeit)
if not e
oldticks=GetTickCount_() ;oldticks dem tickcount gleichstellen
If c=Abweichung And l=0 ;Seitliche Abweichung
Breite=Breite+Abweichung2
c=0
EndIf
If c=Abweichung And l=1
Breite=Breite-Abweichung2
c=0
EndIf
If v<3
c=c+1
EndIf
If Breite>AufBreite-WBreite
l=1
EndIf
If Breite<0
l=0
EndIf
;________________________________________________________________
If x=Anziehung ;Berechnet die Anziehung
a=a+Anziehung2
x=0
EndIf
x=x+1
If v=0 ;lässt den Gegenstand fallen
Hoehe=Hoehe+a
EndIf
If Hoehe=>AufHoehe-30-WHoehe And v=0 ;Wenn es den Boden erreicht...
v=1
a=0
oldHoehe=AufHoehe+800
y=0
EndIf
If v=1 ;Aufspringen
If Huepfen/i> 1.5
Hoehe=Hoehe-Huepfen+a+i*2.5+1
If Hoehe>AufHoehe-30-WHoehe
i=i+1
a=0
oldHoehe=AufHoehe+800
y=0
EndIf
Else
v=2
EndIf
EndIf
If v=2 And Hoehe>AufHoehe-WHoehe-30 ;wenn es auf dem Boden ist...
v=3
Hoehe=AufHoehe+60-WHoehe
ResizeWindow(1,Breite, Hoehe,#PB_Ignore,#PB_Ignore)
Delay(500)
EndIf
If v=3 ;Bild runterziehen ...
s=s+2
Hoehe=Hoehe+s
Delay(10)
If Hoehe > AufHoehe+200
v=4
a=0
EndIf
EndIf
If v=4 ;Bild hochspringen lassen...
Hoehe=Hoehe-50
Delay(10)
EndIf
If v=4 And Hoehe<0 ;Wenn es oben ist die ganze sache nomal wiederholen
i=1
v=0
a=0
EndIf
;_________Höchster Punkt ausrechnen (nicht nötig)_____________________________________
;Höchsten Punkt ausrechnen
If Hoehe < oldHoehe
oldHoehe = Hoehe
; If y=1
EndIf
;Höchsten Punkt debugen
If Hoehe > oldhoehe And y=0
Debug(oldHoehe)
y=y+1
EndIf
;________________________________________________________________-
ResizeWindow(1,Breite, Hoehe,#PB_Ignore,#PB_Ignore) ;Fenster an die angegebenen Koordinaten bewegen
;___________________________________________________________________________________________
endif
ForEver
EndProcedure
physikfenster() ;Ruft das Programm auf
; DataSection
; SkinPicture:
; IncludeBinary "Bilder\bg1.jpg"
; EndDataSection
; IDE Options = PureBasic v4.02 (Windows - x86)
; Folding = -
Code: Alles auswählen
; English forum: http://www.purebasic.fr/english/viewtopic.php?t=4478&highlight=
; Author: FWeil (updated for PB 4.00 by Andre)
; Date: 28. August 2002
; OS: Windows
; Demo: No
;================================================================
;
; EnumWindows TreeView
; F.Weil 20020828
;
; Two linked lists are used for both parent windows and children objects
;
; Each list is updated using a callback Enum procedure
;
; The Tree gadget is build when opening the program's main window
; then you have just to click the items / nodes and surf.
;
; This program has a resizing feature linking the tree gadget size to the main window.
;
; I choosed to put all handle, text and class name information in a single label in the
; tree gadget for each item, so that no more action is necessary except looking labels.
;
; I also tried a List icon gadget version of this program but this tree gadget version is
; really simple and convenient for any further feature to add later.
;
; Feel free to modify update this code sample for any use in the PureBasic community.
;
Structure FindWindowData
hFW.l ; variable to store a handle
sFW.s ; variable to store a Window name
cFW.s ; variable to store a window class name
EndStructure
Global NewList FindWindow.FindWindowData()
Global NewList FindChild.FindWindowData()
Procedure.l EnumChildProc(hChild, lParam)
ChildName.s = Space(255)
ChildClass.s = Space(255)
If GetWindowText_(hChild, @ChildName, 255)
Else
SendMessage_(hChild, #WM_GETTEXT, 255, ChildName)
EndIf
If GetClassName_(hChild, @ChildClass, 255)
AddElement(FindChild())
FindChild()\hFW = hChild
FindChild()\sFW = ChildName
FindChild()\cFW = ChildClass
EndIf
ProcedureReturn 1
EndProcedure
Procedure.l EnumWindowsProc(hFind, lParam)
WindowName.s = Space(255)
WindowClass.s = Space(255)
If GetWindowText_(hFind, WindowName, 255)
Result = GetClassName_(hFind, WindowClass, 255)
AddElement(FindWindow())
FindWindow()\hFW = hFind
FindWindow()\sFW = WindowName
FindWindow()\cFW = WindowClass
EndIf
ProcedureReturn 1
EndProcedure
;
; Main starts here
;
WEvent.l
WindowXSize.l
WindowYSize.l
Quit.l
Quit = #False
WindowXSize = 320
WindowYSize = 240
If OpenWindow(0, 200, 200, WindowXSize, WindowYSize, "MyWindow", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget | #PB_Window_SizeGadget | #PB_Window_TitleBar)
CreateGadgetList(WindowID(0))
TreeGadget(100, 0, 0, WindowXSize, WindowYSize, #PB_Tree_AlwaysShowSelection)
If EnumWindows_(@EnumWindowsProc(), 0)
ResetList(FindWindow())
While NextElement(FindWindow())
AddGadgetItem(100, -1, FindWindow()\sFW + " - " + FindWindow()\cFW + " - " + Str(FindWindow()\hFW), 0, 0)
ClearList(FindChild())
If EnumChildWindows_(FindWindow()\hFW, @EnumChildProc(), 0)
;OpenTreeGadgetNode(100)
ResetList(FindChild())
While NextElement(FindChild())
;AddGadgetItem(100, -1, FindChild()\sFW + " - " + FindChild()\cFW + " - " + Str(FindChild()\hFW))
AddGadgetItem(100, -1, FindChild()\sFW + " - " + FindChild()\cFW + " - " + Str(FindChild()\hFW), 0, 1)
Wend
;CloseTreeGadgetNode(100)
EndIf
Wend
EndIf
Repeat
WEvent = WaitWindowEvent()
Select WEvent
Case #PB_Event_CloseWindow
Quit = #True
Default
EndSelect
If WindowXSize <> WindowWidth(0) Or WindowYSize <> WindowHeight(0)
WindowXSize = WindowWidth(0)
WindowYSize = WindowHeight(0)
ResizeGadget(100, 0, 0, WindowXSize, WindowYSize)
EndIf
Until Quit
EndIf
End
;================================================================
; IDE Options = PureBasic v4.02 (Windows - x86)
; Folding = -
; DisableDebugger
Code: Alles auswählen
; German forum: http://www.purebasic.fr/german/viewtopic.php?t=1279&highlight=
; Author: LittleFurz (updated for PB 4.00 by Andre)
; Date: 18. December 2004
; OS: Windows
; Demo: No
Procedure NewMenuIcon(id,color)
CreateImage(id, 16, 16)
StartDrawing(ImageOutput(id))
box(0,0,16,16,color)
StopDrawing()
ProcedureReturn ImageID(id)
EndProcedure
Enumeration
#MENU_OPEN
#MENU_SAVE
#MENU_SAVEAS
#MENU_CLOSE
#MENU_UNDO
#MENU_REDO
EndEnumeration
OpenWindow(0, 10, 10, 200, 100, "Menu Test", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
If CreateMenu(0, WindowID(0)) ; hier beginnt das Erstellen des Menüs...
MenuTitle("Datei")
MenuItem(#MENU_OPEN , "Open" +Chr(9)+"Ctrl+O")
MenuItem(#MENU_SAVE , "Save" +Chr(9)+"Ctrl+S")
MenuItem(#MENU_SAVEAS , "Save as"+Chr(9)+"Ctrl+A")
MenuItem(#MENU_CLOSE , "Close" +Chr(9)+"Ctrl+C")
MenuTitle("Bearbeiten")
MenuItem(#MENU_UNDO , "Undo" +Chr(9)+"Ctrl+Z")
MenuItem(#MENU_REDO , "Redo" +Chr(9)+"Ctrl+Y")
EndIf
SetMenuItemBitmaps_(MenuID(0), #MENU_OPEN , #MF_BYCOMMAND, NewMenuIcon(0,$FF0000), 0)
SetMenuItemBitmaps_(MenuID(0), #MENU_SAVE , #MF_BYCOMMAND, NewMenuIcon(1,$0000FF), 0)
SetMenuItemBitmaps_(MenuID(0), #MENU_SAVEAS , #MF_BYCOMMAND, NewMenuIcon(2,$FF80FF), 0)
SetMenuItemBitmaps_(MenuID(0), #MENU_CLOSE , #MF_BYCOMMAND, NewMenuIcon(3,$00FF80), 0)
SetMenuItemBitmaps_(MenuID(0), #MENU_UNDO , #MF_BYCOMMAND, NewMenuIcon(4,$000080), 0)
SetMenuItemBitmaps_(MenuID(0), #MENU_REDO , #MF_BYCOMMAND, NewMenuIcon(5,$FFFF00), 0)
Repeat
Until WaitWindowEvent() = #PB_Event_CloseWindow
; Hier ne kurze erklärung der API SetMenuItemBitmaps_():
; SetMenuItemBitmaps_(hMenu, uPosition, uFlags, hBitmapUnchecked, hBitmapChecked)
;
; hMenu - hWnd zum Menü, wo sich das Menüitem befindet
; uPosition - Position im Menü des Menüitems
; uFlags - Keine Ahnung o_O. Sollte #MF_BYPOSITION bleiben
; hBitmapUnchecked - hWnd von einem Bild im Ram. Angezeigt, wenn sich vor dem Menüitem kein Häckchen befindet
; hBitmapChecked - hWnd von einem Bild im Ram. Angezeigt, wenn sich vor dem Menüitem ein Häckchen befindet
;
; Setzt ein kleines Icon vor einem Menuitem im Menü. Kann dazu benutzt werden um ein Programm grafisch etwas aufzuwerten.
;
;
; IDE Options = PureBasic v4.02 (Windows - x86)
; Folding = -
Woher hast du das denn ? Ich habe keine Ahnung was das sein soll , PureFortran ?
http://www.purearea.net/temp/CodeArchiv ... ldItems.pb
Habe aber das hier gefunden :
http://www.purebasic.fr/english/viewtop ... 0325#70325
Code: Alles auswählen
; English forum: http://www.purebasic.fr/english/viewtopic.php?p=70325#70325
; Author: GreenGiant
; Date: 26. September 2004
; OS: Windows
; Demo: No
#MIIM_STATE=1
#MFS_DEFAULT=4096
OpenWindow(0,0,0,400,400,"test",#PB_Window_SystemMenu | #PB_Window_ScreenCentered)
CreatePopupMenu(0)
MenuItem(0,"Normal1")
MenuItem(1,"Normal2")
MenuItem(2,"Bold")
MenuItem(3,"Normal3")
bold.MENUITEMINFO
bold\cbSize=SizeOf(bold)
bold\fMask=#MIIM_STATE
bold\fState=#MFS_DEFAULT
SetMenuItemInfo_(MenuID(0),2,#True,bold) ;2 specifies the item to be made bold
Repeat
ev=WaitWindowEvent()
If ev=#WM_RBUTTONUP
DisplayPopupMenu(0,WindowID(0))
EndIf
Until ev=#PB_Event_CloseWindow
Code: Alles auswählen
; English forum: http://www.purebasic.fr/english/viewtopic.php?t=9263
; Author: einander (updated for PB 4.00 by Andre)
; Date: 22. January 2004
; OS: Windows
; Demo: No
; Problem: innerhalb der Event-Rountine wird zwar offensichtlich die Maus abgefragt, es passiert aber nichts...
;Stretching grid by Einander (updated Sizes() procedure included)
;PB 3.81 - jan 22-2004
Enumeration
#grid
#IMG
EndEnumeration
Global Xmin, Ymin, Xmax, Ymax
Global _X, _Y, XX, YY, s$, MX, MY, MK, mxant, myant
Global Xpoints, Ypoints
Global Dim Xgrid(0, 0) : Global Dim Ygrid(0, 0) : Global Dim Xstep.f(0) : Global Dim Ystep.f(0)
_X = GetSystemMetrics_(#SM_CXSCREEN) - 8 : _Y = GetSystemMetrics_(#SM_CYSCREEN) - 68
XX = _X / 2 : YY = _Y / 2
Global Dim PX(3) : Global Dim PY(3)
Procedure VarL(DIR, i) ; RET ELEM I DEL ARRAY CON DIRECCION DIR
ProcedureReturn PeekL(DIR + i * 4) ; VALE COMO REEMPLAZO PARA PASAR ARRAYS A PROCS
EndProcedure
Procedure Near(x, y, ArrSize, DIR1, DIR2) ; ; retorna indice del elem de LOS ARRAYS EN DIR1, DIR2 mas Near a x,y
MIN = $FFFF
For i = 0 To ArrSize
A = Sqr(Pow(x - VarL(DIR1, i), 2) + Pow(y - VarL(DIR2, i), 2))
If A < MIN : MIN = A : IN = i: EndIf
Next i
ProcedureReturn IN
EndProcedure
Procedure.s LoadIMG()
Show$ = "c:\"
Pat$ = "BitMap (*.BMP)|*.bmp;*.bmp|Jpg (*.jpg)|*.bmp|All files (*.*)|*.*"
File$ = OpenFileRequester("Choose file to load", Show$, Pat$, 0)
If File$
ProcedureReturn File$
Else
End
EndIf
EndProcedure
Procedure MOU(Ev)
Select Ev
Case #WM_LBUTTONDOWN
If MK = 2 : MK = 3 : Else : MK = 1 : EndIf
Case #WM_LBUTTONUP
If MK = 3 : MK = 2 : Else : MK = 0 : EndIf
Case #WM_RBUTTONDOWN
If MK = 1 : MK = 3 : Else : MK = 2 : EndIf
Case #WM_RBUTTONUP
If MK = 3 : MK = 1 : Else : MK = 0 : EndIf
Case #WM_MOUSEMOVE
MX = WindowMouseX(0) - GetSystemMetrics_(#SM_CYSIZEFRAME)
MY = WindowMouseY(0) - GetSystemMetrics_(#SM_CYCAPTION) - GetSystemMetrics_(#SM_CYSIZEFRAME)
EndSelect
EndProcedure
Procedure Sizes()
Xmax = 0 : Xmin = _X : Ymax = 0 : Ymin = _Y
For i = 0 To 3
x = PX(i) : y = PY(i)
If x < Xmin : Xmin = x : EndIf
If x > Xmax : Xmax = x : EndIf
If y < Ymin : Ymin = y : EndIf
If y > Ymax : Ymax = y : EndIf
Next
Xstep(0) = (PX(1) - PX(0)) / Xpoints ; step X horiz sup
Ystep(0) = (PY(1)-PY(0)) / Xpoints ; step Y HOR SUP
Xstep(1) = (PX(2) - PX(3)) / Xpoints ; stepX HOR INF
Ystep(1) = (PY(2)-PY(3)) / Xpoints ; step Y HOR INF
Xstep(2) = (PX(3) - PX(0)) / Ypoints ; step X VER IZQ
Ystep(2) = (PY(3)-PY(0)) / Ypoints ; step Y VER IZQ
Xstep(3) = (PX(2) - PX(1)) / Ypoints ; step X VER DER
Ystep(3) = (PY(2)-PY(1)) / Ypoints ; step Y VER DER
DXstep1.f=(Xstep(1)-Xstep(0))/Ypoints ; para calcular posic horiz de cruces internos
DpX1.f=(PX(3)-PX(0))/Ypoints
DXstep2.f=(Ystep(1)-Ystep(0))/Ypoints
DpX2.f=(PY(3)-PY(0))/Ypoints
For j=0 To Ypoints
For i = 0 To Xpoints ; posic x para verticales
Xgrid(i, j) = (Xstep(0)+DXstep1*j)*i+PX(0)+DpX1*j : Ygrid(i, j) = (Ystep(0)+DXstep2*j)*i+PY(0)+DpX2*j
Next
Next
DYstep1.f=(Xstep(3)-Xstep(2))/Xpoints ; para calcular posic vert de cruces internos
DpY1.f=(PX(1)-PX(0))/Xpoints
DYstep2.f=(Ystep(3)-Ystep(2))/Xpoints
DpY2.f=(PY(1)-PY(0))/Xpoints
For j = 1 To Xpoints
For i = 1 To Ypoints ; posic Y para horizontales
Xgrid( j,i) = (Xstep(2)+DYstep1*j)*i+PX(0)+DpY1*j : Ygrid( j,i) = (Ystep(2)+DYstep2*j)*i+PY(0)+DpY2*j
Next
Next
EndProcedure ; _______________________________
Procedure ShowGrid()
hIMG = CreateImage(#IMG, _X,_Y)
StartDrawing (ImageOutput(#IMG))
DrawingMode(4)
BackColor(RGB(0,0,0))
For i = 0 To 3
Circle (PX(i) , PY(i) , 8,#Yellow)
DrawText(PX(i) + 10, PY(i), Str(i))
Next
Box(Xmin, Ymin, Xmax-Xmin, Ymax-Ymin, #Blue)
For i = 0 To Xpoints ; vertical lines
LineXY(Xgrid( i, 0), Ygrid( i, 0), Xgrid(i, Ypoints ), Ygrid(i, Ypoints ), #Green)
Next
For i = 0 To Ypoints ;horizontal lines
LineXY(Xgrid(0,i), Ygrid( 0,i), Xgrid( Xpoints,i ), Ygrid( Xpoints,i ), #Magenta)
Next
StopDrawing()
StartDrawing(WindowOutput(0))
SetGadgetState(#grid, ImageID(#IMG))
StopDrawing()
EndProcedure
; ____________________________________________________________________________________________________
OpenWindow(0, 0, 0, _X, _Y, "", #WS_OVERLAPPEDWINDOW | #WS_MAXIMIZE)
CreateGadgetList(WindowID(0))
ImageGadget(#grid,0,0,0,0,0)
DisableGadget(#grid,#true)
Xpoints = 28 : Ypoints = 14; Here you can choose how many grid lines*********************************
Dim Xgrid (Xpoints , Ypoints )
Dim Ygrid (Xpoints , Ypoints )
Dim Xstep.f(3 ) : Dim Ystep.f(3 )
PX(0) = _X / 2-100 : PY(0) = _Y / 2-100 : PX(1) = PX(0) + 200 : PY(1) = PY(0)
PX(2) = PX(1) : PY(2) = PY(1) + 200 : PX(3) = PX(0) : PY(3) = PY(2)
Sizes()
ShowGrid()
Repeat
Ev = WaitWindowEvent(10)
MOU(Ev)
If MX <> mxant Or MY <> myant Or MK <> mkant
If sel=0 : C = Near(MX, MY, 3, @PX(), @PY()):sel=1:EndIf
If MK = 1
PX(C) = MX : PY(C) = MY
Sizes()
ShowGrid()
Else
sel=0
EndIf
EndIf
mxant = MX : myant = MY : mkant = MK
Until Ev = #PB_Event_CloseWindow
End
; IDE Options = PureBasic v4.02 (Windows - x86)
; Folding = --
; DisableDebugger
