textdatei einfügen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Jakobi,
dann so.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
'###################################################################
'##Source:= http://www.vbarchiv.net/archiv/tipp_details.php?pid=301
'##
'##Modified by j.ehrensberger 29/02/2008
'###################################################################
Private Declare Function GetTempFilename Lib "kernel32" Alias _
    "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, _
    ByVal wUnique As Long, ByVal lpTempFileName As String) As Long

Private Declare Function GetTempPath Lib "kernel32.dll" Alias "GetTempPathA" _
    (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Function TextFileTempFilename(Optional Path As String) As String
Dim myTempFileName As String
Dim RetVal As Long

If Path = "" Then
    Path = Space$(256)
    RetVal = GetTempPath(Len(Path), Path)
    Path = Left$(Path, RetVal)
End If

myTempFileName = Space$(256)

Call GetTempFilename(Path, "txt", 0&, myTempFileName)

myTempFileName = Left$(myTempFileName, InStr(myTempFileName, Chr$(0)) - 1)

TextFileTempFilename = myTempFileName

End Function

Public Function TextFileReadAll(ByVal FileName As String) As String
Dim F As Integer
Dim sInhalt As String

If Dir$(FileName, vbNormal) <> "" Then

    F = FreeFile

    Open FileName For Binary As #F
    sInhalt = Space$(LOF(F))
    Get #F, , sInhalt
    Close #F

End If

TextFileReadAll = sInhalt

End Function

Public Sub TextFileWriteLine(ByVal FileName As String, ByVal LinePos As Long, _
    ByVal NewString As String, Optional ByVal Replace As Boolean = True)
Dim F As Integer, N As Integer
Dim I As Long, lRow As Long
Dim Zeile As String, myTempFile As String

If Dir$(FileName, vbNormal) = "" Then

    F = FreeFile

    Open FileName For Output As #F

    For I = 1 To LinePos - 1
        Print #F, ""
    Next I

    Print #F, NewString

    Close #F

Else

    myTempFile = TextFileTempFilename()

    F = FreeFile: Open FileName For Input As #F
    N = FreeFile: Open myTempFile For Output As #N

    While Not EOF(F)

        lRow = lRow + 1

        Line Input #F, Zeile

        If lRow = LinePos Then
            If Replace Then
                Zeile = NewString
            Else
                Zeile = NewString & vbLf & Zeile
            End If
        End If

        Print #N, Zeile

    Wend

    If lRow < LinePos Then
        For I = lRow + 1 To LinePos - 1
            Print #N, ""
        Next I
        Print #N, NewString
    End If

    Close #F: Close #N

    Kill FileName
    FileCopy myTempFile, FileName
    Kill myTempFile

End If

End Sub

Private Function TextFileFindLine(ByVal FileName As String, SearchString As String) As Long
Dim F As Integer, l As Long
Dim sTmp As String

If Dir$(FileName, vbNormal) <> "" Then

    F = FreeFile

    Open FileName For Binary As #F

    Do While Not EOF(F)
        l = l + 1

        Line Input #F, sTmp

        If InStr(1, sTmp, SearchString) > 0 Then
            TextFileFindLine = l
            Exit Do
        End If

    Loop

    Close #F

End If
End Function

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

Sub TextInText()
Dim strFile As String, strInsert As String, strTmp As String
Dim lLine As Long

strFile = "F:\Temp\Text.txt"
strInsert = "F:\Temp\Insert.txt"
lLine = TextFileFindLine(strFile, "Protokollkopf") + 1
strTmp = TextFileReadAll(strInsert)
TextFileWriteLine strFile, lLine, strTmp, False

End Sub

Gruß Sepp

Hallo Jakobi,
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
'###########################################################################################
'## Sorce:=http://www.vbarchiv.net/archiv/tipp_details.php?pid=301
'###########################################################################################
' Wird benötigt, zum Ermitteln des temporären
' Verzeichnisses und zum Erstellen temporärer Dateien
Private Declare Function GetTempFileName Lib "kernel32" _
    Alias "GetTempFileNameA" (ByVal lpszPath As String, _
    ByVal lpPrefixString As String, _
    ByVal wUnique As Long, _
    ByVal lpTempFileName As String) As Long

Private Declare Function GetTempPath Lib "kernel32.dll" _
    Alias "GetTempPathA" (ByVal nBufferLength As Long, _
    ByVal lpBuffer As String) As Long

Private winTempPath As String

' Ermittelt einen temporären Dateinamen
' im temporären Verzeichnis
Private Function txt_TempFilename() As String
Dim myTempFileName As String
Dim RetVal As Long

If winTempPath = "" Then
    ' Temporäres Verzeichnis ermitteln
    winTempPath = Space$(256)
    RetVal = GetTempPath(Len(winTempPath), winTempPath)
    winTempPath = Left$(winTempPath, RetVal)
End If

' Temporären Dateinamen ermitteln
myTempFileName = Space$(256)
Call GetTempFileName(winTempPath, "txt", 0&, myTempFileName)
myTempFileName = Left$(myTempFileName, _
    InStr(myTempFileName, Chr$(0)) - 1)

txt_TempFilename = myTempFileName
End Function

Public Function txt_ReadAll(ByVal sFilename As String) As String
Dim F As Integer
Dim sInhalt As String

' Existiert die Datei ?
If Dir$(sFilename, vbNormal) <> "" Then
    ' Textdatei im Binärmodus öffnen und gesamten
    ' Inhalt in einem Rutsch auslesen
    F = FreeFile
    Open sFilename For Binary As #F
    sInhalt = Space$(LOF(F))
    Get #F, , sInhalt
    Close #F
End If

txt_ReadAll = sInhalt
End Function

Public Sub txt_WriteLine(ByVal sFilename As String, _
    ByVal LinePos As Long, ByVal sLine As String)

Dim F As Integer
Dim N As Integer
Dim I As Long
Dim lRow As Long
Dim Zeile As String
Dim myTempFile As String

If Dir$(sFilename, vbNormal) = "" Then
    ' Wenn Datei nicht existiert, automatisch erstellen
    ' und Inhalt sofort speichern
    F = FreeFile
    Open sFilename For Output As #F

    ' Datei mit Leerzeilen füllen, bis gewünschte
    ' Schreibposition erreicht ist
    For I = 1 To LinePos - 1
        Print #F, ""
    Next I

    ' Inhalt speichern
    Print #F, sLine
    Close #F

Else
    ' Temporäre Datei erstellen
    myTempFile = txt_TempFilename()

    ' Original-Datei zum Lesen und temporäre
    ' Datei zum Schreiben öffnen
    F = FreeFile: Open sFilename For Input As #F
    N = FreeFile: Open myTempFile For Output As #N

    ' Original-Datei einlesen und x. Zeile durch
    ' neuen Inhalt ersetzen
    lRow = 0
    While Not EOF(F)
        lRow = lRow + 1
        Line Input #F, Zeile

        '' 'Original
        '' If lRow = LinePos Then
        '' ' x. Zeile durch neuen Inhalt ersetzen
        '' Zeile = sLine
        '' End If
        ''
        '' Print #N, Zeile

        'Modifikation j.ehrensberger
        If lRow = LinePos Then
            Print #N, sLine & vbLf & Zeile
        Else
            Print #N, Zeile
        End If

    Wend

    ' sollte LinePos größer sein, als die bisherige
    ' Anzahl gespeicherter Zeilen in der Orginaldatei
    ' wurde der neue Inhalt noch nicht gespeichert
    ' und die Datei muss ggf. noch mit zusätzlichen
    ' Leerzeilen gefüllt werden!
    If lRow < LinePos Then
        ' Ggf. mit Leerzeilen füllen
        For I = lRow + 1 To LinePos - 1
            Print #N, ""
        Next I

        ' Neuen Zeilen-Inhalt speichern
        Print #N, sLine
    End If

    ' Dateien schliessen
    Close #F: Close #N

    ' Alte Datei löschen
    Kill sFilename

    ' temporäre Datei in "alte" Datei umbenennen
    FileCopy myTempFile, sFilename
    Kill myTempFile
End If
End Sub

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

Sub TextInText()
Dim strFile As String, strInsert As String, strTmp As String
Dim lLine As Long

strFile = "F:\Temp\Text.txt" 'Textdatei in die Eingefügt wird
strInsert = "F:\Temp\Insert.txt" 'Textdatei deren Text eingefügt wird

lLine = 2 'zeile in welche eingefügt wird

strTmp = txt_ReadAll(strInsert)

txt_WriteLine strFile, 2, strTmp

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread