TGC Codebase Backup



Windows style menu by dark coder

24th Oct 2004 16:48
Summary

This almost replicates the windows menu system but its all coded in dbp :)



Description



Code
                                    ` This code was downloaded from The Game Creators
                                    ` It is reproduced here with full permission
                                    ` http://www.thegamecreators.com
                                    
                                    sync on
autocam off

make_menu()
add_drop("File") : `drop 1
add_drop("Edit") : `drop 2
add_drop("Create") : `drop 2

add_sub_drop(1,"Load") : ` sub drop 1
add_sub_drop(1,"Save") : ` sub drop 2
add_sub_drop(1,"Delete") : ` sub drop 1
add_sub_drop(1,"Exit") : ` sub drop 3

add_sub_drop(2,"Undo") : ` sub drop 1
add_sub_drop(2,"Redo") : ` sub drop 1

add_sub_drop(3,"Model") : ` sub drop 1
add_sub_drop(3,"Music") : ` sub drop 1

add_sub_sub_drop(3,1,"Cube") : `sub sub drop 1
add_sub_sub_drop(3,1,"Sphere") : `sub sub drop 1
add_sub_sub_drop(3,1,"Cylinder") : `sub sub drop 1

add_sub_sub_drop(3,2,"Loop 1") : `sub sub drop 1
add_sub_sub_drop(3,2,"Loop 2") : `sub sub drop 1
add_sub_sub_drop(3,2,"Loop 3") : `sub sub drop 1
add_sub_sub_drop(3,2,"Loop 4") : `sub sub drop 1
add_sub_sub_drop(3,2,"Loop 5") : `sub sub drop 1
add_sub_sub_drop(3,2,"Loop 6") : `sub sub drop 1
add_sub_sub_drop(3,2,"Loop 7") : `sub sub drop 1
add_sub_sub_drop(3,2,"Loop 8") : `sub sub drop 1
add_sub_sub_drop(3,2,"Loop 9") : `sub sub drop 1

add_sub_sub_drop(1,1,"Model") : `sub sub drop 1
add_sub_sub_drop(1,1,"Sound") : `sub sub drop 1
add_sub_sub_drop(1,1,"Music") : `sub sub drop 1
add_sub_sub_drop(1,1,"Model") : `sub sub drop 1
add_sub_sub_drop(1,1,"Bitmap") : `sub sub drop 1

position camera 0,1000,0
set camera fov 5
point camera 0,0,0


make object cube 1,1
`color object 999,rgb(255,255,255)

do

return$=update_menu()
if return$="Exit" then end

sync
loop

`==================================
function drop_count()
 count=count1(0)
endfunction count
`==================================
function make_menu()
 dim names1(50) as string
 dim names2(50,50) as string
 dim names3(50,50,50) as string
 dim count1(10)
 dim count2(50)
 dim count3(50,50)
 set text font "tahoma"
 set text size 14
endfunction
`==================================
function add_drop(name as string)
 count1(0)=count1(0)+1
 names1(count1(0))=name
endfunction
`==================================
function add_sub_drop(pos,name as string)
 count2(pos)=count2(pos)+1
 names2(pos,count2(pos))=name
endfunction
`==================================
function add_sub_sub_drop(pos,down,name as string)
 count3(pos,down)=count3(pos,down)+1
 names3(pos,down,count3(pos,down))=name
endfunction
`==================================
function update_menu()
mg=count1(9)
mx=mousex()
my=mousey()
count1(10)=mg
mg=mouseclick()
count1(9)=mg
mc=0
if mg=1 and count1(10)=0 then mc=1

