'Kode ini dibuat oleh plenderj salah satu member VBForums
'http://www.vbforums.com/showthread.php?s=&threadid=132171
' Clear the contents of a file
Private Sub clearFile(ByVal strPath As String)
If Not Len(Dir(strPath)) = 0 Then
Open strPath For Output As #1
Close #1
End If
End Sub
' Is a given string contained within a given file ?
Private Function isStringInFile(ByVal strString As String, ByVal strFile As String) As Boolean
isStringInFile = InStr(returnContents(strFile), strString) <> 0
End Function
' Delete a specific line from a file (note: first line = line number 0)
Private Sub deleteLine(ByVal strFile As String, ByVal lineNumber As Long)
Dim strArrBuff() As String, i As Long
Open strFile For Input As #1
strArrBuff() = Split(Input(LOF(1), 1), vbCrLf)
Close #1
Open strFile For Output As #1
For i = 0 To UBound(strArrBuff)
If Not i = lineNumber Then Print #1, strArrBuff(i)
Next
Close #1
End Sub
' Return a specific line number from a file (note: first line = line number 0)
Private Function getLine(ByVal strFile As String, ByVal lineNumber As Long) As String
Open strFile For Input As #1
getLine = Split(Input(LOF(1), 1), vbCrLf)(lineNumber)
Close #1
End Function
' Append a line to the end of a file
Private Sub appendLine(ByVal strFile As String, ByVal strLineOfText As String)
Open strFile For Append As #1
Print #1, strLineOfText
Close #1
End Sub
' Insert a line of text in a file
Private Sub insertLine(ByVal strFile As String, ByVal lineNumber As Long, ByVal strLineOfText As String)
Dim strBuff() As String: strBuff = Split(returnContents(strFile), vbCrLf)
Dim i As Long
Open strFile For Output As #1
For i = 0 To UBound(strBuff)
If i = lineNumber Then Print #1, strLineOfText
Print #1, strBuff(i)
Next
Close #1
End Sub
' Insert a string of text in a file
Private Sub insertString(ByVal strFile As String, ByVal writePosition As Long, ByVal strStringOfText As String)
Dim strBuff As String: strBuff = returnContents(strFile)
Open strFile For Output As #1
Print #1, Left(strBuff, writePosition) & strStringOfText & Mid(strBuff, writePosition)
Close #1
End Sub
' Return the contents of a file
Private Function returnContents(ByVal strFile As String) As String
Open strFile For Input As #1
returnContents = Input(LOF(1), 1)
Close #1
End Function
' Return the path of a given full path to a file
Private Function returnPathOfFile(ByVal strFile As String) As String
returnPathOfFile = Left(strFile, InStrRev(strFile, "\"))
End Function
' Return the filename of a given full path to a file
Private Function returnNameOfFile(ByVal strFile As String) As String
returnNameOfFile = Mid(strFile, InStrRev(strFile, "\") + 1)
End Function
' Split a file up into n byte chunks
Private Sub splitUpFile(ByVal strFile As String, ByVal nByteSize As Long)
Dim strBuff As String: strBuff = returnContents(strFile)
Dim currPos As Long, endPos As Long: currPos = 1: endPos = Len(strBuff)
Dim fileNumber As Long
While currPos <= endPos
Open Left(strFile, InStrRev(strFile, ".") - 1) & "(" & fileNumber & ")" & Mid(strFile, InStrRev(strFile, ".")) For Output As #1
If (currPos + nByteSize) > endPos Then
Print #1, Mid(strBuff, currPos)
Else
Print #1, Mid(strBuff, currPos, nByteSize)
End If
Close #1
fileNumber = fileNumber + 1
currPos = currPos + nByteSize
Wend
End Sub
' Merge a number of source files into a destination file
Private Sub mergeFiles(ByVal strDestinationFile As String, ParamArray strSourceFiles())
Dim i As Long, strBuff As String
Open strDestinationFile For Output As #1
For i = 0 To UBound(strSourceFiles)
Print #1, ""
Print #1, "***"
Print #1, "*** " & strSourceFiles(i)
Print #1, "***"
Print #1, returnContents(strSourceFiles(i))
Next
Close #1
End Sub
Sunday, June 17, 2012
Tutorial File - Membaca, Menghapus Baris Tertentu, dsb
Labels:
File-And-Folder