VBA - USER DEFINED FUNCTIONS

OBJEKTE:   DATEI

Option Explicit
Option Compare Text 'Klein- und Großbuchstaben gleich behandeln

' gibt eine sortierte Liste der Dateien im aktuellen Verzeichnis
' im Testfenster (--> Strg+G) aus
Sub VerzListe()
Dim i, j, DatMaxZahl, DatAnzahl, Zwischen, dat$()
DatMaxZahl = 100 'anfänglich nur 100 Dateien
ReDim dat(DatMaxZahl) 'Feld für Dateinamen
'Dateien des aktuellen Verzeichnisses einlesen
dat(0) = Dir("*.*")
If dat(0) = "" Then Debug.Print "Das Verzeichnis ist leer": Exit Sub
For i = 1 To 10000
    If i > DatMaxZahl Then 'falls Feld zu klein ist: größer machen
        DatMaxZahl = DatMaxZahl + 100
        ReDim Preserve dat(DatMaxZahl)
    End If
    dat(i) = Dir()
    If dat(i) = "" Then Exit For
Next i
DatAnzahl = i
' Feld mit den Dateinamen sortieren
For i = 0 To DatAnzahl - 1
    For j = i + 1 To DatAnzahl
        If dat(i) > dat(j) Then
        Zwischen = dat(i): dat(i) = dat(j): dat(j) = Zwischen
    End If
    Next j
Next i
' sortiere Dateinamen ausgeben
For i = 0 To DatAnzahl
    Debug.Print dat(i)
Next i
End Sub

Sub VerzSpeicherTest()
Dim s As Long
s = VerzSpeicher(Application.Path)
MsgBox "Die Dateien des Verzeichnisses " & Application.Path & _
" beanspruchen " & Int(s / 1024) & " Kbytes."
End Sub

' ermittelt rekursiv den Speicherbedarf aller Dateien und
' Unterverzeichnisse in einem Verzeichnis
Function VerzSpeicher(pfad$)
Dim gesamtspeicher&, i&, verznr&, verzmax&, vrz$(), dat$
verzmax = 20: ReDim vrz(verzmax)
If pfad = "" Then pfad = CurDir()
dat = Dir(datname(pfad, "*.*"), 2 + 4 + 16)
' Unterverzeichnisse in vrz()-Feld eintragen
' gleichzeitig Länge der Dateien im Verzeichnis summieren
Do While dat <> ""
    If dat <> "." And dat <> ".." Then
    dat = datname(pfad, dat)
    If GetAttr(dat) = 16 Then 'Verzeichnis
        vrz(verznr) = dat: verznr = verznr + 1
        If verznr > verzmax Then
            verzmax = verzmax + 20: ReDim Preserve vrz(verzmax)
        End If
    Else 'Datei
        gesamtspeicher = gesamtspeicher + FileLen(dat)
    End If
End If
dat = Dir()
Loop
'
' Unterverzeichnisse rekursiv durcharbeiten
For i = 0 To verznr - 1
    gesamtspeicher = gesamtspeicher + VerzSpeicher(vrz(i))
Next i
'
' Rückgabewert
VerzSpeicher = gesamtspeicher
End Function

' aus Pfad und Dateiname einen vollständigen Namen zusammensetzen
' z.B. c: + name.abc -> c:\name.abc
Function datname(pfad$, dat$)
If Right(pfad, 1) = "\" Then
    datname = pfad + dat
Else
    datname = pfad + "\" + dat
End If
End Function

Sub BereichAlsMathListeSpeichern()
Dim b, b1, b2, bliste, banz 'Blätter
Dim z, z1, z2 'Zeilen
Dim sp, sp1, sp2 'Spalten
Dim element, kanal 'sonstige Var.
Static datname, dat
If Selection Is Nothing Then Exit Sub
If Selection.Cells.Count = 1 Then Exit Sub
If Selection.Areas.Count > 1 Then
    MsgBox "Nur einfache Zellbereiche": Exit Sub
End If
' Dateiname auswählen
dat = SpeichernUnter(datname)
If dat = "" Then Exit Sub Else datname = dat
    kanal = FreeFile()
    Open dat For Output As #kanal
' Initialisierung
Set bliste = ActiveWindow.SelectedSheets
banz = bliste.Count
Set b1 = bliste(1)
Set b2 = bliste(bliste.Count)
z1 = Selection.Row
z2 = z1 + Selection.Rows.Count - 1
sp1 = Selection.Column
sp2 = sp1 + Selection.Columns.Count - 1
If banz > 1 Then Print #kanal, "{"
For Each b In bliste 'Schleife für alle Blätter
Print #kanal, "{";
For z = z1 To z2 'Schleife für alle Zeilen
Print #kanal, "{";
For sp = sp1 To sp2 'Schleife für alle Spalten
    element = b.Cells(z, sp)
    If IsNumeric(element) Then 'Zahl oder Zeichenkette ?
        Print #kanal, Str(element);
    Else
        Print #kanal, Chr(34); element; Chr(34);
    End If
    If sp = sp2 Then Print #kanal, "}"; Else Print #kanal, ", ";
Next sp
If z = z2 Then Print #kanal, "}" Else Print #kanal, ","
Next z
If banz > 1 Then
    If b.Name = b2.Name Then
        Print #kanal, "}"
    Else
        Print #kanal, "},{"
    End If
End If
Next b
Close #kanal
End Sub

Function SpeichernUnter(datname)
Dim pos, dat, ergebnis, bakdat
Do 'Schleife, bis gültiger Dateiname oder Abbruch
    dat = Application.GetSaveAsFilename(datname, , , _
    "Als Mathematica-Liste speichern")
    If dat = "" Then Exit Function
    ergebnis = vbYes
    If Dir(dat) <> "" Then 'Achtung, Datei existiert schon
    ergebnis = MsgBox( _
    "Die Datei " & dat & " existiert schon! Überschreiben?", _
    vbYesNoCancel)
    If ergebnis = vbCancel Then Exit Function
    End If
Loop Until ergebnis = vbYes
' falls Datei schon existiert: Sicherheitskopie erstellen
If Dir(dat) <> "" Then 'die Datei existiert schon
    bakdat = dat + ".bak"
    'evt. schon vorhandene Backup-Datei löschen
If Dir(bakdat) <> "" Then Kill bakdat
    'vorhandene Datei umbenennen
    Name dat As bakdat
End If
SpeichernUnter = dat
End Function