'Ä=Ž , Ö=™, Ü=š, ä=„, ö=”, ü=�, ß=á, §=õ ,°=ø, ©=¸
'Keine Standarderweiterung ???
'RGB(rrr, ggg, bbb) entfernt, &Hrrggbb tuts auch, nur in Hex
'Konstanten eingefügt, wg Lesbarkeit
'Sub PrintAt(..) hinzugefügt, wg Übersichtlichkeit
'Sub ShortenIt(..) hinzugefügt, wg Übersichtlichkeit
'Eine Fileselectbox (Ver. 2) unter Freebasic ohne API
'Danke an ytwinky und terminator für die Tips
'Neu in Ver. 2: Function "waitmouse(sekunden)" für den Doppelklick
'               $-Zeichen entfernt
'               ...auf mehrfachen Wunsch:
'               Variablen uns Strings "option explicit"-konform gedimmt :-)
'               2x nach Dateien und Ordnern suchen lassen, damit man die Ordner auch dann
'               noch sieht, wenn man die Dateiendung *.* ändert
'Über feedbacks würde ich mich sehr freuen.
'(c) by stevie1401   17.10.2006
'Aufruf ist: auswahl=fs(DialogString,DateiendungString)
'Die Function dos_win$ wandelt die ASCII richtig um,
'sodass sie unter Windows richtig angezeigt werden.
'Die Function fs läuft unter SCREEN 19 und SCREEN 20


Declare Function fs(Dialog As String, Erw As String) As String
Declare Function Dos_Win(t As String) As String
Declare Function WaitMouse(Sekunden As Integer)As Integer
Declare Sub PrintAt(byVal Row As Long, Col As Long, byval What As String, byval ColFG As Long=-1, byval ColBG As Long=-1)
Declare Function ShortenIt(s As String) As String
Declare Sub BubbleSort(ByVal Anz As Long, Array() As String)
Screen 20, 32, 2
Dim As String Auswahl, t
Auswahl=fs("Datei ”ffnen", "*.*")
Cls
Print "Quelle=" &Auswahl
t="Weiter mit Tastendruck oder Mausklick.."
'WaitMouse 99
'Auswahl=fs("Datei speichern unter", "*.*")
'Cls
'?"Ziel=" &Auswahl
WaitMouse 30

Function fs(Dialog as String, Erw As String) As String
  Const ESC=Chr(27), CR=Chr(13), BS=Chr(08)
  Dim As Integer Anz=2100 'sollte (bei mir) wenigstens sein, sonst Fehler..
  Dim As Integer DateiAnz, OrdnerAnz, xOrdner(Anz), yOrdner(Anz), xDatei(Anz), yDatei(Anz)
  Dim As Integer OrdnerFarbe=&HFFFF00, DateiFarbe=&H283B50, TextFarbe, NeuLesen, MaxDateiLaenge, MaxOrdnerLaenge
  Dim As Integer Rueckgabe=2, Inbox, links=1, rechts=2, fs_mx, fs_my, fs_mr, fs_mk
  Dim As Integer Texthintergrund=&H6596CA, LaufwerkFarbe=&HFFFFFF, Max_FS_Zeilen=25, lwAnz, i, y, x, s, l, j
  Dim As Integer OrdnerShowStart, OrdnerShowEnde, DateiShowStart, DateiShowEnde, oldfs_mr
  Dim As String Auswahl, SuchPfad, _Ordner(Anz), _Datei(Anz), Lw
  Dim As String DateiDummy(Anz), OrdnerDummy(Anz), fs_Taste, FileName, Suche
  Do
    NeuLesen=0
    Line(0, 0)-(800, 600), &H6596CA, bf 'obere Box
    Line(0, 0)-(800, 40), &H5077A1, bf  'linke Box
    Line(0, 40)-(40, 600), DateiFarbe, bf  'Box in der Mitte
    Line(42, 524)-(580, 546), DateiFarbe, b 'erste untere Dialogbox
    Line(42, 558)-(580, 580), DateiFarbe, b 'zweite untere Dialogbox
    Line(585, 555)-(650, 586), DateiFarbe, b 'Abbruch-Box
    Line(680, 555)-(770,586), DateiFarbe, b 'Übernehmen-Box
    Line(94, 70)-(320,500), LaufwerkFarbe, b ' Box für die Ordner
    Line(460, 70)-(670,500), LaufwerkFarbe, b ' Box für die Dateien
    Line(0, 0)-(800, 600), &H000000, b 'Umrandung
    PrintAt 6, 43, Chr(24), &HFF0000, Texthintergrund 'Pfeil nach oben für Ordner
    PrintAt 31, 43, Chr(25)  'Pfeil nach unten für Ordner
    PrintAt 6, 87, Chr(24)  'Pfeil nach oben für Dateien
    PrintAt 31, 87, Chr(25)  'Pfeil nach unten für Dateien
    PrintAt 2, 40, Dialog, LaufwerkFarbe, &H5077A1
    PrintAt 36, 75, "Abbruch", 0, Texthintergrund
    PrintAt 36, 87, "�bernehmen"
    PrintAt 2, 2, Curdir, 0, &H5077A1 ' aktuellen Pfad Anzeigen
    PrintAt 36, 10, Erw, 0, Texthintergrund  ' Erw Anzeigen
    ' Laufwerke ermitteln
    Lw=""
    Color LaufwerkFarbe, DateiFarbe
    For i=99 To 122 '"c".."z"
      FileName=Dir(Chr(i) &":\*.*", &H37)' Dateien aller Art ermitteln
      If FileName<>"" Then
        Lw+=Chr(i)
        PrintAt i-95, 2, Chr(i) &":\"
      End If
    Next i
    LwAnz=Len(Lw)