check=0
colour(1) : box 0,0,screen width(),18
colour(2) : line 0,18,screen width(),18
colour(4) : line 0,19,screen width(),19
`================= DROP
wid=5
if count1(0)>0
for i=1 to count1(0)
 tl=text width(names1(i))
 t2=text height(names1(i))
  text wid,1,names1(i)
  line wid,text height(mid$(names1(i),1)),wid+text width(mid$(names1(i),1))-1,text height(mid$(names1(i),1))
  `=========
  wrt=wid+text width(names1(i))
  if mx>wid-5 and mx<wrt and my>0 and my<20
  colour(3) : line wid-5,0,wrt,0 : line wid-5,0,wid-5,17 : colour(2) : line wrt,0,wrt,17 : line wid-5,17,wrt,17
  if mc=1 then colour(2) : line wid-5,0,wrt,0 : line wid-5,0,wid-5,17 : colour(3) : line wrt,0,wrt,17 : line wid-5,17,wrt,17
     colour(4)
     if count1(1)>0 then count1(1)=i : count1(2)=wid : count1(5)=wrt
    if mc=1
     check=1
     count1(1)=i
     count1(6)=0
     count1(2)=wid
     if count2(count1(1),0)=0 then return$=names1(i)
    endif
   endif
  `=========
  wid=wid+text width(names1(i))+15
next i
endif
`======================
`================= SUB DROP
if count2(count1(1),0)>0
wid=count1(2)
he=20+(count2(count1(1),0)*15)
wrt=count1(5)
colour(2) : line wid-5,0,wrt,0 : line wid-5,0,wid-5,17 : colour(3) : line wrt,0,wrt,17 : line wid-5,17,wrt,17
wid=count1(2)-5
colour(1) : box wid,20,wid+100,he
colour(2) : line wid,he-1,wid+99,he-1 : line wid+99,20,wid+99,he
colour(3) : line wid,21,wid+100,21 : line wid+1,20,wid+1,he
colour(4) : line wid,he,wid+100,he : line wid+100,20,wid+100,he
h=20
for i=1 to count2(count1(1),0)
 colour(4)
    count1(3)=0
   if mx>wid-3 and mx<wid+97 and my>(i*15) and my<15+(i*15)
    check=1
    count1(3)=i
    if mc=1 then count1(6)=i : count1(8)=h
    if mc=1 and count3(count1(1),count1(6))=0 then return$=names2(count1(1),i) : count1(1)=0
   endif
 if i=count1(3) then colour(2) : box wid+3,7+(i*15),wid+98,18+(i*15) :  colour(5)
  text wid+5,h,names2(count1(1),i)
  a=wid+96
  if count3(count1(1),i)>0
  h=h+7
   dot a,h : dot a-1,h : dot a-2,h : dot a-3,h : dot a-1,h+1 : dot a-1,h-1
   dot a-2,h+1 : dot a-2,h+2 : dot a-2,h-1 : dot a-2,h-2 : dot a-3,h+3
   dot a-3,h-1 : dot a-3,h-2 : dot a-3,h-3 : dot a-3,h+1 : dot a-3,h+2
  h=h-7
  endif
  colour(4)
  h=h+15
next i
endif
`======================
`================= SUB SUB DROP
if count3(count1(1),count1(6))>0
 colour(1)
  h=7+count1(6)*15
  he=5+(count1(6)*15)+(count3(count1(1),count1(6))*15)
  `h=5+count1(6)*15
 box wid+100,5+count1(6)*15,wid+200,5+(count1(6)*15)+(count3(count1(1),count1(6))*15)
 wid=wid+100
colour(2) : line wid,he-1,wid+99,he-1 : line wid+99,h,wid+99,he
colour(3) : line wid,h-1,wid+99,h-1 : line wid,h,wid,he
colour(4) : line wid,he,wid+100,he : line wid+100,h,wid+100,he
 for i=1 to count3(count1(1),count1(6))
 colour(4)
    count1(3)=0
   if mx>wid-3 and mx<wid+97 and my>(i*15) and my<15+(i*15)
    check=1
    count1(3)=i
    if mc=1 then return$=names3(count1(1),count1(6),i) : count1(1)=0 : count1(6)=0
   endif
 if i=count1(3) then colour(2) : box wid+3,7+(i*15),wid+97,18+(i*15) :  colour(5)
  text wid+5,h-2,names3(count1(1),count1(6),i)
  colour(4)
  h=h+15
 next i
endif
`======================
if mc=1 and check=0 then count1(1)=0 : count1(6)=0

endfunction return$
`==================================
function colour(num)
if num=1 then ink get_colour(4),0
if num=2 then ink get_colour(16),0
if num=3 then ink get_colour(20),0
if num=4 then ink get_colour(21),0
if num=5 then ink rgb(255,255,255),0
endfunction

function get_colour(num)
  local col as dword
  load dll "user32.dll",1
  col = call dll(1,"GetSysColor", num)
  delete dll 1
  col = rgb(rgbb(col), rgbg(col), rgbr(col))
endfunction col
`==================================