Hallo Leute,

ich habe eine Frage bzgl. ordner, denn ich an meine VBA anbinden möchte.
so noch mal hier erklärung: Ich habe ein Ordner in dem befindet noch ein order sozusagen unterordner und in dem Ordner befindet noch einen Ordner und es heisst rohdaten und in dem Order(Rohdaten) befindet19 edit texten mit informationen, die sollten bei ausführung meiner Programme, lesen und ausführen.

Wo soll ich die anbinden?????? Es geht um den ordner mit Name Rohdaten!!!!

Hier kommt die Code

Private Const LogPixelsX = 88
Private Const LogPixelsY = 90
Private Const PHYSICALOFFSETX = 112
Private Const PHYSICALOFFSETY = 113
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long


Dim ExOrdner, ExOrdner2 As String
Dim datname As String
Dim fso As New FileSystemObject
Dim EDVziel As String
Dim nextline As String
Dim space As Variant
Dim PatID As String
Dim file_cnt As Long
Dim folder_cnt As Long
Dim folder_size As Currency
Dim sFolderPath As String
Dim N, i, m As Integer


Dim lcnt, lnmb As Integer
Dim KoID, KoComp, KoVal As String
Dim KoFile As String
Dim Pval, ZPval, Anfonr As String
Dim Anfotxt, AnfoAb As String
Dim Thresh, kleiner, Thrfor As String
Dim Fileval, Peakval As Boolean
Dim DFSval, shellcmd As String

   
Private Sub Form_Load()
b1b6
'druck
End
End Sub
Sub b1b6()
    
    filenum = FreeFile
    ExOrdner = "H:\DatKon\Export\B1_B6\"
    sFolderPath = ExOrdner & "B1_B6\"
    GetFolderInfo sFolderPath, folder_cnt, file_cnt, folder_size
    EDVziel = "I:\HPLC\M65.txt"
    ExOrdner2 = "H:\DatKon\KoFiles\"
    KoFile = ExOrdner2 & "B1_B6.txt"

    fso.CreateTextFile EDVziel, True
    fso.CreateTextFile KoFile, True
    
    'Anzahl der Dateien an i übergeben
    i = file_cnt
    Do While i <> 0                          'Wiederholen solange noch Dateien im Ordner sind
    N = N + 1
    datname = ExOrdner & "B1_B6\" & N & ".txt"
    If fso.FileExists(datname) Then
        
        Open datname For Input As #2
        nextline = ReadLine(datname, 2)
        Index = Mid(nextline, 1, 1)
        Anfonr = Mid(nextline, 1, 4)
        
            If Index = "0" Then           'Abfrage ob die Datei zu einer Kontrolle gehört
            
                Open KoFile For Append As #3
                nextline = ReadLine(datname, 3) 'Kontrolltext
                space = Split(nextline, vbTab)
                KoID = space(2)
                DFSval = Right(KoID, 3)
                If DFSval <> "DFS" Then
                    For lcnt = 29 To lnmb
                        nextline = ReadLine(datname, lcnt)
                        space = Split(nextline, vbTab)
                        KoComp = space(2)
                        KoVal = space(6)
                        If KoComp <> "TPP" Then
                            'KoComp; KoID auf einheitliche Länge bringen
                            KoComp = einheitslen(KoComp, 20)
                            KoID = einheitslen(KoID, 10)
                            KoVal = KTP(KoVal)
                            Print #3, KoID & vbTab; KoComp & vbTab; KoVal
                        End If
                    Next lcnt
                    Print #3, 'Leerzeile
                End If
                Close #3
            Else                            'Patienten
                'm = m + 1
                nextline = ReadLine(datname, 3) 'Einlesen der Patienten ID
                space = Split(nextline, vbTab)
                PatID = space(2)
                Fileval = False
                
                If Anfonr = "7385" Then
                    Anfotxt = "PLP"
                    Thresh = " 0,3"
                    Threshoben = "300"
                    Thrfor = " 3"
                    Thrforoben = "300"
                    Fileval = True
                Else
                    If Anfonr = "7386" Then
                        Anfotxt = "PLP"
                        Thresh = "0,3"
                        Threshoben = "300"
                        Thresh = " 3"
                        Threshoben = "300"
                        Fileval = True
                    Else
                        If Anfonr = "7380" Then
                            Anfotxt = "TPP"
                            Thresh = " 0,7"
                            Thrforoben = "750"
                            Thresh = "7"
                            Thrforoben = "750"
                            Fileval = True
                        
                        End If
                    End If
                End If
                               
                If Fileval = True Then
                    Peakval = False
                    For lcnt = 29 To lnmb - 1
                    nextline = ReadLine(datname, lcnt)    'Einlesen des Patienten Messwertes
                    space = Split(nextline, vbTab)
                    AnfoAb = space(2)
                    If AnfoAb = Anfotxt Then
                        ZPval = space(6)
                        ZPval = preformat(ZPval)
                        If Kleinerals(ZPval, Thresh) = True Then
                            Pval = Thrfor
                            kleiner = "<"
                        Else
                            Pval = Runden(ZPval)
                            'Pval = ZPval
                            kleiner = " "
                        End If
                            Pval = Format(Pval)
                            lcnt = lnmb - 1
                        Open EDVziel For Append As #1
                        Print #1, PatID & " ; " & Anfonr; " ; " & kleiner; " ; " & Pval & " ;"
                        Close #1
                        Peakval = True
                    End If
                    Next lcnt
                    'Rückmeldung, wenn falscher Peak integriert wurde
                    If Peakval = False Then
                            Open KoFile For Append As #3
                            Print #3, datname, vbTab; PatID; vbTab; "falscher Peak"
                            Close #3
                    End If
                Else
                'Rückmeldung, wenn Untersuchungsnummer nicht passt
                Open KoFile For Append As #3
                Print #3, datname, vbTab; PatID; vbTab; "fehlerhafte Datei"
                Close #3
                End If
            End If
        Close #2
       Kill datname
        i = i - 1
    End If
   Loop
   fso.CopyFile EDVziel, "I:\HPLC\M65.txt", True
   'lblStatus.Caption = "Amiodaron Meßwerte wurden exportiert"
   'lblStatus2.Caption = ""
   shellcmd = "C:\WINDOWS\NOTEPAD.EXE " & KoFile
   Shell (shellcmd), vbNormalFocus
