[B3D] Funny 3D Explorer

Übersicht BlitzBasic Codearchiv

Neue Antwort erstellen

BlitzChecker

Betreff: [B3D] Funny 3D Explorer

BeitragDi, Jan 24, 2006 20:39
Antworten mit Zitat
Benutzer-Profile anzeigen
Ich hab grad auf BlitzBasic.com nen guten Code gefunden. Ich dachte ich poste ihn hier, da ihn sicherlich viele gebrauchen können:

Code: [AUSKLAPPEN]
; 3D File-Explorer

Graphics3D 640,480,16,2
SetBuffer BackBuffer()

Global gw#=GraphicsWidth()
Global gh#=GraphicsHeight()
MoveMouse gw/2,gh/2

cam=CreateCamera()
Global uni=CreateSphere(7,cam)
MoveEntity cam,0,2,-6
li=CreateLight()
RotateEntity li,80,30,30
ScaleEntity uni,100,100,100
FlipMesh uni
EntityOrder uni,1
texname$="space.jpg"
If FileType(texname$)=0
unitex=CreateTexture(128,128)
SetBuffer TextureBuffer(unitex)
For i=0 To 10000
  Color Rand(255), Rand(255), Rand(255)
  Plot  Rand(128), Rand(128)
Next
SetBuffer BackBuffer()
Else
unitex=LoadTexture(texname$)
EndIf
EntityTexture uni,unitex

Global fls#=25000 ;max 25000 Files in one Folder
Dim fb_icon(fls),fb_name$(fls),fb_type(fls),fb_tex(fls),fb_sel(fls)

Global rheight#=4 ; x space between icons
Global rwidth#=5  ; y space between icons
Global fperline#=3 ; number of icon columns

Global iconw#=2.0 ; icon scaling
Global iconh#=1.0
Global icond#=.5
Global stexx#=1.0 ; texure scaling
Global stexy#=2.0
ClearTextureFilters

font=LoadFont("Tahoma",17)
SetFont font


mx100#=(gw/2)*.9
my100#=(gh/2)*.9
Global camxi#=5
Global camyi#=0
Global camzi#=-9.2
Global camx#=camxi#
Global camy#=camyi#
Global camz#=camzi#

RefreshDir()

; -------------------------------------------MAIN-------------------------------------------
While KeyDown(1)=0
mx#=MouseX()
my#=MouseY()

If my<my100
  If camy<1
   sty#=((my100-my)/150)^2
   camy=camy+sty
   If camy>1 Then camy=1
  EndIf
EndIf
If my>gh-my100
  If camy>(0-(Floor(fls/fperline)*rheight))
   sty#=((my100-(gh-my))/150)^2
   camy=camy-sty
   If camy<(0-(Floor(fls/fperline)*rheight)) Then camy=(0-(Floor(fls/fperline)*rheight))
  EndIf
EndIf

If mx>gw-mx100
  If camx<(fperline)*rwidth
   stx#=(mx100-(gw-mx))/500
   camx=camx+stx
   If camx>(fperline)*rwidth Then camx=(fperline)*rwidth
  EndIf
EndIf
If mx<mx100
  If camx>-rwidth
   stx#=(mx100-mx)/500
   camx=camx-stx
   If camx<-rwidth Then camx=-rwidth
  EndIf
EndIf

If MouseHit(1)
  oldmhitt=mhitt
  mhitt=MilliSecs()
  If (mhitt-oldmhitt)<300 Then
   ; -----------------------------is dooubleclick!
   p=CameraPick(cam,mx,my)
   If p<>0
    picked_i=-1
    For i=0 To fls
     If fb_icon(i)=p
      picked_i=i
      Exit
     EndIf
    Next
    If picked_i>-1
    For roro=0 To 1000
     dx#=(EntityX(fb_icon(picked_i),1)-EntityX(cam))/10.0;-EntityX(cam)
     dy#=(EntityY(fb_icon(picked_i),1)-EntityY(cam))/10.0;-EntityY(cam)
     dz#=(EntityZ(fb_icon(picked_i),1)-EntityZ(cam))/10.0;-EntityZ(cam)
     PositionEntity cam,EntityX(cam,1)+dx,EntityY(cam,1)+dy,EntityZ(cam,1)+dz,1
     TurnEntity uni,.1,.1,.1
     RenderWorld()
     PathInfo()
     Flip
     If dx<.1 And dy<.1 And dz<.1 Then Exit
    Next
    placebo=CopyEntity(fb_icon(picked_i))
;    FreeEntity fb_icon(picked_i)
    If fb_type(picked_i)=2
     ChangeDir(fb_name$(picked_i))
    EndIf
    EntityParent placebo,cam
    camx#=camxi#
    camy#=camyi#
    camz#=camzi#
    MoveMouse gw/2,gh/2
    PositionEntity cam,camx,camy,camz,1
   
    If Instr(fb_name$(picked_i),".")<>0 And fb_name$(picked_i)<>".." And fb_type(picked_i)=1
     ; check Media Type and probably do something (some examples)
     ext$=Right$(fb_name$(picked_i), Len(fb_name$(picked_i))-Instr(fb_name$(picked_i),"."))
