Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!Code-Beispiel
Kinderleicht Tabellen erstellen
| Lizenz: | Erster Autor: | Letzte Bearbeitung: |
| GPL |  jakidomi |  05.11.2008 |
[b]
tabelle.bi
tabelle
x position
y position
breite
höhe
anzahl der splaten
anzahl der zeilen
rahmenfarbe = Trennlinien für die zellen
hintergrundfarbe der kompleten tabelle
zellen = der text der in jede zelle geschrieben werden soll
zellen_background_farbe=der hintergrund für jeder zelle
zellen_schrift_farbe= schrift Farbe der zelle
zellen_ausrichtung= text position inerhalb der zelle
(
opt. 1 (wagerecht)
center - left - right
, = verbindet
opt. 2 (lotrecht)
center - up - down
z.B.
zellen_ausrichtung(1)="center,up"
)
zellen_event =
(
0=kein event
1= maus in zelle & andere maustaste betätigt
2=maus in zelle & linker mausklick auf zelle
3=maus in zelle & linker mausklick auf zellen text
4=maus in zelle
)
[/b]
#include once "fonts.bi"
sub tabelle (x as integer,y as integer,breit as integer,hoch as integer,spalten as integer,_
zeilen as integer,byval rahmenfarbe as uinteger=0,byval hintergrundfarbe as uinteger=0,_
zellen() as string,zellen_background_farbe() as uinteger,zellen_schrift_farbe() as _
uinteger,zellen_ausrichtung() as string,zellen_event() as integer)
if hintergrundfarbe then line (x,y)-(x+breit,y+hoch),hintergrundfarbe,bf
if rahmenfarbe then line (x,y)-(x+breit,y+hoch),rahmenfarbe,b
dim as integer spalten_breite,zeilen_breite,yy,xx,i
dim as integer ui,spaltenpos(),zeilenpos(),kpos,spalten_pos_abzug,_
zeilen_pos_abzug,spalten_format_op,zeilen_format_ok,posbe,ii
spalten_breite=fix(breit/spalten)
zeilen_breite=fix(hoch/zeilen)
if spalten_breite<2 then spalten_breite=2:spalten=2*breit
if zeilen_breite<2 then zeilen_breite=2:zeilen=2*hoch
redim spaltenpos(spalten),zeilenpos(zeilen)
posbe=0
for xx =x to breit+x step spalten_breite
line(xx,y)-(xx,y+hoch),rahmenfarbe
posbe+=1
spaltenpos(posbe)=xx
next
posbe=0
for yy =y to hoch+y step zeilen_breite
line(x,yy)-(x+breit,yy),rahmenfarbe:i+=1
posbe+=1
zeilenpos(posbe)=yy
next
ii=0
for ui=1 to zeilen
for i=1 to spalten
ii+=1
if zellen_background_farbe(ii) then line(spaltenpos(i)+1_
,zeilenpos(ui)+1)-(spaltenpos(i)+spalten_breite-1,zeilenpos(ui)-1+zeilen_breite),_
zellen_background_farbe(ii),bf
kpos=instr(zellen_ausrichtung(ii),",")
spalten_format_op=1
zeilen_format_ok=1
spalten_pos_abzug=0
zeilen_pos_abzug=0
if kpos then
select case mid(zellen_ausrichtung(ii),1,kpos-1)
case "center"
spalten_pos_abzug=(spalten_breite/2)-((len(zellen(ii))*8)/2)
case "left"
spalten_pos_abzug=5
case "left+"
'spalten_pos_abzug=
case "left-"
'spalten_pos_abzug=
case "right"
spalten_pos_abzug=spalten_breite-(len(zellen(ii))*8)-5
case "right+"
'spalten_pos_abzug=
case "right-"
'spalten_pos_abzug=
case else
spalten_format_op=0
draw string(spaltenpos(i)+5,zeilenpos(ui)),"Zelle("+str(i)+","+str(ui)+"):Falsche Spalten formatierung",_
zellen_schrift_farbe(ii)
end select
select case mid(zellen_ausrichtung(ii),kpos+1,len(zellen_ausrichtung(ii)))
case "center"
zeilen_pos_abzug=(zeilen_breite/2)-4
case "up"
zeilen_pos_abzug=5
case "up+"
'zeilen_pos_abzug=
case "up-"
'zeilen_pos_abzug=
case "down"
zeilen_pos_abzug=zeilen_breite-getfont
case "down+"
'zeilen_pos_abzug=
case "down-"
'zeilen_pos_abzug=
case else
zeilen_format_ok=0
if spalten_format_op then
draw string(spaltenpos(i)+5,zeilenpos(ui)),"Zelle("+str(i)+","+str(ui)+"):Falsche Zeilen formatierung",_
zellen_schrift_farbe(ii)
else
draw string(spaltenpos(i)+5,zeilenpos(ui)+getfont),"Zelle("+str(i)+","+str(ui)+"):Falsche Zeilen formatierung",_
zellen_schrift_farbe(ii)
endif
end select
dim as integer stringlaengenabzug=0,stringlaenge=(len(zellen(ii))*8),stpos=1,_
mx,my,but
stringlaengenabzug=fix(stringlaenge/spalten_breite)
if spalten_format_op and zeilen_format_ok then
getmouse mx,my,,but
if mx>spaltenpos(i) and mx<spaltenpos(i)+spalten_breite and my>zeilenpos(ui) and my<zeilenpos(ui)+zeilen_breite then
if but=1 then
zellen_event(ii)=2
else
if not but=0 then zellen_event(ii)=1 else zellen_event(ii)=4
endif
endif
if stringlaengenabzug then
select case mid(zellen_ausrichtung(ii),kpos+1,len(zellen_ausrichtung(ii)))
case "up"
zeilen_pos_abzug=5
zeilen_pos_abzug+=stringlaengenabzug*(getfont/2)
case "up+"
'zeilen_pos_abzug=
case "up-"
'zeilen_pos_abzug=
case "down"
zeilen_pos_abzug=zeilen_breite-getfont
zeilen_pos_abzug-=stringlaengenabzug*(getfont/2)
case "down+"
'zeilen_pos_abzug=
case "down-"
'zeilen_pos_abzug=
end select
spalten_pos_abzug=2
if instr(str(stringlaengenabzug/2),".") then
zeilen_pos_abzug+=8
endif
for uu as integer=(stringlaengenabzug/2) to -(stringlaengenabzug/2) step -1
if Drawstring_with_mouse(spaltenpos(i)+spalten_pos_abzug,zeilenpos(ui)+zeilen_pos_abzug-(uu*getfont),1,_
mid(zellen(ii),stpos,(spalten_breite/8)-1),zellen_schrift_farbe(ii),rgb(0,0,0)) = 2 then zellen_event(ii)=3
stpos+=(spalten_breite/8)
next
else
if Drawstring_with_mouse(spaltenpos(i)+spalten_pos_abzug,zeilenpos(ui)+zeilen_pos_abzug,0,_
zellen(ii),zellen_schrift_farbe(ii),rgb(0,0,0))=2 then zellen_event(ii)=3
endif
endif
else
spalten_format_op=0
zeilen_format_ok=0
draw string(spaltenpos(i),zeilenpos(ui)),"Bitte Formatierung Beachten", _
zellen_schrift_farbe(ii)
endif
if (ii)>=ubound(zellen) then goto forend
next
next
forend:
end sub
[b]
Fonts.bi
Type fb_font_x
As Integer breit, hoch
As Any Ptr start
End Type
Extern Font8 Alias "fb_font_8x8" As fb_font_x
Extern Font14 Alias "fb_font_8x14" As fb_font_x
Extern Font16 Alias "fb_font_8x16" As fb_font_x
Sub DrawString( ByVal buffer As Any Ptr=0, ByVal xpos As Integer, _
ByVal ypos As Integer, ByRef text As String, ByVal fgcol As Integer=Color, _
ByRef f As fb_font_x)
Dim As Integer l,bits,xend,ss=xpos
Dim row As UByte Ptr
l = Len(text)-1
If l<0 Then Exit Sub
ScreenInfo xend
For i As Integer = 0 To l
if mid(text,i+1,2)=chr(13,10) then ypos+=f.hoch:i+=2:xpos=ss
row = (text[i]*f.hoch+f.start)
For y As Integer= ypos To ypos+f.hoch-1
bits = *row
For x As Integer= xpos To xpos+7
If (bits And 1) Then
If (buffer = 0) Then
PSet (x,y),fgcol
Else
PSet buffer,(x,y),fgcol
End If
End If
bits = bits Shr 1
Next
row +=1
Next
xpos +=f.breit
If xpos > xend Then Exit For
Next
End Sub
Function set_fbfont (ByVal x As Integer) As Integer
Dim As Integer breit, hoch
ScreenInfo breit, hoch
Select Case x
Case 8, 14, 16 'nur 8, 14 oder 16 funktioniert richtig
Width breit\8, hoch\x ' hier wird auto. Cls ausgeführt
Case Else
Return 0 'etwas lief schief
End Select
Return 1 'Font erfolgreich gesetzt
End Function
declare function center (text as string,byval von as integer=0,byval bis as integer=-1)as integer
function center (text as string,byval von as integer=0,byval bis as integer=-1)as integer
dim as integer lang=len(text)*8,ges,we,a,b
dim as single ab
screeninfo a,b
if bis=-1 then bis=b:ab=1.5 else ab=2
if von>bis then ges=von-bis:we=bis else ges=bis-von:we=von
return (ges/ab)-(lang/2)+we
end function
declare function getfont() as integer
function getfont() as integer
dim as integer a,b
screeninfo a,b
return b/HIWORD(WIDTH)
end function
declare function center2(text as string) as integer
function center2(text as string) as integer
dim as integer a=len(text),b,x,y
b=(a*8)/2
screeninfo x,y
return (x/2)-b
end function
sub drawstringright(y as integer,text as string, farbe as uinteger)
dim as integer a,b
screeninfo a,b
draw string(a-(len(text)*8),y),text,farbe
end sub
declare function locright(text as string)as integer
function locright(text as string)as integer
dim as integer a,b,c=len(text)*8
screeninfo a,b
return a-c
end function
sub drawstringcenter (y as integer,text as string,farbe as uinteger)
dim as integer a,b,c=(len(text)*8)/2
screeninfo a,b
draw string ((a/2)-c,y),text,farbe
end sub
declare function Drawstring_with_mouse(x as integer,y as integer,toleranz as integer,text as string,farbe1 as uinteger,farbe2 as uinteger)as integer
function Drawstring_with_mouse(x as integer,y as integer,toleranz as integer,text as string,farbe1 as uinteger,farbe2 as uinteger)as integer
dim as integer mx,my,mbut,l=len(text)*8,font=getfont,b1
getmouse mx,my,,mbut
if mx>x-toleranz and mx<(x+l)+toleranz and my>y-toleranz and my<(y+font)+toleranz then
draw string(x,y),text,farbe2:b1=1
else
draw string(x,y),text,farbe1:b1=2
end if
select case b1
case 1
if mbut=0 then return 1
if mbut=1 then return 2
if mbut=2 then return 3
if mbut=3 then return 4
if mbut=4 then return 5
if mbut=5 then return 6
if mbut=6 then return 7
if mbut=7 then return 8
case 2
if mbut=0 then return 9
if mbut=1 then return 10
if mbut=2 then return 11
if mbut=3 then return 12
if mbut=4 then return 13
if mbut=5 then return 14
if mbut=6 then return 15
if mbut=7 then return 16
case else
return 0
end select
end function
declare function button (x as integer,y as integer,text as string,byval f1 as uinteger=rgb(200,200,200), _
byval f2 as uinteger=rgb(0,0,0),byval f3 as uinteger=rgb(0,0,255),byval f4 as uinteger=rgb(255,255,255)) as integer
function button (x as integer,y as integer,text as string,byval f1 as uinteger=rgb(200,200,200), _
byval f2 as uinteger=rgb(0,0,0),byval f3 as uinteger=rgb(0,0,255),byval f4 as uinteger=rgb(255,255,255)) as integer
if text="" then return -1:exit function
dim as integer breit=len(text)*8,mx,my,but,re
getmouse mx,my,,but
if mx>x and mx<x+breit+20 and my>y and my<y+24 then
line (x,y)-(x+breit+20,y+24),f3,bf
Draw string (x+10,y+4),text,f4
return but
else
line (x,y)-(x+breit+20,y+24),f1,bf
Draw string (x+10,y+4),text,f2
return 0
endif
end function
function bcolor as uinteger
return HIWORD(color)
end function
function vcolor as uinteger
return loWORD(color)
end function
namespace net.fb.sys.console
''
function getStdIn() as integer
static as integer h = -1
if( h = -1 ) then
h = freefile
open cons for input as #h
end if
function = h
end function
''
function getStdOut() as integer
static as integer h = -1
if( h = -1 ) then
h = freefile
open cons for output as #h
end if
function = h
end function
''
sub print overload ( byval v as string )
.print #getStdOut(), v;
end sub
''
sub printnl overload ( byval v as string )
.print #getStdOut(), v
end sub
''
sub printnl overload ( byval v as integer )
.print #getStdOut(), str( v )
end sub
''
sub printnl overload ( byval v as uinteger )
.print #getStdOut(), str( v )
end sub
''
sub printnl overload ( byval v as longint )
.print #getStdOut(), str( v )
end sub
''
sub printnl overload ( byval v as ulongint )
.print #getStdOut(), str( v )
end sub
''
sub printnl overload ( byval v as double )
.print #getStdOut(), str( v )
end sub
end namespace
'console.print
sub printcursor (byref lin as integer,byref row as integer,byref vis as integer)
DIM AS INTEGER pst
pst = LOCATE
row = LOBYTE(pst)
lin = LOWORD( HIBYTE(pst) )
vis = HIWORD(pst)
end sub[/b]
| Zusätzliche Informationen und Funktionen | |||||||
|---|---|---|---|---|---|---|---|
|
|||||||
Bearbeiten
Versionen