End Sub

Sub GetFolderInfo(ByVal FolderSpec As String, ByRef folder_cnt As Long, _
                           ByRef file_cnt As Long, ByRef folder_size As Currency)
    
    Dim fso As Scripting.FileSystemObject
    Dim nfolder As Folder
    
    'Verweis auf FSO Objekt
    Set fso = New Scripting.FileSystemObject
    
    'ggf. abschließender Backslash hinzufügen
    If Right$(FolderSpec, 1) <> "\" Then FolderSpec = FolderSpec & "\"
    
    'Prüfen, ob der Ordner existiert
    If fso.FolderExists(FolderSpec) Then
        'Folder-Objekt erstellen
        Set nfolder = fso.GetFolder(FolderSpec)
    
        'Größe des Ordners
        folder_size = nfolder.Size
        
        'Informationen über alle Unterordner und Dateien ermitteln
        Call zGetFolderInfo(nfolder, folder_cnt, file_cnt)
        
        'Anzahl Gesamt-Ordner
        folder_cnt = folder_cnt + nfolder.SubFolders.Count
        
        'Anzahl der Gesamt-Dateien
        file_cnt = file_cnt + nfolder.Files.Count
        
        'Folder Objekt "zerstören"
        Set nfolder = Nothing
    End If
    
End Sub

Sub zGetFolderInfo(ByVal nfolder As Folder, ByRef folder_cnt As Long, _
                            ByRef file_cnt As Long)
        
        Dim nSubFolder As Folder
        
        For Each nSubFolder In nfolder.SubFolders
            'Hier wird die Funktion rekursiv aufgerufen
            Call zGetFolderInfo(nSubFolder, folder_cnt, file_cnt)
            
            'Anzahl Unterordner aktualisieren
            folder_cnt = folder_cnt + nSubFolder.SubFolders.Count
            
            'Anzahl Dateien aktualisieren
            file_cnt = file_cnt + nSubFolder.Files.Count
        Next
