Excel-VBA-Collection

1
Attribute VB_Name = "TextFile"
2
Option Explicit
3
Option Compare Text
4
Option Base 1
5
DefLng A-Z
6

7
Public Sub ErrorBox(e As ErrObject, Optional Description As Variant, Optional TITLE As Variant)
8
    If IsMissing(Description) Then Description = e.Description _
9
        Else Description = BPrintF("%s\n\%s", Description, e.Description)
10
    If IsMissing(TITLE) Then TITLE = BPrintF("Ошибка %d в %s", e.Number, e.Source)
11
    MsgBox Description, vbExclamation, TITLE
12
End Sub
13

14
Public Sub DumpFile()
15
    Dim s As String, Buf As String, p, d, r
16
    
17
    Buf = Cells(1, 1).Text
18
    If Len(Buf) = 0 Then _
19
        Buf = Application.GetOpenFilename("Файлы TXT (*.txt),*.txt,Все файлы (*.*),*.*", 1, "Открытие файла TXT")
20
    
21
    s = InputFile(Buf)
22
    If Len(s) = 0 Then Exit Sub
23
    s = CWin(s) & vbLf
24
    
25
    Columns("A:A").Clear
26
    Cells(1, 1) = Buf
27
    Application.ScreenUpdating = False
28
    p = 1: r = 2
29
    Do
30
        d = InStr(p, s, vbCrLf) 'DOS eoln
31
        If d = 0 Then d = InStr(p, s, vbLf) 'else UNIX eoln
32
        If d = 0 Then Exit Do 'no eoln is eof
33
        If d = p Then Exit Do
34
        Buf = Mid(s, p, d - p)
35
        Cells(r, 1) = "'" & Buf
36
        p = d + 2
37
        r = r + 1
38
    Loop
39
    
40
    s = "$A$2:$A$" & Trim(CStr(r - 1))
41
    With Range(s)
42
        .Font.Name = "Courier New"
43
        '.NumberFormat = "@"
44
        .Interior.ColorIndex = 35
45
        .Interior.Pattern = xlSolid
46
    End With
47
    ActiveSheet.PageSetup.PrintArea = s
48
    
49
    Columns("A:A").AutoFit
50
    Application.ScreenUpdating = True
51
End Sub
52

53
Public Function InputFile(FName As String) As String
54
    Dim FNum As Long
55
    On Error GoTo ErrHandler
56
    FNum = FreeFile
57
    Open FName For Binary Access Read Lock Write As FNum
58
        InputFile = Input(LOF(FNum), #FNum)
59
    Close #FNum
60
    On Error GoTo 0
61
    Exit Function
62
ErrHandler:
63
    Close #FNum
64
    InputFile = ""
65
    ErrorBox Err, BPrintF("Чтение файла ~%s~", FName)
66
End Function
67

68
Public Sub OutputFile(FName As String, s As String)
69
    Dim FNum As Long
70
    On Error GoTo ErrHandler
71
    FNum = FreeFile
72
    Open FName For Output Access Write Lock Write As FNum
73
    Close #FNum
74
    FNum = FreeFile
75
    Open FName For Binary Access Write Lock Write As FNum
76
        Put #FNum, , s
77
    Close #FNum
78
    On Error GoTo 0
79
    Exit Sub
80
ErrHandler:
81
    Close #FNum
82
    ErrorBox Err, BPrintF("Запись файла ~%s~", FName)
83
End Sub
84

85
Public Sub AppendFile(FName As String, s As String)
86
    Dim FNum As Long, p As Long
87
    On Error GoTo ErrHandler
88
    FNum = FreeFile
89
    Open FName For Binary Access Write Lock Write As FNum
90
        p = LOF(FNum)
91
        If p = 0 Then p = 1
92
        Put #FNum, p, s
93
    Close #FNum
94
    On Error GoTo 0
95
    Exit Sub
96
ErrHandler:
97
    Close #FNum
98
    ErrorBox Err, BPrintF("Добавление файла ~%s~", FName)
99
End Sub
100

101
Public Sub WipeFile(FName As String)
102
    Dim FNum As Long
103
    On Error GoTo ErrHandler
104
    FNum = FreeFile
105
    Open FName For Output Access Write Lock Write As FNum
106
        Print #FNum, String(LOF(FNum) + 4096, "*")
107
    Close #FNum
108
    Kill FName
109
    On Error GoTo 0
110
    Exit Sub
111
ErrHandler:
112
    Close #FNum
113
    ErrorBox Err, BPrintF("Затирание файла ~%s~", FName)
114
End Sub
115