;Print
;Color 255,0,0
;     Print ext$
;     WaitKey()
     Select Upper$(ext$)
      Case "TXT"
       ExecFile "notepad.exe "+fb_name$(picked_i)
      Case "EXE"
       ExecFile fb_name$(picked_i)
      Case "HTM",".HTML"
       ExecFile fb_name$(picked_i)
      Case "BB"
       ExecFile fb_name$(picked_i)
     End Select
    EndIf

    RemoveAll()
    RefreshDir()


    For al#=1.0 To 0.0 Step -.05
     EntityAlpha placebo,al#
     TurnEntity uni,.1,.1,.1
     RenderWorld()
     PathInfo()
     Flip
    Next
    FreeEntity placebo
    EndIf
   EndIf   
   Goto done
  Else
   ; -----------------------------is single click
   p=CameraPick(cam,mx,my)
   If p<>0
    picked_i=-1
    For i=0 To fls
     If fb_icon(i)=p
      picked_i=i
      Exit
     EndIf
    Next
    If picked_i>-1
     For i=0 To fls
      If fb_sel(i)<>0
       If i<>picked_i
        fb_sel(i)=0
        EntityColor fb_icon(i),255,255,255
       EndIf
      EndIf
     Next
     fb_sel(picked_i)=fb_sel(picked_i)Xor 1
     If fb_sel(picked_i)=1
      EntityColor fb_icon(picked_i),75,75,255
     Else
      EntityColor fb_icon(picked_i),255,255,255
     EndIf
    EndIf
   EndIf
  EndIf
  .done
EndIf


If KeyDown(200)
  camz=camz+.1
EndIf
If KeyDown(208)
  camz=camz-.1
EndIf
PositionEntity cam,camx,camy,camz,1
TurnEntity uni,.1,.1,.1
RenderWorld()
PathInfo()
Flip
Wend
;--------------------------------------------eo main ------------------------------------

End

Function RefreshDir()


; Define what folder to start with ...
folder$=CurrentDir$()
myDir=ReadDir(folder$)
fls=0
Repeat
fb_name$(fls)=NextFile$(myDir)
If fb_name$(fls)<>"."
  If fb_name$(fls)="" Then Exit
   folder2$=folder$
   If Right$(folder2$,1)<>"\"
    folder2$=folder2$+"\"
   EndIf
   If FileType(folder2$+fb_name$(fls)) = 2 Then
    fb_type(fls)=2
   Else
    fb_type(fls)=1
   End If
  fls=fls+1
EndIf
Forever
CloseDir myDir
fls=fls-1





;fls#=Rand(10,100)
;Dim fb_icon(fls),fb_name$(fls),fb_type(fls),fb_tex(fls),fb_sel(fls)

For i=0 To fls
fb_icon(i)=CreateCube()
y=Floor(i/fperline)
x=i-(y*fperline)
PositionEntity fb_icon(i),x*rwidth,-(y*rheight),0
fb_tex(i)=CreateTexture(128,128)
SetBuffer TextureBuffer(fb_tex(i))
If fb_type(i)=2
  Color 127,127,0
  Rect 0,0,256,256,1
Else
  Color 127,127,127
  Rect 0,0,256,256,1
EndIf
If StringWidth(fb_name$(i))<=126
Color 255,255,255
Text 64,0,fb_name$(i),1,0
Color 0,0,0
Text 65,1,fb_name$(i),1,0
Else
lin$=""
wchar=1
ycount=0
While wchar<=Len(fb_name$(i))
  While StringWidth(lin$)<=122 And wchar<=Len(fb_name$(i))
   lin$=lin$+Mid$(fb_name$(i),wchar,1)
   wchar=wchar+1
  Wend
  If wchar<Len(fb_name$(i))
   lin$=Left$(lin$,Len(lin$)-1)
   wchar=wchar-1
  EndIf
  Color 255,255,255
  Text 64,0+ycount*StringHeight(fb_name$(i)),lin$,1,0
  Color 0,0,0
  Text 65,1+ycount*StringHeight(fb_name$(i)),lin$,1,0
  lin$=""
  ycount=ycount+1
Wend
EndIf
SetBuffer BackBuffer()
ScaleTexture fb_tex(i),stexx,stexy
EntityTexture fb_icon(i),fb_tex(i)
EntityPickMode fb_icon(i),2
ScaleEntity fb_icon(i),iconw,iconh,icond
EntityFX fb_icon(i),16
fb_sel(i)=0
Next

End Function

Function RemoveAll()
For i=0 To fls
  FreeEntity fb_icon(i)
  FreeTexture fb_tex(i)
Next
End Function

Function PathInfo()
Color 127,127,127
Text 0,0,CurrentDir$()
Color 255,255,255
Text 1,1,CurrentDir$()
End Function[/syntax]
www.xairro.com

Lunatix

BeitragDi, Jan 24, 2006 20:56
Antworten mit Zitat
Benutzer-Profile anzeigen
Das ist geil... cool.
[size=9]Pro|gram|mier|er: Ein Organismus, der Koffein in Software umwandelt.
Geben Sie eine beliebige 11-stellige Primzahl ein, um fortzusetzen...

AMY

BeitragMi, Feb 01, 2006 21:55
Antworten mit Zitat
Benutzer-Profile anzeigen
Ja schon cool bloss hab ich n paar fehler gefunden.
z.b.
statt
ext$=Right$(fb_name$(picked_i), Len(fb_name$(picked_i))-Instr(fb_name$(picked_i),"."))

muss es heissen:
Repeat
ESC=instr$(fb_name$(picked_i),".",backupESC)
bachupesc=esc+1
until esc=0
ext$=mid$(fb_name$(picked_i),backupesc)
denn dateinamen können auch mitten im Namen einen Punkt enthalten. Das wird hiermit ausgedchaltet
Projekte: www.amyscbi.de
I never comment my sourcecode. What's HARD to write must be HARD to read!

Neue Antwort erstellen


Übersicht BlitzBasic Codearchiv

Gehe zu:

Powered by phpBB © 2001 - 2006, phpBB Group