End Sub

Static Function Round(ByVal Value As Variant, Optional ByVal Digits As Integer = 0) As Variant
Dim j As Long
Dim Pot10(-28 To 28) As Variant

'ggf. 10er Potenz vor-berechnen
If j = 0 Then
    For j = LBound(Pot10) To UBound(Pot10)
        Pot10(j) = CDec(10 ^ 1)
    Next j
End If

'Los gehts
On Error Resume Next
    If Value > 0 Then
        Round = Int(Value * Pot10(Digits) + 0.5) * Pot10(-Digits)
    Else
        Round = -Int(-Value * Pot10(Digits) + 0.5) * Pot10(-Digits)
    End If
If Err.Number Then Round = Value
On Error GoTo 0
End Function


'Bestimmte Zeile aus einer Textdatei lesen
Function ReadLine(ByVal sFile As String, Optional ByVal nLine As Long = 1) As String
Dim slines() As String
Dim oFSO As Object
Dim oFile As Object

'Fehlerbehandlung aktivieren
On Error GoTo ErrHandler

'Verweis auf das FileSystemObject erstellen
Set oFSO = CreateObject("Scripting.FileSystemObject")

'Existiert die Datei überhaupt?
If oFSO.FileExists(sFile) Then
    'Datei öffnen
    Set oFile = oFSO.OpenTextFile(sFile)
    
    'Alles lesen und in Array zerlegen
    slines = Split(oFile.ReadAll, vbCrLf)
    
    'Datei schliessen
    oFile.Close
    
    Select Case Sgn(nLine)
    
    '(nLine > 0)
    Case 1
    'n-te Zeile von vorne beginnend
    ReadLine = slines(nLine - 1)
    
    '(nLine < 0
    Case -1
    'n-te Zeile von hinten beginnend
    ReadLine = slines(UBound(slines) + nLine + 1)
    End Select
    lnmb = (UBound(slines))
End If
    
ErrHandler:
    'Objekte "zerstören"
    Set oFile = Nothing
    Set oFSO = Nothing
End Function

Function einheitslen(ByVal instring As String, ByVal target As Integer)
Dim il, lenstr As Integer
Dim workstr As String

lenstr = Len(instring)
workstr = instring

Do While lenstr < target
workstr = workstr & " "
lenstr = Len(workstr)
Loop

einheitslen = workstr

End Function

Public Static Function Runden(ByVal wert As Variant) As String
Dim RZiffer, Ziffer, ziffer99 As Integer
Dim space As Variant
Dim part1, part2, part As Variant
Dim Lpart1, Lpart2 As Integer
Dim zahl As Integer


If wert = "" Then
 Runden = wert
Else
space = Split(wert, ",")
part1 = space(0)
part2 = space(1)
Lpart1 = Len(part1)
Lpart2 = Len(part2)
    If Lpart1 > 2 Then
        RZiffer = Left(part2, 1)
            If RZiffer <> 0 Then
                If RZiffer >= 5 Then
                    Runden = part1 + 1
                 Else
                    Runden = part1
                 End If
            Else
            Runden = part1
            End If
    Else
        If Lpart1 = 2 Then
            If Lpart2 = 2 Then
                RZiffer = Right(part2, 1)
                If RZiffer <> 0 Then
                    If RZiffer >= 5 Then
                    part = part2 + (10 - RZiffer)
                    Lpart = Len(part)
                        If Lpart = 3 Then
                        Ziffer = Mid(part, 2)
                        ziffer99 = Left(part, 1)
                        Runden = (part1 + ziffer99) & "." & Ziffer
                        Else
                        Ziffer = Left(part, 1)
                        Runden = part1 & "." & Ziffer
                        End If
                    Else
                    part = part2 - RZiffer
                    Ziffer = Left(part, 1)
                    Runden = part1 & "." & Ziffer
                    End If
                Else
                Runden = part1 & "." & part2
                End If
             Else
             Runden = part1 & "." & part2
             End If
        Else
            If Lpart2 = 2 Then
                RZiffer = Right(part2, 1)
                If RZiffer <> 0 Then
                    If RZiffer >= 5 Then
                    part = part2 + (10 - RZiffer)
                    Lpart = Len(part)
                        If Lpart = 3 Then
                        Ziffer = Mid(part, 2)
                        ziffer99 = Left(part, 1)
                        zahl = part1 + ziffer99
                        Runden = zahl & "." & Ziffer
                        Else
                        Ziffer = Left(part, 1)
                        Runden = part1 & "." & Ziffer
                        End If
                    Else
                    part = part2 - RZiffer
                    Ziffer = Left(part, 1)
                    Runden = part1 & "." & Ziffer
                    End If
                Else
                Runden = part1 & "." & part2
                End If
             Else
             Runden = part1 & "." & part2
             End If
        End If
    End If
