File Browser

User projects written in or related to FreeBASIC.
bcohio2001
Posts: 508
Joined: Mar 10, 2007 15:44
Location: Ohio, USA
Contact:

Re: File Browser

Postby bcohio2001 » Oct 20, 2017 4:29

Gave you few days ... Got the code and all I got was errors. Missing and include at the top? The code looks right, not sure why
the errors are popping up.
C:\FreeBASIC-1.05.0-win64\fbc -s console -exx "FbTemp.bas"
FbTemp.bas(8) error 14: Expected identifier, found ' ' in '   foreground As ULong'
FbTemp.bas(15) error 14: Expected identifier, found ' ' in '   highlightFont As UByte Ptr'
FbTemp.bas(20) error 159: Expected class or UDT identifier, found 'tMMcolors' in 'Property tMMcolors.text(col As ULong)'
FbTemp.bas(60) error 58: Illegal specification, at parameter 2 ( ) of mouseMenu() in '                    separator As String = "", _'
FbTemp.bas(66) error 3: Expected End-of-Line, found ' ' in '                      '
FbTemp.bas(67) error 3: Expected End-of-Line, found ' ' in '  'mode bit 0 set (1) -> omitted for downward compatibility'
FbTemp.bas(68) error 3: Expected End-of-Line, found ' ' in '  'mode bit 1 set (2, MM_FRAME) -> draw a frame around the text'
FbTemp.bas(69) error 3: Expected End-of-Line, found ' ' in '  'mode bit 2 set (4, MM_SHIFT) -> shift the text right half a character'
FbTemp.bas(70) error 3: Expected End-of-Line, found ' ' in '  'mode bit 3 set (8, MM_BUTTONUP) -> action at button up (default: action at button down)'
FbTemp.bas(71) error 3: Expected End-of-Line, found ' ' in '  'mode bit 4 set (16, MM_CONTINUE) -> continued action at button down (default: single shot)'
FbTemp.bas(71) error 132: Too many errors, exiting

Build error(s)

Also same errors with V1.04 Win32
grindstone
Posts: 637
Joined: May 05, 2015 5:35
Location: Germany

Re: File Browser

Postby grindstone » Oct 20, 2017 9:09

I can't reproduce that, here it works. Maybe an accidently change in your copy of the code?

Anyway, I replaced the code with the actual version.
BasicCoder2
Posts: 3338
Joined: Jan 01, 2009 7:03

Re: File Browser

Postby BasicCoder2 » Oct 20, 2017 20:06

The code compiles and runs ok for me.
The sliders do not respond to the mouse but do work with the keyboard.
It needs a go back button to replace PgUp and also an OPEN and CLOSE button.
What might be a challenge is to duplicate the tree structure of the directory in the left list with mouse and keyboard to open and close branches.
It also needs to be a stand alone piece of code (object?) that anyone can use by an #include statement probably requiring a complete rewrite.
An easier solution of course is to learn to use a GUI library with it built in :) It was just a retro project for me.
After adding some mouse stuff myself with a bit of cowboy programming I decided this is silly I need to use a GUI library even if I wrote a simple one myself. This way the guts of the directory program is not filled with messy long winded GUI code and the workings of the directory code becomes easier to read and understand.
.
bcohio2001
Posts: 508
Joined: Mar 10, 2007 15:44
Location: Ohio, USA
Contact:

Re: File Browser

Postby bcohio2001 » Oct 21, 2017 5:38

It was the Copy/Paste that gave me all those errors, instead of tabs, inserted spaces. But only in the 'added' portion of code.
Not sure why that would make a difference, but it did.
As soon as I correct all the paste errors will get back with ya on it.
grindstone
Posts: 637
Joined: May 05, 2015 5:35
Location: Germany

Re: File Browser

Postby grindstone » Oct 21, 2017 8:11

BasicCoder2 wrote:The sliders do not respond to the mouse but do work with the keyboard.
Yes, they only visualize (yet) which segment of the list is displayed.
It needs a go back button to replace PgUp and also an OPEN and CLOSE button.
Implementing such buttons is quite easy. PgUp is clear to me, but what do you want to OPEN or CLOSE?
What might be a challenge is to duplicate the tree structure of the directory in the left list with mouse and keyboard to open and close branches.
Call me dense, but I don't understand what you mean.

What I'm working at currently is that if a file is highlighted in the left window, the content of this file (at least a part of it for a quick overview) is displayed in the right window. For .bmp it already works, now I'm implementing text files (.txt, .bat, .lst etc.). Further suggestions are welcome.
grindstone
Posts: 637
Joined: May 05, 2015 5:35
Location: Germany

Re: File Browser

Postby grindstone » Oct 21, 2017 10:39

New update. Now displaying an overview of the contents for some types of files.
BasicCoder2
Posts: 3338
Joined: Jan 01, 2009 7:03

Re: File Browser

Postby BasicCoder2 » Oct 21, 2017 11:28

grindstone wrote:Implementing such buttons is quite easy. PgUp is clear to me, but what do you want to OPEN or CLOSE?

Looking at the example in FBIDE to open a .bas file I see it is Cancel not Close but I meant the same thing.
Open means you want to go ahead and open the file and load it into your program which might be an editor, paint program etc.
However I see you have implemented the buttons just replace the 'dunno for code in an application to load the data or to terminate the load when the directory is being used that way.
There might also be a drop down combo box to choose the kind of file you might want to load or save and a text box to enter a name for a file. There are all sorts of other functionality you can add as well.

I like how you display a bitmap file. I did something like that with loading an image into a picture box control. Each image was displayed as a thumbnail.
viewtopic.php?f=3&t=20779&hilit=Picture+box

The tree structure is C:\ as the trunk of the tree with each folder a branch which in turn can have other branches (folders) and at the ends you have the leaves (files). See below.


Code: Select all

' Load file
' +----------------------------------------------------------------------------------------------------+
' | [ <- ]  [ -> ]   > Computer > OS(C:) > FreeBasic > bitmaps >                                       |
' +----------------------------------------------------------------------------------------------------+
' | Create New folder                                                                                  |
' +-----------------------------+--+----------------------------------------------------------------+--+
' |> C:\                        |  | Name          Date                 Type          Size   Tags   |  |
' |  > FireFly                  |  |                                                                |  |
' |    > CodeStore              |  | compress       5/31/2017  3:32 PM  File folder                 |  |
' |    > CustomControls         |  | fileToData     5/31/2017 12:56 PM  File folder                 |  |
' |    > Keywords               |  | old            5/29/2017  6:33 PM  File folder                 |  |
' |    > Projects               |  | birdData.bas   5/31/2017  2:15 AM  BAS file      26 KB         |  |
' |      > Project1             |  | birdData2.bas  5/31/2017  2:50 PM  BAS file      14 KB         |  |
' |        > forms              |  | codePixels.bas 5/30/1017  3:24 PM  BAS fle        3 KB         |  |
' |        > images             |  |                                                                |  |
' |        > modules            |  |                                                                |  |
' |        > release            |  |                                                                |  |
' |        > release64          |  |                                                                |  |
' |      > Settings             |  |                                                                |  |
' |  > FreeBasic                |  |                                                                |  |
' |    > Misc                   |  |                                                                |  |
' |    > bitmaps                |  |                                                                |  |
' |      > compress             |  |                                                                |  |
' |      > sprites              |  |                                                                |  |
' +-----------------------------+--+----------------------------------------------------------------+--+
'               +-----------------------------------------+           +-------------------+-+
'    File name: |.bas                                     |           | FBFiles(*.bas)    |v|
'               +-----------------------------------------+           +-------------------+-+
'
'                                                                     +-------+-+    +--------+
'                                                                     | Open  |v|    | Cancel |
'                                                                     +-------+-+    +--------+
grindstone
Posts: 637
Joined: May 05, 2015 5:35
Location: Germany