'Suchen
    For i=1 To 2 'Erst nach Dateien, dann nach Ordnern
       If i=1 Then
        Suche=CurDir &"\" &Erw  'Nach Dateien Suchen
      Else
        Suche=CurDir &"\*.*"  'Nach Ordnern Suchen
      End If
      s=Instr(Suche, "\\") ' ggf. doppelte Backslash entfernen<macht er aber nur ein Mal..>
      If s>0 Then Suche=Left(Suche, s) &Right(Suche, Len(Suche)-s-1)
      Filename=Dir(Suche, &H37, @Rueckgabe)
      ' ...und nebenbei die Ausgabe auch noch "Ö" und "Ä" etc richtig Anzeigen lassen
      If i=1 Then DateiAnz=0
      OrdnerAnz=1
      _Ordner(1)=".."
      Do
        If FileName<>"." And FileName<>".." Then
          If Rueckgabe And 16 Then  'Ist es ein Ordner?
            If i=2 Then
              OrdnerAnz+=1
              _Ordner(OrdnerAnz)=FileName
            End if
          Else
            If i=1 Then
              DateiAnz+=1
              _Datei(DateiAnz)=FileName
            End if
          End If
        End If
        FileName=Dos_Win(Dir(@Rueckgabe))
      Loop While FileName<>""
    Next i
    'Dateinamen sortieren
    BubbleSort(DateiAnz, _Datei())
    'Ordnernamen sortieren
    BubbleSort(OrdnerAnz, _Ordner())
    ' Datei-Ausgabelänge kürzen, damit es in die Ausgabebox passt
    ' ...dazu packen wir die Datei in einen Dumfs_my, welche dann angezeigt wird
    For i=1 To DateiAnz
      DateiDummy(i)=ShortenIt(_Datei(i))
    Next i
    ' keine Daten gefunden?
    If DateiAnz=1 And _Datei(DateiAnz)="" Then
      _Datei(1)="Keine Daten gefunden"
      DateiDummy(1)=_Datei(DateiAnz)
    End If
    ' Ordner-Ausgabelänge kürzen, damit es in die Ausgabebox passt
    ' ...dazu packen wir die Datei in einen Dumfs_my, welche dann angezeigt wird
    For i=1 To OrdnerAnz
      OrdnerDummy(i)=ShortenIt(_Ordner(i))
    Next i