End If
    
End Function



 Public Static Function Format(ByVal wert As Variant) As String
Dim Länge As Integer
Dim erg As Integer
Dim zeile, zeile2 As Variant
Dim space As Variant
Dim part1, part2, part As String


Länge = Len(wert)
    If Länge < 5 Then
        Select Case Länge
        Case 0
            zeile = "00000"
        Case 1
            zeile = "00" & wert & ".0"
        Case 2
            zeile = "000" & wert
        Case 3
            zeile = "00" & wert
        Case 4
            zeile = "0" & wert
        End Select
    Format = zeile
    Else
    Format = wert
 
    End If

End Function


Function preformat(ByVal wert As Variant)

Dim val As String
Dim wlen As Integer

wlen = Len(wert)
'Leerzeichen am Ende wegschneiden
val = Right(wert, 1)
If val = " " Then
    wert = Mid(wert, 1, wlen - 1)
End If

'Nuller am Anfang wegschneiden
val = Mid(wert, 1, 1)
Do While val = "0"
wert = Mid(wert, 2, wlen)
wlen = Len(wert)
val = Mid(wert, 1, 1)
If val = "," Then
    wert = "0" & wert
    val = "ok"
End If
Loop

preformat = wert
End Function


Sub druck()
 
On Error GoTo Form_Load_errorhandler
   Dim root As String
   Dim target As String
   Dim file As String
   Dim fso As New FileSystemObject
    
 marker = False
 lblOK.Visible = False
 lblerror.Visible = False
 cmdOK.Visible = False
    
    
 Dim Text1, Text2, Text3 As String
 Dim Zeile1() As String
 Dim zeile2() As String
 Dim zeile3() As String
 Dim N As Long
 Dim RandOben As Single
 Dim RandLinks As Single

 ' Datei komplett einlesen
 filenum = FreeFile

 Open KoFile For Input As #filenum
   Text1 = Input(LOF(filenum), #filenum)
 Close #filenum
 
'Open inputfile For Input As #filenum
 '  Text2 = Input(LOF(filenum), #filenum)
'Close #filenum

 Open login For Input As #filenum
   Text3 = Input(LOF(filenum), #filenum)
 Close #filenum

 ' Eingelesenen Text in einzelne Zeilen aufsplitten
 Zeile1 = Split(Text1, vbCrLf)
 'zeile2 = Split(Text2, vbCrLf)
 zeile3 = Split(Text3, vbCrLf)

' Druckerränder des Druckers ermitteln in mm
 Printer.Orientation = vbPRORLandscape
 RandOben = Round(CStr(GetDeviceCaps(Printer.hDC, PHYSICALOFFSETY)) / (CStr(GetDeviceCaps(Printer.hDC, LogPixelsY)) / 25.4), 1)
 RandLinks = Round(CStr(GetDeviceCaps(Printer.hDC, PHYSICALOFFSETX)) / (CStr(GetDeviceCaps(Printer.hDC, LogPixelsX)) / 25.4), 1)

 ' Drucker auf mm einstellen
 Printer.ScaleMode = vbMillimeters

 ' Schrift und Schriftgrösse einstellen
 Printer.FontName = "Arial"
 Printer.FontSize = 10

 ' Oberer Rand auf 20 mm einstellen
Printer.CurrentY = 20 - RandOben

For N = 0 To UBound(Zeile1)
 ' Linker Rand auf 15 mm einstellen, muss bei jeder Zeile gemacht werden
   Printer.CurrentX = 15 - RandLinks

 ' Zeile drucken
  Printer.Print Zeile1(N)
Next

'For N = 0 To UBound(zeile2)
 '' Linker Rand auf 15 mm einstellen, muss bei jeder Zeile gemacht werden
  ' Printer.CurrentX = 15 - RandLinks

 '' Zeile drucken
  ' Printer.Print zeile2(N)
'Next

For N = 0 To UBound(zeile3)
 ' Linker Rand auf 15 mm einstellen, muss bei jeder Zeile gemacht werden
   Printer.CurrentX = 15 - RandLinks

 ' Zeile drucken
   Printer.Print vbCrLf
   Printer.Print vbCrLf
   Printer.Print zeile3(N)
Next

' Druck beenden
 Printer.EndDoc
    
   lblOK.Visible = True
   cmdOK.Visible = True
    
Exit Sub
Form_Load_errorhandler:
    

Select Case MsgBox("Fehler beim drucken!", vbAbortRetry + _
        vbExclamation, " Fehlermeldung")
        Case vbAbort
          Resume Exit_Form_Load
   Case vbRetry
      Resume
            Case vbIgnore
              Resume Next
    End Select

Exit_Form_Load:
   End
End Sub

Function Kleinerals(ByVal wert As String, ByVal vergleich As String)
Dim val As String
Dim wertkomma, vglkomma As Boolean
Dim wlen, vgllen As Integer
Dim wertver, vglver As String
Dim zwwert As String


If Kommatest(wert) = False Then
    wert = wert & ",0"
End If

If Kommatest(vergleich) = False Then
    vergleich = vergleich & ",0"
End If


wertkomma = False
vglkomma = False
wlen = Len(wert)
vgllen = Len(vergleich)

'Nuller am Anfang wegschneiden
val = Mid(wert, 1, 1)
Do While val = "0"
wert = Mid(wert, 2, wlen)
wlen = Len(wert)
val = Mid(wert, 1, 1)
If val = "," Then
    wert = "0" & wert
    val = "ok"
    wertkomma = True
End If
Loop

'Nuller am Anfang wegschneiden
val = Mid(vergleich, 1, 1)
Do While val = "0"
vergleich = Mid(vergleich, 2, vgllen)
vgllen = Len(vergleich)
val = Mid(vergleich, 1, 1)
If val = "," Then
    vergleich = "0" & vergleich
    val = "ok"
    vglkomma = True
End If
Loop

If wertkomma = True Then 'wert ist 0,x
    If vglkomma = False Then ' val ist x,0
        Kleinerals = True
    Else 'wert und val 0,x
        wertver = Right(wert, 1)
        vglver = Right(vergleich, 1)
        If CInt(wertver) < CInt(vglver) Then
            Kleinerals = True
        Else
            Kleinerals = False
        End If
    End If
Else 'wert ist x,0
    If vglkomma = True Then 'val ist 0,x
        Kleinerals = False
    Else 'wert und val x,0
        If wlen < vgllen Then
                Kleinerals = True
        Else
            If wlen > vgllen Then
                Kleinerals = False
            Else 'wert und val gleiche länge
                wertver = Mid(wert, 1, wlen - 2)
                vglver = Mid(vergleich, 1, vgllen - 2)
                If CInt(wertver) < CInt(vglver) Then
                    Kleinerals = True
                Else
                    Kleinerals = False
                End If
            End If
        End If
    End If
End If


End Function

Function Kommatest(ByVal text As String)
Dim txtlen, txtloop As Integer
Dim txtver As Boolean
Dim txtval As String

txtver = False
txtlen = Len(text)
For txtloop = 1 To txtlen
    txtval = Mid(text, txtloop, 1)
    If txtval = "," Then
        txtver = True
        txtloop = txtlen
    End If
Next txtloop
Kommatest = txtver
End Function

Function KTP(ByVal bearb As String)
Dim part1, part2, ergebnis, nbval As String
Dim nspace As Variant

nbval = Mid(bearb, 1, 1)
If nbval <> "n" Then
    nspace = Split(bearb, ",")
    part1 = nspace(0)
    part2 = nspace(1)
End If

ergebnis = part1 & "." & part2
KTP = ergebnis
End Function