Re: File Browser

Postby grindstone » Oct 21, 2017 14:21

To get a list with a tree structure you'll need a different approach. This snippet creates an ordered list of all directories and subdirectories of drive C:\

Code: Select all

#Include "dir.bi"

Dim As String g
ReDim As String dirList(0)
Dim As Integer startindex, endindex, maxindex, index, i, x, xrem

dirlist(0) = "C:"
startindex = LBound(dirlist)
endindex = UBound(dirlist)

Do
   For i = startindex To endindex
      g = Dir(dirlist(i) + "\*.", fbDirectory) '1st subdirectory
      Do While Len(g) 'subdirectory found
         Select Case g
        Case ".",".."
          'ignore
        Case Else
          x = UBound(dirlist) + 1
          ReDim Preserve dirlist(x)
          dirlist(x) = dirlist(i) + "\" + g 'write new subdirectory with path to the array          '? x;" ";UBound(dirlist);" ";dirlist(UBound(dirlist))
         End Select
      g = Dir("",fbDirectory) 'next subdirectory
      Loop
   Next
   'next level
   startindex = endindex + 1
   endindex = x
   
   If x = xrem Then 'no new directory found
      Exit Do 'terminate loop
   Else
      xrem = x
   EndIf
Loop

'order directory list
Dim As boolean ord = TRUE
Do
   ord = TRUE
   For x = 1 To UBound(dirlist) - 1
      If dirlist(x) > dirlist(x + 1) Then
         Swap dirlist(x), dirlist(x + 1)
         ord = FALSE
      EndIf
   Next
Loop Until ord

Open ExePath + "\dirlist.txt" For Output As #1
For y As Integer = LBound(dirlist) To UBound(dirlist)
   Print #1, dirlist(y)
Next
Close

?"DONE"

Sleep
The next step is to replace the leading identical folder names with appropriate indentions. Maybe tomorrow, I'm too tired now...
BasicCoder2
Posts: 3338
Joined: Jan 01, 2009 7:03

Re: File Browser

Postby BasicCoder2 » Oct 21, 2017 22:07

Found this and it works inside a command prompt window.
https://cmatskas.com/generate-ascii-fol ... with-tree/
.
grindstone
Posts: 637
Joined: May 05, 2015 5:35
Location: Germany

Re: File Browser

Postby grindstone » Oct 22, 2017 12:20

To get a complete folder list is not as trivial as it seems at first glance, but I think I got it now:

Code: Select all

#Include "dir.bi"

Type tTree
   As String path
   Declare Property level As Integer
   Declare Property folder As String
End Type