'    PrintAt 4, 22, (OrdnerAnz-1) &" Ordner"
'    PrintAt 4, 67, (DateiAnz) &" Dateien"
    ' Ordner Anzeigen
    y=5
    x=15
    Color OrdnerFarbe, Texthintergrund
    OrdnerShowStart=0
    i=OrdnerShowStart
    OrdnerShowEnde=0
    Do
      i+=1
      y+=1
      OrdnerShowEnde+=1
      PrintAt y, x, OrdnerDummy(i)
      yOrdner(i)=y
      xOrdner(i)=x
    Loop Until OrdnerShowEnde=Max_FS_Zeilen Or i=OrdnerAnz
    ' Dateien Anzeigen
    y=5
    x=60
    Color DateiFarbe, Texthintergrund
    DateiShowStart=0
    i=0
    DateiShowEnde=0
    Do
      i+=1
      y+=1
      DateiShowEnde+=1
      PrintAt y, x, OrdnerDummy(i)
      yDatei(i)=y
      xDatei(i)=x
    Loop Until DateiShowEnde=Max_FS_Zeilen Or i=DateiAnz
    Do
      ' Mausabfrage
      oldfs_mr=fs_mr  'Mausrad merken
      Getmouse fs_mx, fs_my, fs_mr, fs_mk
      fs_Taste=Inkey
      Locate 2, 60
      'Ist die Maus über einem der Pfeile?
      '...über dem Ordner-Nachoben-Pfeil?
      If fs_mx>328 And fs_mx<355 And fs_my>70 And fs_my<100 And fs_mk=1 Then fs_Taste="q"
      '...über dem Datei-Nachoben-Pfeil?
      If fs_mx>677 And fs_mx<705 And fs_my>70 And fs_my<100 And fs_mk=1 Then fs_Taste="+"
      '...über dem Ordner-Nachunten-Pfeil?
      If fs_mx>328 And fs_mx<355 And fs_my>470 And fs_my<505 And fs_mk=1 Then fs_Taste="a"
      '...über dem Datei-Nachunten-Pfeil?
      If fs_mx>677 And fs_mx<705 And fs_my>470 And fs_my<505 And fs_mk=1 Then fs_Taste="-"
      If oldfs_mr<>fs_mr Then  'Mausrad bewegt?
        If fs_mx>92 And fs_mx<332 And fs_my>68 And fs_my<502 Then 'Maus innerhalb der Ordnerbox...
          fs_Taste=Mid("qa", Abs(oldfs_mr>fs_mr), 1)
        End If
        If fs_mx>460 And fs_mx<670 And fs_my>68 And fs_my<502 Then 'Maus innerhalb der Dateibox...
          fs_Taste=Mid("+-", Abs(oldfs_mr>fs_mr), 1)
        End If
      End If
      If Len(fs_Taste)=2 Then
        Select Case Right(fs_Taste, 1)
          Case "P" ' Pfeil nach unten
            fs_Taste=Mid("-a", Abs(Inbox=links), 1)
          Case "H" ' Pfeil nach oben
            fs_Taste=Mid("+q", Abs(Inbox=links), 1)
          Case "M" ' Pfeil nach rechts
            If Inbox=links Then
              Inbox=rechts
            Else
              Inbox=links
            End If
          Case "K" ' Pfeil nach links
            If Inbox=links Then
              Inbox=rechts
            Else
              Inbox=links
            End If
        End Select
      End If
      If Inbox=links then
        Line(92, 68)-(322, 502), LaufwerkFarbe, b ' Box für die Ordner
        Line(94, 70)-(320, 500), LaufwerkFarbe, b ' Box für die Ordner
        Line(458, 68)-(672, 502), LaufwerkFarbe, b ' Box für die Dateien
        Line(460, 70)-(670, 500), Texthintergrund, b ' Box für die Dateien
      Else
        Line(94, 70)-(320, 500), Texthintergrund, b ' Box für die Ordner
        Line(92, 68)-(322, 502), LaufwerkFarbe, b ' Box für die Ordner
        Line(458, 68)-(672, 502), LaufwerkFarbe, b ' Box für die Dateien
        Line(460, 70)-(670, 500), LaufwerkFarbe, b ' Box für die Dateien
      End If
      Select Case fs_Taste
        Case "a"
          If OrdnerShowStart+OrdnerShowEnde<OrdnerAnz Then 'das "Plus" für Ordner
            y=5
            x=15
            Color OrdnerFarbe, Texthintergrund
            OrdnerShowStart+=1
            i=OrdnerShowStart
            OrdnerShowEnde=0
            Do
              i+=1
              y+=1
              OrdnerShowEnde+=1
              PrintAt y, x, OrdnerDummy(i)
              yOrdner(i)=y
              xOrdner(i)=x
            Loop Until OrdnerShowEnde=Max_FS_Zeilen Or i=OrdnerAnz
          End If
        Case "q"
          If OrdnerShowStart>0 Then  'das "Minus" für Ordner
            y=5
            x=15
            Color OrdnerFarbe, Texthintergrund
            OrdnerShowStart-=1
            i=OrdnerShowStart
            OrdnerShowEnde=0
            Do
              i+=1
              y+=1
              OrdnerShowEnde+=1
              PrintAt y, x, OrdnerDummy(i)
              yOrdner(i)=y
              xOrdner(i)=x
            Loop Until OrdnerShowEnde=Max_FS_Zeilen Or i=OrdnerAnz
          End If
        Case "-"
          If DateiShowStart+DateiShowEnde<DateiAnz Then
            y=5
            x=60
            Anz=0
            Color DateiFarbe, Texthintergrund
            DateiShowStart+=1
            i=DateiShowStart
            DateiShowEnde=0
            Do
              i+=1
              y+=1
              DateiShowEnde+=1
              yDatei(i)=y
              xDatei(i)=x
              PrintAt y, x, DateiDummy(i),
            Loop Until DateiShowEnde=Max_FS_Zeilen Or i=DateiAnz
          End If
        Case "+"
          If DateiShowStart>0 Then
            y=5
            x=60
            Color DateiFarbe, Texthintergrund
            DateiShowStart-=1
            i=DateiShowStart
            DateiShowEnde=0
            Do
              i+=1
              y+=1
              DateiShowEnde+=1
              yDatei(i)=y
              xDatei(i)=x
              PrintAt y, x, DateiDummy(i)
            Loop Until DateiShowEnde=Max_FS_Zeilen Or i=DateiAnz
          End If
        End Select
      ' Maus auf einem Ordner?
      For i=OrdnerShowstart To OrdnerShowstart+OrdnerShowEnde
        If fs_mx>xOrdner(i)*8-8 And fs_mx<xOrdner(i)*8-8+100 And fs_my>yOrdner(i)*16-16 And fs_my<yOrdner(i)*16 Then
          If fs_mk=1 Then
            Chdir _Ordner(i)
            Do
              Getmouse fs_mx, fs_my, fs_mr, fs_mk
              fs_Taste=Inkey
              Sleep 1
            Loop Until fs_Taste="" And fs_mk=0
            NeuLesen=1
          End If
        End If
      Next i
      ' Maus auf einer Datei?
      For i=DateiShowStart To DateiShowStart+DateiShowEnde
        If fs_mx>xDatei(i)*8-8 And fs_mx<xDatei(i)*8+200 And fs_my>yDatei(i)*16-16 And fs_my<yDatei(i)*16 Then
          PrintAt yDatei(i), xDatei(i), DateiDummy(i), LaufwerkFarbe, Texthintergrund
          If fs_mk=1 Then
            Auswahl=_Datei(i)
            PrintAt 34, 10, Auswahl &Space(60-Len(Auswahl))
            'Eine Sekunde warten, ob noch einmal geklickt wurde...
            'Wenn ja, dann übernehmen
            If WaitMouse(1)=1 Then fs_Taste=ESC
          End If
        Else
          PrintAt yDatei(i), xDatei(i), DateiDummy(i), TextFarbe, Texthintergrund
        End If
      Next i
      ' Maus auf der Abbruch-Box?
      If fs_mx>585 And fs_mx<650 And fs_my>555 And fs_my<586 And fs_mk=1 Then
        Auswahl="Abbruch"
        fs_Taste=ESC
      End If
      ' Maus auf der Übernehmen-Box?
      If fs_mx>680 And fs_mx<770 And fs_my>555 And fs_my<586 And fs_mk=1 And Auswahl<>"" Then
        Auswahl=Curdir &"\" &Auswahl
        s=Instr(Auswahl, "\\") ' ggf. doppelte Backslash entfernen
        If s>0 Then Auswahl=Left(Auswahl, s) &Right(Auswahl, Len(Auswahl)-s-1)
        fs_Taste=ESC
      End If
      ' Maus in der zweiten untere Dialogbox?
      If fs_mx>42 And fs_mx<580 And fs_my>558 And fs_my<580 And fs_mk=1 Then
        Do
          Getmouse fs_mx, fs_my, fs_mr, fs_mk
          fs_Taste=Inkey
        Loop Until fs_Taste="" And fs_mk=0
        Color LaufwerkFarbe, Texthintergrund
        Do
          Getmouse fs_mx, fs_my, fs_mr, fs_mk
          fs_Taste=Inkey
          PrintAt 36, 10, Erw &"|  ",
          If Len(fs_Taste)=1 And fs_Taste<>"" And fs_Taste<>CR And fs_Taste<>Esc And fs_Taste<>BS Then
            Erw+=fs_Taste
            PrintAt 36, 10, Erw &"|  "
          End If
          If fs_Taste=BS And Len(Erw)>0 Then
            Erw=Left(Erw, Len(Erw)-1)
            PrintAt 36, 10, Erw &"|  "
          End If
          Sleep 1
        Loop Until fs_Taste=CR Or Len(fs_Taste)>1 Or fs_Taste=ESC Or fs_mk>0
        PrintAt 36, 10, Erw &"  ", 0, Texthintergrund
        NeuLesen=1
      End If
      ' Auf Laufwerkbuchstaben geklickt?
      For i=1 To lwAnz
        If fs_mx>2 And fs_mx<60 And fs_my>(3+i)*16-16 And fs_my<(3+i)*16 Then
          PrintAt 3+i, 2, Mid(Lw, i, 1) &":\", &HFF0000, DateiFarbe ' Color LaufwerkFarbe, Rgb(40, 59, 80)
          If fs_mk=1 Then
            Chdir Mid(Lw, i, 1) &":\"
            Do
              Getmouse fs_mx, fs_my, fs_mr, fs_mk
              fs_Taste=Inkey
              Sleep 1
            Loop Until fs_Taste="" And fs_mk=0
            NeuLesen=1
          End If
        Else
          PrintAt 3+i, 2, Mid(Lw, i, 1) &":\", LaufwerkFarbe, DateiFarbe
        End If
      Next i
      ' Maus in der Datei-Anzeige-Box?
      If fs_mx>42 And fs_mx<580 And fs_my>524 And fs_my<546 Then
        If fs_mk=1 Then
          Auswahl=""
          PrintAt 34, 10, Space(30), &HFF0000, Texthintergrund
          Do 'Maus und Tastaturpuffer leeren
            Getmouse fs_mx, fs_my, fs_mr, fs_mk
            fs_Taste=Inkey
          Loop Until fs_Taste="" And fs_mk=0
          Do ' Eingabe
            Getmouse fs_mx, fs_my, fs_mr, fs_mk
            fs_Taste=Inkey
            PrintAt 34, 10, Auswahl &"|  "
            If Len(fs_Taste)=1 And fs_Taste<>"" And fs_Taste<>CR And fs_Taste<>Esc  And fs_Taste<>BS  Then
              Auswahl+=fs_Taste
              PrintAt 34, 10, Auswahl &"|  "
            End If
            If fs_Taste=BS And Len(Auswahl)>0 Then
              Auswahl=Left(Auswahl, Len(Auswahl)-1)
              PrintAt 34, 10, Auswahl &"|  "
            End If
            Sleep 1
          Loop Until fs_Taste=CR Or fs_mk>0
          PrintAt 34, 10, Auswahl, TextFarbe, Texthintergrund
        End If
      End If
      Sleep 1  'Pause für die CPU
    Loop Until fs_Taste=Esc Or Auswahl="Abbruch" Or NeuLesen=1
    NeuLesen=0
  Loop Until fs_Taste=Esc
  Return Auswahl
  Erase _Ordner, _Datei, xOrdner, yOrdner, xDatei, yDatei, OrdnerDummy, DateiDummy
