Fonte/ Codesnippets | | | | - Page 1 - |
| | | | | | |
| | | | | - Page 2 - |
| | | | | | |
| | | KompilierenMarkierenSeparierenSource wurde am 30.09.2009 in die Babyklappe auf XProfan.Com abgelegt:
{$cleq}
longs x,y
cls
long xx=width(hwnd),yy=height(hwnd),c
mcls xx,yy
whileLoop 0,200
x[loop]=xx*0.5
y[loop]=yy*0.5
wend
while 1
startpaint -1
cls
usebrush 6,$FFAA00
ellipse (mousex-30),(mousey-30) - (mousex+30),(mousey+30)
whileLoop 0,sizeOf(x)-1
x[loop]=x[loop]-2+rnd(5)
y[loop]=y[loop]-2+rnd(5)
setPixel x[loop]-cos(getTickCount*0.001)*30,y[loop]-sin(getTickCount*0.001)*30,loop
wend
endPaint
mcopyBmp 0,0 - xx,yy > 0,0;0
wend
waitinput
end
|
| | | | |
| | | KompilierenMarkierenSeparierenSource wurde am 01.10.2009 in die Babyklappe auf XProfan.Com abgelegt:
{$cleq}
#include c:p00xlistbox.inc
cls
long xx=320,yy=240,c,d,p,cl,mx,my
long flies=lb.create()
long fliesToDie=lb.create()
mcls xx,yy
whileLoop 1
flie.add(xx*0.5-100+loop,yy*0.5)
wend
long fliesDirtPic=create(hNewPic,xx,yy,$FFFFFF)
long bgPic=create(hPic,-1,1.bmp)
long tme=getTickCount+1000
while 1
waitinput 1
mx=mousex/width(hwnd)*xx
my=mousey/height(hwnd)*yy
if getTickCount>tme
tme=tme+100
//case getCount(flies)<50 : flie.add(rnd(xx),rnd(yy-50),0)
case getCount(flies)<150 : flie.add(mx,my,0)
endif
settext hwnd,Fliegen: +str$(getCount(flies))+ Kollisionen: +str$(cl)
cl=0
c=getCount(fliesToDie)
if c
whileLoop c
flie.die(val(getString$(fliesToDie,loop-1))-(loop-1))
wend
clearList fliesToDie
endif
startpaint -1
cls
usepen 0,,256
usebrush 6,$FFAA00
ellipse (mousex-30),(mousey-30) - (mousex+30),(mousey+30)
usepen 0,,0
line 0, (yy-10) - xx,(yy-10)
drawPic fliesDirtPic,0,0;-1
drawPic bgPic,0,0;-1
whileLoop getCount(flies)
p=flie.fly(loop)
wend
if mousepressed
whileLoop getCount(flies)
flie.localBang(loop,mx,my)
wend
endif
endPaint
mcopysizedBmp 0,0 - xx,yy > 0,0 - width(hwnd),height(Hwnd);0
wend
deleteObject fliesDirtPic
waitinput
end
dist(float x,y,xx,yy){
float xd=xx-x
float yd=yy-y
return sqrt(xd*xd+yd*yd)
}
flie.localBang(long n,x,y){
long h=val(getString$(flies,n-1))
case dist(long(h,4),long(h,8),x,y)<30 : long h&,0=1
}
flie.add(long x,y,m){
long h=globalAlloc(gPTR,16)
long h&,0=m
long h&,4=x
long h&,8=y
addstring(flies,str$(h))
}
flie.fly(long n){
long h=val(getString$(flies,n-1)),
m=long(h,0),
x=long(h,4),
y=long(h,8),
ox=x,
oy=y,
c,d
select m
caseof 0
x=x-1+rnd(3)
y=y-1+rnd(3)
if getPixel(x,y)==$FFFFFF
long h&,4=x
long h&,8=y
else
x=ox
y=oy
cl+
endif
setPixel x,y,256
caseof 1
if getPixel(x,y+1)==$FFFFFF
y+
long h&,8=y
setPixel x,y,0
long h&,12=long(h&,12)+3
else
long h&,12=long(h,12)*0.5
if rnd(2)
if getPixel(x-1,y+1)=$FFFFFF
x-
y+
long h&,12=long(h,12)+2
elseif getPixel(x+1,y+1)=$FFFFFF
x+
y+
long h&,12=long(h,12)+2
endif
else
if getPixel(x+1,y+1)=$FFFFFF
x+
y+
long h&,12=long(h,12)+2
elseif getPixel(x-1,y+1)=$FFFFFF
x-
y+
long h&,12=long(h,12)+2
endif
endif
ox=x
oy=y
long h&,4=x
long h&,8=y
long h&,12=long(h,12)-1
if long(h,12)<1
flie.ToDie(n)
endif
setPixel ox,oy,0
endif
/*c=getPixel(x,y)
if (c==$FFFFFF)
else
if long(h,12)>6
endif
endif*/
endSelect
}
flie.toDie(long n){
addString(fliesToDie,str$(n))
}
flie.die(long n){
long h=val(getString$(flies,n-1))
long x=long(h,4),y=long(h,8)
globalFree(h)
deleteString(flies,n-1)
startpaint fliesDirtPic
setPixel x,y,0
endPaint
}
|
| | | | |
| | | | | | | |
| | | | | | | |
| | | | | | | |
| | | | | | | |
| | | | - Page 3 - |
| | | | | | | |
| | H.Brill | Profaninterne Icons Mostra, ohne deren Namen zu wissen. Ab X3 (AddRes)
Declare Handle ilist
Declare Long x, y
ClearList
AddRes %hinstance, 14
x = 50
y = 50
Window 800, 600
ilist = Create("ImageList", 32, 32)
WhileLoop 0, GetCount(0) - 1
ImageList("AddIcon", ilist, Create("hIcon", SubStr$(GetString$(0, &LOOP), 2, "|")))
EndWhile
WhileLoop 0, GetCount(ilist) - 1
DrawText x, y - 20, SubStr$(GetString$(0, &LOOP), 2, "|"), 0
DrawIcon ImageList("GetIcon", ilist, &LOOP), x, y
' oder direkt mit Name (WhileLoop 0, GetCount(0) -1)
'DrawIcon SubStr$(GetString$(0, &LOOP), 2, "|"), x, y
If x > 500
x = 50
Inc y, 100
Else
Inc x, 100
EndIf
EndWhile
WaitKey
DeleteObject ilist
End
|
| | | Benutze XPROFAN X3 + FREEPROFAN Wir sind die XProfaner. Sie werden von uns assimiliert. Widerstand ist zwecklos! Wir werden alle ihre Funktionen und Algorithmen den unseren hinzufügen.
Was die Borg können, können wir schon lange. | 15.08.2017 ▲ |
| |
| | Unterthema: Gridbox auch nach Datum sortieren [...] erzeugt. |
| | | | |
| | Unterthema: Rätselspiel [...] erzeugt. |
| | | | |
| | H.Brill | Programm, um Klassenbilder oder Bilder mit Personen mit Tooltips zu beschriften. Auch interessant, wenn man ein Bild mit Artikeln (Waren) hat, um z.B. den aktuellen Preis anzuzeigen.
$H commctrl.ph
Declare Handle static, Pic, bmp, tip, edit, grid, Long ende, modus, speichern, start, x1, y1, x2, y2, String datei1, file2, text, tool#
Def GetAsyncKeyState(1) !"User32","GetAsyncKeyState"
Dim tool#, 40
grid = Create("Grid", 5, 0)
text = "Tool-Text"
speichern = 0
start = 0
Windowtitle "Bilder - Manager (Rechte Maustaste zum Markieren Mittlere Maustaste gibt Koordinaten !)"
Window %MaxX - 100, %MaxY - 100
Popup "&Datei"
AppendMenu 101, "&Laden"
AppendMenu 102, "&Speichern"
AppendMenu 103, "&Ende"
Separator
AppendMenu 256, "Über"
speichern = 0
ende = 0
MCls Width(%HWnd, 0), Height(%HWnd, 0), RGB(254, 254, 254)
static = Create("hSizedPic", 0, "&MEMBMP", Width(%HWnd, 0), Height(%HWnd, 0), 0)
ClearList grid
WhileNot ende
WaitInput 10
IF GetAsyncKeyState(4)
Dialog1' Mittlere Maustaste
If speichern = 1
start = 0
SpeichereDatei()
'LadeDatei(file2)
EndIf
EndIf
If MenuItem(101)
datei1 = LoadFile$(%HWnd, "Bild-Daei laden", "Bilder|*.jpg;*.jpeg;*.bmp;*.png", 0)
If datei1 <> ""
file2 = SubStr$(datei1, 1, ".") + ".txt"
Create("Bitmap", %HWnd, static, 0, 0)
MLoadBmp datei1
Pic = Create("hPic", 0, "&MEMBMP")
bmp = Create("Bitmap",%HWnd, Pic,10,10)
tip = Create("ToolTip",%HWnd, bmp, "")
'SendMessage(tip,~TTM_SETTIPBKCOLOR, $255,0);
'SendMessage(tip, ~TTM_SETTIPTEXTCOLOR, RGB(255,0,0), 0)
SetText tip, %HWnd, 0, "Unbekannt", 1, "Name :"
If FileExists(file2)
start = 1
LadeDatei(file2)
' MessageBox(Str$(SendMessage(tip, ~TTM_GETTOOLCOUNT, 0, 0)), "", 0)
Else
MessageBox("Noch keine File angelegt !\nweiter mit rechter Maustaste !", "Fehler", 0)
ClearList 0
ClearList grid
EndIf
Else
MessageBox("Keine File ausgewählt !", "Datei laden", 0)
EndIf
ElseIf MenuItem(102)
SpeichereDatei()
MessageBox(file2 + " gespeichert !", "Speichern", 0)
ElseIf MenuItem(103)
ende = 1
ElseIf MenuItem(256)
MessageBox("Von Heinz Brill\nH.Brill@t-online.de", "Info", 0)
EndIf
If %MouseKey = 2
x1 = %MouseX - 10 : y1 = %MouseY - 10 : x2 = %MouseX + 10 : y2 = %MouseY + 10
edit = Create("Edit", bmp, "", x1 - 10, y1, 80, 25)
SetFocus(edit)
While GetFocus(edit)
WaitInput
EndWhile
text = GetText$(edit)
DestroyWindow(edit)
If text <> ""
Long tool#, 0 = 40, 16, %HWnd
Long tool#, 16 = x1, y1, x2, y2, 0, Addr(text)
SendMessage(tip, 1028, 0, tool#)
AddString(grid, Str$(x1) + "|" + Str$(y1) + "|" + Str$(x2) + "|" + Str$(y2) + "|" + text)
EndIf
EndIf
Case %Key = 2 : ende = 1
EndWhile
Proc LadeDatei
Parameters String datei2
Declare toolinfo#, tooltext$
Dim toolinfo#, 40
ClearList grid
ClearList 0
Move("FileToList", datei2)
Move("ListToHandle", grid)
If (GetCount(grid) - 1) > 0
WhileLoop 0, GetCount(grid) - 1
Long toolinfo#, 0 = 40, 16, %HWnd, &LOOP
tooltext$ = GetText$(grid, &LOOP, 4)
Long toolinfo#, 16 = Val(GetText$(grid, &LOOP, 0)), Val(GetText$(grid, &LOOP, 1)), Val(GetText$(grid, &LOOP, 2)), Val(GetText$(grid, &LOOP, 3)), 0, Addr(tooltext$)
SendMessage(tip, 1028, 0, toolinfo#)
EndWhile
If start = 1
MessageBox(datei2 + " geladen !", "Laden", 0)
EndIf
Else
MessageBox("Keine Einträge vorhanden !", "Fehler", 0)
EndIf
Dispose toolinfo#
EndProc
Proc SpeichereDatei
If file2 <> ""
If (GetCount(grid) - 1) > 0
ClearList 0
Move("HandleToList", grid)
Move("ListToFile", file2)
If start = 1
MessageBox(file2 + " angelegt !", "Info", 0)
EndIf
EndIf
Else
MessageBox("Noch keine File angelegt !", "Fehler", 0)
EndIf
EndProc
Proc Dialog1
Declare Handle dlg, btn1, btn2, btn3, kgrid, edit1, edit2, edit3, edit4, edit5
Declare Long stop, pos, String zeile, ttext$
stop = 0
dlg = Create("Dialog", %HWnd, "Koordinaten", %MouseX, %MouseY, 400, 500)
Create("Text", dlg, "X1-Koord.links",10, 10, 100, 25)
edit1 = Create("Edit", dlg, "", 140, 10, 40, 25)
Create("Text", dlg, "Y1-Koord.links",210, 10, 100, 25)
edit2 = Create("Edit", dlg, "", 320, 10, 40, 25)
Create("Text", dlg, "X2-Koord.rechts",10, 80, 100, 25)
edit3 = Create("Edit", dlg, "", 140, 80, 40, 25)
Create("Text", dlg, "Y2-Koord.rechts",210, 80, 100, 25)
edit4 = Create("Edit", dlg, "", 320, 80, 40, 25)
Create("Text", dlg, "Beschreibung",10, 120, 90, 25)
edit5 = Create("Edit", dlg, "", 110, 120, 240, 25)
btn1 = Create("Button", dlg, "Update", 10, 150, 60, 25)
btn2 = Create("Button", dlg, "Lösche", 100, 150, 60, 25)
btn3 = Create("Button", dlg, "Ende", 150, 350, 60, 25)
kgrid = Create("Gridbox", dlg, "X;0;40;Y;0;40;X1;0;40;Y1;0;40;Name;0;120", 0, 10, 180, 320, 100)
If (GetCount(grid) - 1) > 0
Move("ListToHandle", kgrid)
EndIf
WhileNot stop
WaitInput
If Clicked(btn1)
SetText kgrid, pos, 0, GetText$(edit1)
SetText kgrid, pos, 1, GetText$(edit2)
SetText kgrid, pos, 2, GetText$(edit3)
SetText kgrid, pos, 3, GetText$(edit4)
SetText kgrid, pos, 4, GetText$(edit5)
ttext$ = GetText$(edit5)
Long tool#, 0 = 40, 16, %HWnd, pos
Long tool#, 16 = Val(GetText$(edit1)), Val(GetText$(edit2)), Val(GetText$(edit3)), Val(GetText$(edit4)), 0, Addr(ttext$)
SendMessage(tip, ~TTM_UPDATETIPTEXT, 0, tool#)
ElseIf Clicked(btn2)
' Eintrag löschen
Long tool#, 0 = 40, 16, %HWnd, pos
SendMessage(tip, ~TTM_DELTOOL, 0, tool#)
DeleteString(kgrid, pos)
ElseIf Clicked(btn3)
ClearList 0
Move("HandleToList", kgrid)
ClearList grid
Move("ListToHandle", grid)
speichern = 1
stop = 1
'MessageBox("Die Namen werden erst\nbeim erneuten Laden registriert !", "Info", 0)
ElseIf Clicked(kgrid)
pos = GetCurSel(kgrid)
SetText edit1, GetText$(kgrid, pos, 0)
SetText edit2, GetText$(kgrid, pos, 1)
SetText edit3, GetText$(kgrid, pos, 2)
SetText edit4, GetText$(kgrid, pos, 3)
SetText edit5, GetText$(kgrid, pos, 4)
EndIf
EndWhile
DestroyWindow(dlg)
EndProc
Proc UpdateTipText
Declare toolinfo#, tooltext$
Dim toolinfo#, 40
'Long toolinfo#, 0 = 40, 16, %HWnd
If (GetCount(grid) - 1) > 0
WhileLoop 0, GetCount(grid) - 1
tooltext$ = GetText$(grid, &LOOP, 4)
Long toolinfo#, 0 = 40, 16, %HWnd, &LOOP
Long toolinfo#, 16 = Val(GetText$(grid, &LOOP, 0)), Val(GetText$(grid, &LOOP, 1)), Val(GetText$(grid, &LOOP, 2)), Val(GetText$(grid, &LOOP, 3)), 0, Addr(tooltext$)
SendMessage(tip, ~TTM_UPDATETIPTEXT, 0, toolinfo#)
EndWhile
EndIf
Dispose toolinfo#
EndProc
Proc SetInnerSize
Parameters x%,y%
Setwindowpos %Hwnd = %winleft,%wintop - ((%winright-%winleft)-(width(%hwnd)-x%)),((%winbottom-%wintop)-(height(%hwnd)-y%));0
EndProc
Dispose tool#
End
Wenn noch jemand Ideen zur Verbesserung hat, immer her damit. |
| | | Benutze XPROFAN X3 + FREEPROFAN Wir sind die XProfaner. Sie werden von uns assimiliert. Widerstand ist zwecklos! Wir werden alle ihre Funktionen und Algorithmen den unseren hinzufügen.
Was die Borg können, können wir schon lange. | 06.01.2019 ▲ |
| |
|
Zum QuelltextTopic-Options | 30.548 Views |
ThemeninformationenDieses Thema hat 3 subscriber: |