Property tTree.level As Integer
   Dim As Integer lv
   For x As Integer = 0 To Len(this.path) - 1
      If this.path[x] = Asc("\") Then
         lv += 1
      EndIf
   Next
   Return lv
End Property

Property tTree.folder As String
   Return Mid(this.path, InStrRev(this.path, "\") + 1)
End Property

Dim As String g
ReDim As tTree dirList(0), dirlist2(0)
Dim As Integer startindex, endindex, maxindex, index, i, x, xrem, retatt
Dim As boolean ord

dirlist(0).path = "C:"
dirlist2(0) = dirlist(0)
startindex = 0
endindex = 0

Print "reading folder list..."

Do
   For i = startindex To endindex
      g = Dir(dirlist(i).path + "\*", -1, @retatt) '1st subdirectory
      Do While Len(g) 'subdirectory found
         If (retatt And fbDirectory) Then
            Select Case g
               Case ".",".."
                  'ignore
               Case Else
                  x = UBound(dirlist) + 1
                  ReDim Preserve dirlist(x)
                  ReDim Preserve dirlist2(x)
                  dirlist(x).path = dirlist(i).path + "\" + g 'write new subdirectory with path to the array
                  dirlist2(x) = dirlist(x) 'copy to ordered list
                  For y As Integer = UBound(dirlist2) To 1 Step -1
                     'shift new entry to the correct place
                     If dirlist2(y).path < dirlist2(y - 1).path Then
                        Swap dirlist2(y), dirlist2(y - 1)
                     Else
                        Exit For
                     EndIf
                  Next
            End Select
         EndIf
         g = Dir("", -1, @retatt) 'next subdirectory
      Loop
   Next
         
   'next level
   Print ".";
   startindex = endindex + 1
   endindex = x
   
   If x = xrem Then 'no new directory found
      Exit Do 'terminate loop
   Else
      xrem = x
   EndIf
Loop
Print

ReDim dirlist(0) 'free memory
Print UBound(dirlist2);" folders"
Print
Print "saving folder list..."

Open ExePath + "\dirlist.txt" For Output As #1
For y As Integer = LBound(dirlist2) To UBound(dirlist2)
   Print #1, dirlist2(y).path
Next
Close

Print
Print "making tree list..."

Open ExePath + "\tree.txt" For Output As #1
For y As Integer = LBound(dirlist) To UBound(dirlist)
   With dirlist(y)
      For z As Integer = 0 To .level
         Print #1, "  ";
      Next
      Print #1, .folder
   End With
Next
Close

Print
Print "DONE"

Sleep
Last edited by grindstone on Oct 23, 2017 9:15, edited 1 time in total.
BasicCoder2
Posts: 3338
Joined: Jan 01, 2009 7:03

Re: File Browser

Postby BasicCoder2 » Oct 22, 2017 21:36

That's really neat grindstone well done. You may have noticed I also asked the question in the general section and received some nice example code from bcohio2001. Will be interesting to see if you go any further with the project.
.
grindstone
Posts: 637
Joined: May 05, 2015 5:35
Location: Germany

Re: File Browser

Postby grindstone » Oct 23, 2017 9:14

BasicCoder2 wrote:That's really neat grindstone well done
Thank you, but nevertheless it contains a fallacy (the list mustn't be sorted before it's complete). I've replaced the code above with the fixed version. This one should work correct (I hope).
Will be interesting to see if you go any further with the project
Why not? I'll try to make some adaptions and then insert it in your file browser.
bcohio2001
Posts: 508
Joined: Mar 10, 2007 15:44
Location: Ohio, USA
Contact:

Re: File Browser

Postby bcohio2001 » Oct 30, 2017 0:44

This is crude. But with a few tweeks should start you out.

Code: Select all

#Ifndef DosTree_Core
#Define DosTree_Core

#Define DosTree_Core_RunTest

#Ifndef NULL
#Define NULL 0
#EndIf

#Ifndef TRUE
#Define FALSE 0
#Define TRUE Not(0)
#EndIf

/' TV_ITEM ... commctrl.bi as of v1.05
type tagTVITEMA
   mask as UINT
   hItem as HTREEITEM (type HTREEITEM as _TREEITEM ptr)
   state as UINT
   stateMask as UINT
   pszText as LPSTR
   cchTextMax as long
   iImage as long
   iSelectedImage as long
   cChildren as long
   lParam as LPARAM
end type
'/

Type DosTree_Item
   As DosTree_Item Ptr Parent 'copy of ptr
   As DosTree_Item Ptr Ptr Child 'list of children (in order)
   As Long ChildCount
   As Long SibIndex 'order
   'As String Text
   As UByte Ptr zText
   As Long zTextLen
   As Byte Expanded 'whether or not to print '+ ', '- ' or '  '
   As Byte Level 'how deep -- indentation
End Type

'simulate TreeView control
Type DosTree
   As Long SortBy 'none, assend, decend
   'graphic/console flag
   As Long Indent 'number of spaces/pixels to indent Child
   As DosTree_Item Ptr Ptr TreeList 'list of all "root" items
   As Long TreeListCount
   'these are Long for graphic
   'As Long L, R 'left right pos
   'As Long T, B 'top bottom pos
   '
   Declare Constructor(ByVal SortFlag As Long=0, ByVal IndentMe As Long=3)
   Declare Destructor()
   Declare Function AddNode(ByVal Txt As String, ByVal TheParent As DosTree_Item Ptr = NULL) As DosTree_Item Ptr
   'Declare Sub SetSort(ByVal SortFlag As Long)
   'Declare Sub SetChildIndent(ByVal IndentMe As Long)
   Declare Sub KillNode(ByRef Item As DosTree_Item Ptr)
   Declare Sub KillAll()
   Declare Function Resolve(ByVal Item As DosTree_Item Ptr, Sep As String) As String
   Declare Function GetParent(ByVal Item As DosTree_Item Ptr) As DosTree_Item Ptr
   Declare Function GetSibling(ByVal Item As DosTree_Item Ptr, ByVal D As Long) As DosTree_Item Ptr
   Declare Function GetChild(ByVal Item As DosTree_Item Ptr) As DosTree_Item Ptr
   Declare Function GetItemTxt(ByVal Item As DosTree_Item Ptr) As String
End Type

Constructor DosTree(ByVal SortFlag As Long=0, ByVal IndentMe As Long=3)
SortBy = SortFlag
Indent = IndentMe 'either spaces or pixels?????
End Constructor

Destructor DosTree()
KillAll()
End Destructor

Function DosTree.AddNode(ByVal Txt As String, ByVal TheParent As DosTree_Item Ptr = NULL) As DosTree_Item Ptr
   Dim As Long x, L = Len(Txt)
   'create item to add
   Dim As DosTree_Item Ptr AddMe = Callocate(SizeOf(DosTree_Item))
   AddMe->zTextLen = L
   AddMe->zText = Allocate(L)
   For x = 0 To L - 1
      AddMe->zText[x] = Asc(Mid(Txt, x+1, 1))
   Next
   'AddMe->Expanded = 0
   'AddMe->SibIndex = 0
   If TheParent Then
      'adding child
      AddMe->Level = TheParent->Level + 1
      AddMe->Parent = TheParent
      If TheParent->ChildCount Then
         'add sibling
         TheParent->Child = ReAllocate(TheParent->Child, (TheParent->ChildCount+1)*SizeOf(DosTree_Item Ptr))
         If SortBy Then
            For x = 0 To TheParent->ChildCount - 1
               If SortBy = 1 Then
                  'A-Z
                  If Txt < GetItemTxt(TheParent->Child[x]) Then
                     TheParent->Child[x]->SibIndex += 1 'before this
                  Else
                     AddMe->SibIndex += 1 'after this
                  EndIf
               Else
                  'Z-A
                  If Txt > GetItemTxt(TheParent->Child[x]) Then
                     AddMe->SibIndex += 1
                  Else
                     TheParent->Child[x]->SibIndex += 1
                  EndIf
               EndIf
            Next
         Else
            AddMe->SibIndex = TheParent->ChildCount
         EndIf
      Else
         TheParent->Child = Allocate(SizeOf(DosTree_Item Ptr)) 'all we are storing are pointers
      EndIf
      TheParent->Child[TheParent->ChildCount] = AddMe
      TheParent->ChildCount += 1
   Else
      'at root
      'AddMe->Level = 0 'put in for clarity
      'AddMe->Parent = NULL 'put in for clarity
      If TreeListCount Then
         'add sibling
         TreeList = ReAllocate(TreeList, (TreeListCount + 1)*SizeOf(DosTree_Item Ptr))
         If SortBy Then
            For x = 0 To TreeListCount - 1
               'set index
               If SortBy = 1 Then
                  'A-Z
                  If Txt < GetItemTxt(TreeList[x]) Then
                     TreeList[x]->SibIndex += 1 'before this
                  Else
                     AddMe->SibIndex += 1 'after this
                  EndIf
               Else
                  'Z-A
                  If Txt > GetItemTxt(TreeList[x]) Then
                     AddMe->SibIndex += 1
                  Else
                     TreeList[x]->SibIndex += 1
                  EndIf
               EndIf
            Next
         Else
            AddMe->SibIndex = TreeListCount
         EndIf
      Else
         TreeList = Allocate(SizeOf(DosTree_Item Ptr)) 'all we are storing are pointers
      EndIf
      TreeList[TreeListCount] = AddMe
      TreeListCount += 1
   EndIf
   Return AddMe
End Function

Sub DosTree.KillNode(ByRef Item As DosTree_Item Ptr)
   'does this node have children?
   While Item->ChildCount
      KillNode(Cast(DosTree_Item Ptr, Item->Child[Item->ChildCount - 1])) 'recursively call
   Wend
   '
   Dim As DosTree_Item Ptr ItemParent
   Dim As Long x, ItemFound
   '
   ItemParent = Item->Parent 'use parent ptr
   If ItemParent Then
      'removing child
      If ItemParent->ChildCount > 1 Then
         For x = 0 To ItemParent->ChildCount - 1
            If ItemParent->Child[x] <> Item Then
               If ItemParent->Child[x]->SibIndex > Item->SibIndex Then ItemParent->Child[x]->SibIndex -= 1
               If ItemFound Then ItemParent->Child[x - 1] = ItemParent->Child[x]
            Else
               ItemFound = 1
            EndIf
         Next
         ItemParent->Child = ReAllocate(ItemParent->Child, ItemParent->ChildCount*SizeOf(DosTree_Item Ptr))
      Else
         'only node
         DeAllocate(ItemParent->Child)
         ItemParent->Child = 0
      EndIf
      ItemParent->ChildCount -= 1
   Else
      'removing root item
      If TreeListCount > 1 Then
         For x = 0 To TreeListCount - 1
            If TreeList[x] <> Item Then
               If TreeList[x]->SibIndex > Item->SibIndex Then TreeList[x]->SibIndex -= 1
               If ItemFound Then TreeList[x - 1] = TreeList[x]
            Else
               ItemFound = 1
            EndIf
         Next
         TreeList = ReAllocate(TreeList, TreeListCount*SizeOf(DosTree_Item Ptr))
      Else
         'only root item
         DeAllocate(TreeList)
         TreeList = 0
      EndIf
      TreeListCount -= 1
   EndIf
   DeAllocate(Item->zText) 'no need to nullify
   DeAllocate(Item)
   Item = NULL 'nullify pointer
End Sub

Sub DosTree.KillAll()
   While TreeListCount
      KillNode(Cast(DosTree_Item Ptr, TreeList[TreeListCount - 1]))
   Wend
   'this is done in KillNode
   'DeAllocate(TreeList)
   'TreeList = 0
End Sub

Function DosTree.GetParent(ByVal Item As DosTree_Item Ptr) As DosTree_Item Ptr
   Return Item->Parent 'if root, returns NULL
End Function

Function DosTree.GetSibling(ByVal Item As DosTree_Item Ptr, ByVal D As Long) As DosTree_Item Ptr
   Dim As Long WantIndex, x
   Dim As DosTree_Item Ptr R = NULL
   '
   If D < 0 Then
      'previous/older sibling
      If Item->SibIndex = 0 Then Return NULL 'is first
      WantIndex = Item->SibIndex - 1
   Else
      'next/younger sibling
      WantIndex = Item->SibIndex + 1
   EndIf
   If Item->Parent Then
      If WantIndex >= Item->Parent->ChildCount Then Return NULL 'Item is the last
      'find this item in child array
      Do
         R = Cast(DosTree_Item Ptr, Item->Parent->Child[x])
         If R->SibIndex = WantIndex Then Exit Do
         x += 1
      Loop
   Else
      'look in TreeList
      If WantIndex >= TreeListCount Then Return NULL 'Item is the last
      Do
         R = Cast(DosTree_Item Ptr, TreeList[x])
         If R->SibIndex = WantIndex Then Exit Do
         x += 1
      Loop
   EndIf
   Return R
End Function

Function DosTree.GetChild(ByVal Item As DosTree_Item Ptr) As DosTree_Item Ptr
   If Item->ChildCount = 0 Then Return NULL 'no children
   If Item->ChildCount = 1 Then Return Cast(DosTree_Item Ptr, Item->Child[0]) 'only one child
   'return the child with SibIndex of 0
   Dim As Long RIndex
   Dim As DosTree_Item Ptr Look
   If Item->ChildCount > 1 Then
      Do
         Look = Cast(DosTree_Item Ptr, Item->Child[RIndex])
         If Look->SibIndex = 0 Then Exit Do
         RIndex += 1
      Loop
   EndIf
   Return Cast(DosTree_Item Ptr, Item->Child[RIndex])
End Function

Function DosTree.Resolve(ByVal Item As DosTree_Item Ptr, Sep As String) As String
   Dim As String R = GetItemTxt(Item) 'put it's own value in now
   Dim As DosTree_Item Ptr Looper = Item
   While Looper->Parent <> NULL
      Looper = Looper->Parent
      R = GetItemTxt(Looper) + Sep + R
   Wend
   Return R
End Function

Function DosTree.GetItemTxt(ByVal Item As DosTree_Item Ptr) As String
Dim As String R
For x As Long = 0 To Item->zTextLen - 1
   R += Chr(Item->zText[x])
Next
Return R
End Function

#Ifdef DosTree_Core_RunTest
Print "CORE TEST"
Dim As DosTree MyTree = DosTree(1,2) 'sort assending, 2 spaces over for each subfolder level
Dim As DosTree_Item Ptr P, P1, Selected

'this could be done in a loop
P = MyTree.AddNode("C:")
Selected = P 'start out on first drive

P1 = MyTree.AddNode("Folder1", P)
P1 = MyTree.AddNode("Folder2", P)
'P1 = MyTree.AddNode("SubFolder Of 2", P1)
P1 = MyTree.AddNode("Folder3", P)
P1 = MyTree.AddNode("Folder4", P)
'this one should go between Folder1 and Folder2
P1 = MyTree.AddNode("Folder18", P)

P = MyTree.AddNode("D:")
P1 = MyTree.AddNode("Folder1", P)
P1 = MyTree.AddNode("Folder2", P)
P1 = MyTree.AddNode("Folder3", P)
P1 = MyTree.AddNode("Folder4", P)

Cls
While Selected
   Print Spc(Selected->Level * MyTree.Indent); 'tab over
   'work in Expanded
   Print MyTree.GetItemTxt(Selected);" {"; 'print the tree
   Print MyTree.Resolve(Selected, "/"); "}" 'print path
   'Do first folders of drive
   P1 = MyTree.GetChild(Selected)
   While P1
      Print Spc(P1->Level * MyTree.Indent); 'tab over
      'work in Expanded
      Print MyTree.GetItemTxt(P1); 'print the tree branch
      Print " {";MyTree.Resolve(P1, "/"); "}" 'print path
      P1 = MyTree.GetSibling(P1, 1) 'next folder
   Wend
   Selected = MyTree.GetSibling(Selected, 1) 'next drive
Wend
Sleep
#EndIf 'DosTree_Core_RunTest

#EndIf
grindstone
Posts: 637
Joined: May 05, 2015 5:35
Location: Germany

Re: File Browser

Postby grindstone » Nov 05, 2017 13:13

In principle it's quite easy: You scan the directories of all hard drives, put them in a sorted list and then display it. But there is a snag: The scanning of a big drive can last more than a minute, and if you want to scan them all you can go and drink a cup of coffee while the program is working.

So it makes sense to scan only the part of the directory you want to display. And to make the sorting easier *cough* I used a chained list instead of an array. There are still some features to implement, but in general it works now:

Code: Select all

' Original code by BasicCoder2
'------------------------------------------------------------------------- '
' Modifications by MrSwiss, bcohio2001, grindstone ... Date: 2017-11-05 Time: 01:25 PM
' ======================================================================== '
'
'Mouse support added by grindstone


'********* BEGIN MOUSEMENU ***********************************
'by grindstone *** the mousemenu section can be copied into a
' seperate file (eg. "mousemenu.bi") to be included in any
' other program to provide mouse functionality
'
#Define MM_FRAME 2
#Define MM_SHIFT 4
#Define MM_BUTTONUP 8
#Define MM_CONTINUE 16

Type tMMcolors 'mouse menu colors
   foreground As ULong
   background As ULong
   frame As ULong
   foregroundhi As ULong
   backgroundhi As ULong
   framehi As ULong
   normalFont As UByte Ptr 'user defined font
   highlightFont As UByte Ptr
   Declare Property text(col As ULong)
   Declare Property bgnd(col As ULong)
End Type

Property tMMcolors.text(col As ULong)
   this.foreground = col
   this.backgroundhi = col
   this.frame = col
   this.framehi = col
End Property

Property tMMcolors.bgnd(col As ULong)
   this.foregroundhi = col
   this.background = col
End Property

#Macro PrintMenuItem(fg, bg, fr, fp)
      
   If graphic Then
      If userDefinedFont Then
         Line buffer, (xPos,yPos - 1)-(xPos + Len(text) * ch_width, yPos + ch_height), bg, bf
         Draw String buffer, (xPos + IIf(Bit(mode, 2),ch_width / 2, 0), yPos), text,, fp
         If Bit(mode, 1) Then 'draw frame around text
            Line buffer, (xPos - 1, yPos - 1)-(xPos + textWidth, yPos + ch_height), fr, b
         EndIf
      Else
         Line buffer, (xPos,yPos - 1)-(xPos + textWidth, yPos + ch_height), bg, bf
         Draw String buffer, (xPos + IIf(Bit(mode, 2),ch_width / 2, 0), yPos), text, fg
         If Bit(mode, 1) Then 'draw frame around text
            Line buffer, (xPos - 1, yPos - 2)-(xPos + 1 + textWidth, yPos + ch_height + 1), fr, b
         EndIf
      EndIf
   Else 'console window
      colorrem = Color
      cursorrem = Locate
      Color fg, bg
      Locate lin, col, 0
      Print text
      Locate HiByte(cursorrem),LoByte(cursorrem),HiWord(cursorrem) 'replace cursor
     Color LoWord(colorrem),HiWord(colorrem) 'restore colours
   EndIf
#EndMacro

Function mouseMenu(text As String, _
                    separator As String = "", _
                    xPos As Integer = 0, _
                    yPos As Integer = 0, _
                    colors As tMMcolors, _
                    mode As UByte = 0, _
                    buffer As Any Ptr = 0) As Integer
                      
  'mode bit 0 set (1) -> omitted for downward compatibility
  'mode bit 1 set (2, MM_FRAME) -> draw a frame around the text
  'mode bit 2 set (4, MM_SHIFT) -> shift the text right half a character
  'mode bit 3 set (8, MM_BUTTONUP) -> action at button up (default: action at button down)
  'mode bit 4 set (16, MM_CONTINUE) -> continued action at button down (default: single shot)
 
  #Define lin xpos
  #Define col ypos
 
  Dim As String sc_driver
  Dim As Integer mx, my, wheel, buttons
  Dim As Integer sc_width, sc_height, ch_width, ch_height, graphic
  Dim As Integer colorrem, cursorrem, x, returnValue = 0
  Dim As Integer textWidth, ch_width_n(255), ch_width_h(255)
  Dim As UByte Ptr p
  Dim As Integer Ptr hp
  Dim As boolean userDefinedFont = FALSE
  Static As Integer xrem, yrem, returnrem
   
  ScreenInfo sc_width, sc_height,,,,,sc_driver
  graphic = Len(sc_driver) '= 0 --> console window / <> 0 --> graphic screen
  If graphic Then
     With colors
        'get character size(s)
        If (.normalFont <> 0) And (.highlightFont <> 0) Then 'user defined font   
           userDefinedFont = TRUE
           p = .normalFont + IIf(.normalFont[0] = 7, 32, 4) 'points to font header
            For x = p[1] To p[2] '1st character to last character
              ch_width_n(x) = p[x + 3 - p[1]] 'write widths to array
           Next
           p = .highlightFont + IIf(.highlightFont[0] = 7, 32, 4)
            For x = p[1] To p[2]
              ch_width_h(x) = p[x + 3 - p[1]]
            Next
            hp = Cast(Integer Ptr, .normalFont)
            ch_height = hp[3] - 1
        Else
            ch_width = sc_width / LoWord(Width)
           ch_height = sc_height / HiWord(Width)
        EndIf
     End With
  EndIf
   
  If yPos = 0 Then
     yPos = yrem
  ElseIf yPos < 0 Then
     yPos = yrem - yPos
     yPos = IIf(yPos < 0, 0, yPos)
  EndIf
 
  If xPos = 0 Then
     xPos = xrem
  ElseIf xPos < 0 Then
     xPos = xrem - xPos
     xPos = IIf(xPos < 0, 0, xPos)
  EndIf
       
  xrem = xPos
  yrem = yPos
   
  If Len(separator) Then 'justify text at separator
      If graphic Then
         If userDefinedFont Then
            For x = 1 To InStr(text, separator) - 1
               xpos -= ch_width_n(text[x - 1]) 'shift xpos left
            Next
         Else
            xPos = xPos - ((InStr(text, separator) - 1) * ch_width)
         EndIf
      Else 'console window
         col = col - (InStr(text, separator))
      EndIf
  EndIf
         
   GetMouse (mx, my, wheel, buttons)
   
   If graphic Then
      If userDefinedFont Then
         For x = 0 To Len(text) - 1
            textWidth += ch_width_n(text[x])
         Next
      Else
         textWidth = Len(text) * ch_width
      EndIf
      
      If (mx >= xpos) AndAlso (mx <= xpos + textWidth) AndAlso _
          (my >= yPos) AndAlso (my <= ypos + ch_height) Then 'mouse cursor touches the text
        returnValue Or= 8
      EndIf
   Else 'console window
      If (my + 1 = lin) AndAlso (mx >= col - 1) AndAlso (mx <= col - 2 + Len(text)) Then
         returnValue Or= 8
      EndIf
   EndIf
   
  If returnValue Then 'cursor touches the item
      PrintMenuItem(colors.foregroundhi, colors.backgroundhi, colors.framehi, colors.highlightFont) 'highlight menu item
               
      If Bit(mode, 4) Then 'MM_CONTINUE -> continuous action at button down
         returnValue Or= buttons
         returnrem = returnValue
         Return returnValue
      ElseIf Bit(mode, 3) Then 'MM_BUTTONUP -> single action at button up
         If buttons Then 'mouse button pressed
            returnrem = returnValue Or buttons
         Else
            If returnrem And &b00000111 Then 'button was pressed at the last call
               returnValue = returnrem
               returnrem And= &b11111000 'clear button flags
            EndIf
         EndIf
         Return returnValue
      Else 'single action at button down (default)
         If buttons Then
            If (returnrem And &b00000111) = 0 Then 'no button pressed at the last call
               returnValue Or= buttons
               returnrem = returnValue
               Return returnValue
            Else 'ignore button
               Return returnValue
            EndIf
         Else 'no button
            returnrem = returnValue
            Return returnValue
         EndIf 'buttons
      EndIf 'mode
  EndIf 'cursor touching item
 
  PrintMenuItem(colors.foreground, colors.background, colors.frame, colors.normalFont)
  Return 0
     
End Function
'******* END MOUSEMENU ********************************************

'************************************************************************************
#Include Once "dir.bi"

'#Define fbReadOnly    &h01
'#Define fbHidden      &h02
'#Define fbSystem      &h04
'#Define fbDirectory   &h10
'#Define fbArchive     &h20
'#Define fbNormal      (fbReadOnly Or fbArchive)

#Define black   RGB(0,0,0)
#Define white   RGB(255,255,255)
#Define red     RGB(255,0,0)
#Define green   RGB(100,255,100)
#Define dkgreen RGB(80,180,80)

ScreenRes 800, 800, 32, 2
ScreenSet 1, 0 'double buffering to prevent flicker
Color black, white : Cls

Dim Shared As tMMcolors mmcblack, mmcred
Dim Shared As Any Ptr wndImg
Dim Shared As String message

mmcblack.text = black
mmcblack.bgnd = white

mmcred.text = red
mmcred.bgnd = white

'----------------------------------------------

Enum 'listbox view methods
   treeview
   listview
   imageview
End Enum

Type tTreeNode
   As String fName             'name of the current subfolder
   As UInteger attr            'attributes
   As Integer depth            'folder depth
   As boolean deflate = TRUE   'deflation flag (for folder)
   As tTreeNode Ptr parent     'pointer to parent node
   As tTreeNode Ptr child(Any) 'array of child nodes (sorted by fname)
   
   Declare Property total() As Integer
   Declare Function doTotal(p As tTreeNode Ptr) As Integer
   Declare Property path() As String
End Type

Property tTreeNode.total() As Integer
   Dim As Integer ret
   Dim As tTreeNode Ptr p = @This   
      
   Do While p->parent <> 0 'get parent node
      p = p->parent
   Loop
   For x As Integer = 0 To UBound(p->child) 'all drives
      ret += this.doTotal(p->child(x))
   Next
   Return ret
End Property

Function tTreeNode.doTotal(p As tTreeNode Ptr) As Integer
   Dim As Integer ret = 1
   
   If UBound(p->child) = -1 Then 'no subnodes --> don't traverse
      Return ret
   EndIf
   For x As Integer = 0 To UBound(p->child) 'all subnodes
      If p->child(x) <> 0 Then
         ret += this.doTotal(p->child(x)) 'traverse subnode (recursive)
      EndIf
   Next
   Return ret
End Function

Property tTreeNode.path() As String
   Dim As String ret
   Dim As tTreeNode Ptr p = @This
   
   ret = p->fName
   Do While p->parent <> 0
      p = p->parent
      ret = p->fName + "\" + ret
   Loop
   Return LTrim(ret, "\")
End Property

Declare Sub getFolderEntryList(p As tTreeNode Ptr)

Type tLISTBOX
   As Integer  x            ' x position on screen
   As Integer  y            ' y position on screen
   As Integer  w            ' width in pixels
   As Integer  h            ' height in pixels
   As Integer  start        ' item to start printing from
   As Integer  index        ' current item selected
   As Integer  itemcount    ' current item number at traversing the tree list
   As Integer  totalitems   ' current number of exposed items
   As Integer  mmkey        ' key substitute for mouse menu
   As Integer  wheelrem     ' reference value for mousewheel query
   As boolean  mouserem     ' help variable for mouse use
   As ULong    bgcolor      ' background color
   As ULong    framecolor   ' frame color
   As ULong    focuscolor   ' title bar color
   As ULong    nofocuscolor ' title bar color
   As UByte    display      ' current view method (tree / list / image)
   As String   title        ' title of list box
   As String   key          ' pressed key
   
   'static --> global to the tLISTBOX class
   Static As tTreeNode Ptr rootNode 'pointer to root node of chained dirtree list
   Static As tTreeNode Ptr selected 'pointer to the selected node
   Static As tLISTBOX Ptr focus    'pointer of the listbox which has the keyboard focus
   Static As String        selfile  'selected file
         
   Declare Property count As Integer ' number of shown items
   Declare Property mouseInsideBox As boolean
   
   Declare Sub show
   Declare Sub printExposed(p As tTreeNode Ptr)
   Declare Sub scrollBar
   Declare Function alignLen(s As String) As String
End Type

Dim As tTreeNode Ptr tLISTBOX.rootNode
Dim As tTreeNode Ptr tLISTBOX.selected
Dim As tLISTBOX Ptr tLISTBOX.focus
Dim As String tLISTBOX.selfile

Sub tLISTBOX.show
   Dim As Integer ret, x, ownChildIndex, childIndex, i, pline, ff, iw, ih, mmkey
   Dim As Integer mx, my, wheel, buttons
   Dim As tTreeNode Ptr pp, p(count) 'list of nodes to print
   Dim As boolean subfolders
   Dim As String deflateSign, attrString, g, itemName
   Static As Double timerem
   
   With This
      'mousewheel stuff
      GetMouse(mx, my, wheel, buttons)
      If .mouseinsidebox Then
         If .mouserem = FALSE Then 'mouse wasn't inside before --> actualize wheelrem
            .wheelrem = wheel
            .focus = @This 'set focus to the box
         EndIf
                  
         If wheel > wheelrem Then 'scroll up (to the top of the list)
            .key = Chr(255, 72)
            wheelrem = wheel
         ElseIf wheel < .wheelrem Then 'scroll down (to the bottom of the list)
            .key = Chr(255, 80)
            wheelrem = wheel
         EndIf
      EndIf
      .mouserem = .mouseInsideBox
            
      'clear list box area
      Line (.x, .y - 24) - (.x + .w, .y + .h - 24), IIf(.focus = @This, .focuscolor, nofocuscolor), bf
      Line (.x, .y - 24) - (.x + .w, .y + .h - 24), .framecolor, b
   
      'print header details
      Draw String (.x + 4, .y - 16), .title
      Line (.x, .y) - (.x + .w, .y + .h), .bgcolor, bf
      Line (.x, .y) - (.x + .w, .y + .h), .framecolor, b
   
      Select Case display
         Case treeview 'display the folder tree
            .itemcount = 0
            For x = 0 To UBound(.rootNode->child)
               .printExposed(.rootNode->child(x))
            Next
            Select Case .key
               Case Chr(255,72) 'scroll up (to the top of the list)
                  .index -= IIf(.index > 0, 1, 0)
                  If .index < .start Then 'reached the top of the displayed section --> shift list
                     .start -= 1
                  EndIf
               
               Case Chr(255, 80) 'scroll down (to the bottom of the list)
                  .index += IIf(.index < (.totalitems - 1), 1, 0)
                  If .index >= .start + .count Then 'reached the bottom of the displayed section --> shift list
                     .start += 1
                  EndIf
            End Select
            .key = ""
            .totalitems = .itemcount
            .scrollbar
            
         Case listview 'display files of the selected folder
            If (.selected <> 0) AndAlso _
                (UBound(.selected->child) >= 0) AndAlso _
                (.selected->child(0) <> 0) Then 'at least one child
               
               .itemcount = 0
               .title = "FOLDERS OF " & .selfile
                              
               For x = 0 To UBound(.selected->child) 'all child nodes
                  Dim As tTreeNode Ptr sc = .selected->child(x) 'pointer to the actual child node
                  If (sc->attr And fbDirectory) = 0 Then 'child node represents a file
                     If (.itemcount >= .start) AndAlso (.itemcount < .start + .count) Then 'inside the window --> print file
                        If .index = .itemcount Then 'selected item --> try to write file contents to the image
                           selfile = sc->path
                        EndIf
                        pline = .y + (.itemcount - .start) * 16 + 4 'print line (in pixels)
                        
                        Select Case mouseMenu(alignLen(sc->fName),"", _
                                               .x + 65, pline, _
                                               IIf(.index = .itemcount, mmcred, mmcblack))
                           Case 8 'cursor touching item
                              .index = .itemcount 'select current item
                                                            
                           Case 9 'left click
                              If timerem < Timer Then
                                 timerem = Timer + .4 'double click timer
                              Else
                                 .key = Chr(13) 'open selected file
                              EndIf
                        End Select
                     EndIf
                     .itemcount += 1
                  EndIf
               Next
               .totalitems = .itemcount
               .scrollbar
            EndIf
            
            Select Case .key
               Case Chr(255,72) 'scroll up (to the top of the list)
                  .index -= IIf(.index > 0, 1, 0)
                  If .index < .start Then 'reached the top of the displayed section --> shift list
                     .start -= 1
                  EndIf
               
               Case Chr(255, 80) 'scroll down (to the bottom of the list)
                  .index += IIf(.index < (.totalitems - 1), 1, 0)
                  If .index >= .start + .count Then 'reached the bottom of the displayed section --> shift list
                     .start += 1
                  EndIf
               
               Case Chr(13)
                  Shell "start " & .selfile 'launch selected file
                                 
            End Select
         
         Case imageview 'display the contents image
            ImageInfo wndImg, iw, ih 'get image size
            Line wndImg, (0, 0) - (iw - 1, ih - 1), .bgcolor, bf 'clear image
            
            Select Case LCase(Mid(.selfile, InStrRev(.selfile, "."))) 'file extension
               Case ".bmp"
                  BLoad .selfile, wndImg
                                                   
               Case ".txt", ".bat", ".inf", ".lst", ".pif", ".hlp", ".bas", ".bi" 'text file
                  ff = FreeFile
                  Open .selfile For Input As #ff
                  For i As Integer = 1 To 30
                     Line Input #ff, g
                     Draw String wndImg, (0, 10 * i), g, black
                     If Eof(ff) Then
                        Exit For
                     EndIf
                  Next
                  Close ff
                                                   
               Case Else 'no display method
                  For x As Integer = 0 To 10 'draw cross
                     Dim As Integer clen = 50
                     Line wndImg, (iw/2 - clen + x, ih/2 - clen) - (iw/2 + clen + x, ih/2 + clen), black
                     Line wndImg, (iw/2 + clen + x, ih/2 - clen) - (iw/2 - clen + x, ih/2 + clen), black
                  Next
                  
            End Select
         
            Line(.x, .y) - (.x + .w, .y + .h),white,
            PUT (.x + 1, .y + 1), wndImg, PSet 'display image
                  
      End Select
      .key = ""
   End With
   
End Sub

Sub tLISTBOX.printExposed(p As tTreeNode Ptr)
   Dim As tTreeNode Ptr pp = p->parent
   Dim As Integer pline
   Dim As String deflateSign
   Dim As boolean noSubfolders = TRUE, toggledeflate
      
   With This
      If p = 0 Then
         Return 'no node pointer --> error
      EndIf
            
      If (p->attr And fbDirectory) = 0 Then 'no folder
         Return
      EndIf
            
      For x As Integer = 0 To UBound(p->child)
         If (p->child(x) <> 0) AndAlso (p->child(x)->attr And fbDirectory) Then 'at least one subfolder
            nosubfolders = FALSE
            Exit For
         EndIf
      Next
               
      If (.itemcount >= .start) And (.itemcount < .start + .count) Then 'print item
         pline = .y + (.itemcount - .start) * 16 + 4 'print line (in pixels)
         
         If noSubfolders Then
            deflateSign = "  "
         Else
            If p->deflate Then
               deflateSign = "+ "
            Else
               deflateSign = "- "
            EndIf
         EndIf
         
         Select Case mouseMenu(deflateSign + p->fName,"", _
                                .x  + (p->depth * 16) , pline, _
                                IIf(.index = .itemcount, mmcred, mmcblack))
            Case 0
               If (.index = .itemcount) And (.key = Chr(13)) Then
                  toggledeflate = TRUE
                  .key = ""
               EndIf
            Case 8 'cursor touching item
               If .mouseInsideBox Then
                  .index = .itemcount 'select the current item
                  .selected = p
               EndIf
            Case 9 'left click
               toggledeflate = TRUE
         End Select
         
         If toggledeflate Then
            p->deflate = IIf(p->deflate, FALSE, TRUE) 'toggle deflation flag
            If p->deflate = FALSE Then
               If nosubfolders = FALSE Then 'get entry list of all child nodes
                  For x As Integer = 0 To UBound(p->child)
                     getFolderEntryList(p->child(x))
                  Next
               EndIf
            EndIf
            toggledeflate = FALSE   
         EndIf
      EndIf
            
      If .index = .itemcount Then
         .selected = p
      EndIf
      .itemcount += 1
      
      If (p->deflate) Then 'deflated --> don't continue, one level back
         Return
      EndIf
            
      For x As Integer = 0 To UBound(p->child) 'traverse child nodes
         If (p->child(x) <> 0) Then
            .printExposed(p->child(x))
         EndIf
      Next
      
   End With
   
End Sub

Property tLISTBOX.count As Integer
   Return Int(this.h / 16)
End Property

Property tLISTBOX.mouseInsideBox As boolean
   Dim As Integer mx, my, wheel, buttons
   
   GetMouse(mx, my, wheel, buttons)
   If (mx >= this.x) AndAlso (mx <= this.x + this.w) AndAlso _
       (my >= this.y) AndAlso (my <= this.y + this.h) Then
      Return TRUE
   EndIf
   Return FALSE

End Property

Sub tLISTBOX.scrollBar
   Dim As boolean docount = TRUE
   Dim As Integer x, item, begx, begy, endx, endy, lenframe, begbar, lenbar
   
   With This
      If .itemcount > .count Then 'draw scroll bar
         begx = .x + .w - 20
         begy = .y + 5
         endx = .x + .w - 10
         endy = .y + .h - 5
         lenframe = endy - begy
         lenbar = Int((lenframe /.totalitems) * (.count))
         begbar = begy + Int((lenframe / .totalitems) * .start)
         
         Line (begx, begy) - (endx, endy), black, b 'scroll frame
         Line (begx, begbar) - (endx, begbar + lenbar), black, bf 'scroll bar
      EndIf
   End With
   
End Sub

Function tLISTBOX.alignLen(s As String) As String
   Dim As String g = s
   
   If Len(g) > Int(this.w / 8) - 5 Then
      g = Left(s, Int(this.w / 8) - 25) & "..." & Right(s, 8)
   EndIf
   
   Return g
   
End Function

'##################################

Dim As tLISTBOX FOLDER_LIST, FILE_LIST, IMAGE_LIST
Dim As Integer x, i
Dim As String g, remselfile
Dim As tTreeNode Ptr tree = New tTreeNode 'create root node

'###################################

With FOLDER_LIST
   .x            = 8
   .y            = 64
   .w            = 8*48
   .h            = 16*20
   .start        = 0
   .index        = 0
   .display      = treeview
   .title        = "FOLDER VIEW"
   .bgcolor      = white
   .framecolor   = black
   .focuscolor   = green
   .nofocuscolor = dkgreen
End With

With FILE_LIST
   .x            = 408
   .y            = 64
   .w            = 8*48
   .h            = 16*20
   .start        = 0
   .index        = 0
   .display      = listview
   .title        = "CONTENTS OF SELECTED FOLDER"
   .bgcolor      = white
   .framecolor   = black
   .focuscolor   = green
   .nofocuscolor = dkgreen
End With

With IMAGE_LIST
   .x            = FOLDER_LIST.x
   .y            = FOLDER_LIST.y + FOLDER_LIST.h + 40
   .w            = 600
   .h            = 16*20
   .start        = 0
   .index        = 0
   .display      = imageview
   .title        = "CONTENTS OF SELECTED FOLDER"
   .bgcolor      = white
   .framecolor   = black
   .focuscolor   = green
   .nofocuscolor = green
End With

wndImg = ImageCreate(IMAGE_LIST.w - 1, IMAGE_LIST.h - 1, white)


Sub getFolderEntryList(p As tTreeNode Ptr)
   Dim As Integer i, x, y, out_attr, fileindex
   Dim As String g, path
   Dim As tTreeNode Ptr pp, ret '= Callocate(SizeOf(tTreeNode))
   
   ReDim p->child(0) 'initialize child array
   
   'get path
   pp = p
   Do
      path = "\" + pp->fName + path
      pp = pp->parent
   Loop While Len(pp->fName)' <> 0
   path = LTrim(path, "\")
   g = Dir(path + "\*", -1, @out_attr) '1st dir entry
   
   Do While Len(g) 'dir entry found
      Select Case g
         Case ".",".."
            'ignore
         Case Else
            'message = "SCANNING " & g
            ReDim Preserve p->child(x)
            p->child(x) = New tTreeNode 'create new node
            p->child(x)->parent = p
            p->child(x)->depth = p->depth + 1
            p->child(x)->fName = g 'subfolder name
            p->child(x)->attr = out_attr
            p->child(x)->deflate = TRUE
            For y As Integer = x To 1 Step -1 'sort entries alphabetical
               If LCase(p->child(y)->fName) < LCase(p->child(y - 1)->fName) Then
                  Swap p->child(y), p->child(y - 1)
               Else
                  Exit For
               EndIf
            Next
            x += 1
      End Select
      g = Dir("", -1, @out_attr) 'next entry
   Loop
      
End Sub

'Open Cons For Output As #1

Sub deleteTree(p As tTreeNode Ptr)
   
   If UBound(p->child) <> -1 Then 'no child nodes
      For x As Integer = 0 To UBound(p->child) 'all child nodes
         If p->child(x) <> 0 Then
            deleteTree(p->child(x))
         EndIf
      Next
   EndIf
   
   Delete p
   
End Sub

'############################################################################################
'====== MAIN ================================================================================

Do
   ChDir ".."
Loop While Len(CurDir) > 3

'create a list of all existing drives
'dirrem = CurDir 'save current directory
ReDim tree->child(0) 'initialize child array
For x = Asc("A") To Asc("Z") 'all possible drives
   If ChDir(Chr(x) + ":") = 0 Then 'drive exists
      ReDim Preserve tree->child(i)
      tree->child(i) = New tTreeNode 'create new child node
      tree->child(i)->parent  = tree
      tree->child(i)->depth   = tree->child(i)->parent->depth + 1
      tree->child(i)->fName   = RTrim(CurDir, "\") 'write drive to list
      tree->child(i)->attr    = fbDirectory
      tree->child(i)->deflate = TRUE
      getFolderEntryList(tree->child(i))
      i += 1
   EndIf
Next
tLISTBOX.rootNode = tree
tLISTBOX.focus = @FOLDER_LIST

'ChDir dirrem 'restore current directory


With FOLDER_LIST
   Do
      Cls
      
      If g = Chr(255, 75) Then 'cursor left
         tLISTBOX.focus = @FOLDER_LIST
      ElseIf g = Chr(255, 77) Then 'cursor right
         tLISTBOX.focus = @FILE_LIST
      Else 'send key to focused listbox
         If tLISTBOX.focus = @FOLDER_LIST Then
            FOLDER_LIST.key = g
         ElseIf tLISTBOX.focus = @FILE_LIST Then
            FILE_LIST.key = g
         EndIf
      EndIf
            
      .show() 'display folder tree
      FILE_LIST.show 'display file list (if any)
      
      If tLISTBOX.selected <> 0 Then
         IMAGE_LIST.title = "CONTENTS OF " & tLISTBOX.selfile
      EndIf
      IMAGE_LIST.show
      
      If tLISTBOX.selected->path <> remselfile Then
         FILE_LIST.index = 0
      EndIf
      remselfile = tLISTBOX.selected->path
      
      ScreenCopy
      Sleep 1
      g = InKey
   Loop Until g = Chr(27) Or g = Chr(255, 107)
End With

deleteTree(tree)
ImageDestroy wndImg
Mouse: Selecting an item by touching with the cursor, display/deflate folder with left click, open file with double click, scroll with mouse wheel.
Keyboard: cursor up/down to select item, cursor left/right to switch listbox, return to display/deflate respectively open the file.
BasicCoder2
Posts: 3338
Joined: Jan 01, 2009 7:03

Re: File Browser

Postby BasicCoder2 » Nov 05, 2017 19:58

@grindstone,
Your are getting there. By the way most screens are wider than they are high. Your current one is too high for my screen. The biggest comfortable size for me is 1280x600.
.

Return to “Projects”

Who is online

Users browsing this forum: marcov and 3 guests