End Function

Function Dos_Win(s As String) As String
  Dim As Long i, j
  Dim s1 As String=Chr(252)+Chr(228)+Chr(196)+Chr(246)+Chr(214)+Chr(220) 'zur besseren Übersicht
  Dim s2 As String=Chr(129)+Chr(132)+Chr(142)+Chr(148)+Chr(153)+Chr(154) 'stehen diese Dim's untereinander
  For i=1 To Len(s)
    j=Instr(s1, Mid(s, i, 1))
    If j Then Mid(s, i, 1)=Mid(s2, j, 1)
  Next i
  Function=s
End Function

Function WaitMouse(Sekunden As Integer) As Integer
  'wartet auf ein Maus- oder Tastaturereignis "Sekunden" Sekunden lang
  Dim As Double Zeit, ZeitZaehler
  Dim As Integer wmx, wmy, wmr, wmk
  Dim wTaste As String
  Zeit=Timer
  Do
    Getmouse wmx, wmy, wmr, wmk
    Sleep 1
  Loop Until wmk=0 And Inkey=""
  Do
    Getmouse wmx, wmy, wmr, wmk
    wTaste=Inkey
    ZeitZaehler=Timer
    Sleep 1
  Loop Until wmk>0 Or wTaste<>"" Or (ZeitZaehler-Zeit)=Sekunden
  Return wmk 'v1ctor meint, es wäre besser ;)
End Function

Sub PrintAt(byVal Row As Long, Col As Long, byval What As String, byval ColFG As Long=-1, byval ColBG As Long=-1)
  Locate Row, Col
  If ColFG>=0 Then Color ColFG
  If ColBG>=0 Then Color , ColBG
  Print What
End Sub

Function ShortenIt(s As String) As String
  Dim Dummy As String=s
  If Len(s)>20 Then Dummy=Left(s, 20) &".."
  ' ggf. mit Leezeichen auffüllen, um den Rest der Zeile zu löschen
  Return Dummy &Space(23-Len(Dummy))
End Function

Sub BubbleSort(ByVal Anz As Long, _Datei() As String)
  Var i=0, j=0, l=0
  For i=1 To Anz-1
    j=i
    For l=i+1 To Anz
      If lcase(_Datei(l))<lcase(_Datei(j)) Then j=l
    Next l
    Swap _Datei(i), _Datei(j)
  Next i
End Sub