Excel-VBA-Collection

1
Attribute VB_Name = "Printf"
2
Option Explicit
3
Option Compare Binary 'BINARY!!!
4
Option Base 0 'ParamArray!!!
5
DefLng A-Z
6

7
Dim simple As Boolean, realign As Boolean
8
Dim width As String, PART As String, before As Boolean, argc As Long
9

10
Public Function Bsprintf(FormatStr As String, ParamArray Args() As Variant) As String
11
    Bsprintf = Bvsprintf(FormatStr, CVar(Args))
12
End Function
13

14
Public Function Bvsprintf(FormatStr As String, Args As Variant) As String
15
    'like the C function vsprintf()
16
    'required to investigate user32.wvsprintfA()!
17
    Dim n1 As Long, n2 As Long, C As String, s As String
18
    Bvsprintf = vbNullString
19
    n1 = 1
20
    Do
21
        n2 = InStr(n1, FormatStr, "\")
22
        If n2 = 0 Then
23
            Bvsprintf = Bvsprintf & Mid(FormatStr, n1)
24
            Exit Do
25
        Else
26
            Bvsprintf = Bvsprintf & Mid(FormatStr, n1, n2 - n1)
27
        End If
28
        C = Mid(FormatStr, n2 + 1, 1)
29
        Select Case C
30
            Case "\":
31
                Bvsprintf = Bvsprintf & "\"
32
            Case "'":
33
                Bvsprintf = Bvsprintf & """" 'like C \"
34
            Case "a":
35
                Beep
36
            Case "b":
37
                Bvsprintf = Left(Bvsprintf, Len(Bvsprintf) - 1) '''''''''''''''''need to be last
38
            Case "n":
39
                Bvsprintf = Bvsprintf & vbCrLf
40
            'Case "r":
41
            '    Bvsprintf = Bvsprintf & vbLf 'UNIX
42
            Case "t":
43
                Bvsprintf = Bvsprintf & vbTab
44
            Case "0":
45
                Bvsprintf = Bvsprintf & vbNullChar
46
            Case Else
47
                Bvsprintf = Bvsprintf & C
48
        End Select
49
        n1 = n2 + 2: n2 = n1
50
    Loop
51
    
52
    argc = LBound(Args)
53
    n1 = 1
54
    FormatStr = Bvsprintf
55
    Bvsprintf = vbNullString
56
    Do
57
        simple = True
58
        realign = False
59
        width = vbNullString
60
        PART = vbNullString
61
        before = True
62
        n2 = InStr(n1, FormatStr, "%")
63
        If n2 = 0 Then
64
            Bvsprintf = Bvsprintf & Mid(FormatStr, n1)
65
            Exit Do
66
        Else
67
            Bvsprintf = Bvsprintf & Mid(FormatStr, n1, n2 - n1)
68
        End If
69
        Do
70
            n2 = n2 + 1
71
            C = Mid(FormatStr, n2, 1)
72
            Select Case C
73
                Case "%":
74
                    Bvsprintf = Bvsprintf & "%"
75
                    Exit Do
76
                Case "c":
77
                    Bvsprintf = Bvsprintf & Chr(Args(argc))
78
                    argc = argc + 1
79
                    Exit Do
80
                Case "d":
81
                    Bvsprintf = Bvsprintf & DFormat(Args(argc))
82
                    argc = argc + 1
83
                    Exit Do
84
                Case "s":
85
                    Bvsprintf = Bvsprintf & SFormat(Args(argc))
86
                    argc = argc + 1
87
                    Exit Do
88
                    
89
                'Changed behavior!
90
                Case "f":
91
                    Bvsprintf = Bvsprintf & FFormat(Args(argc))
92
                    argc = argc + 1
93
                    Exit Do
94
                Case "F":
95
                    Bvsprintf = Bvsprintf & PFormat(Args(argc))
96
                    argc = argc + 1
97
                    Exit Do
98
                Case "x":
99
                    Bvsprintf = Bvsprintf & DFormat(LCase(To36(Args(argc))))
100
                    argc = argc + 1
101
                    Exit Do
102
                Case "X":
103
                    Bvsprintf = Bvsprintf & DFormat(UCase(To36(Args(argc))))
104
                    argc = argc + 1
105
                    Exit Do
106
                    
107
                'Extra formats!!!
108
                Case "n":
109
                    Bvsprintf = Bvsprintf & Format(Args(argc), "dd.MM.yyyy") 'DtoC
110
                    argc = argc + 1
111
                    Exit Do
112
                Case "N":
113
                    Bvsprintf = Bvsprintf & DtoS(Args(argc)) 'yyyymmdd DtoS
114
                    argc = argc + 1
115
                    Exit Do
116
                Case "m":
117
                    Bvsprintf = Bvsprintf & Format(Args(argc), "yyyy-MM-dd") 'XML
118
                    argc = argc + 1
119
                    Exit Do
120
                Case "M":
121
                    Bvsprintf = Bvsprintf & Format(Args(argc), "yyyy-MM-ddTHH:mm:ss") 'XML
122
                    argc = argc + 1
123
                    Exit Do
124
                Case "t":
125
                    Bvsprintf = Bvsprintf & Format(Args(argc), "HH:mm")
126
                    argc = argc + 1
127
                    Exit Do
128
                Case "T":
129
                    Bvsprintf = Bvsprintf & Format(Args(argc), "dd.MM.yyyy HH:mm")
130
                    argc = argc + 1
131
                    Exit Do
132
                
133
                'Digital preprocessing
134
                Case "0":
135
                    simple = False
136
                    If Len(width) = 0 Then width = "0"
137
                    If before Then
138
                        width = width & C
139
                    Else
140
                        PART = PART & C
141
                    End If
142
                Case "1" To "9":
143
                    simple = False
144
                    If Len(width) = 0 Then width = " "
145
                    If before Then
146
                        width = width & C
147
                    Else
148
                        PART = PART & C
149
                    End If
150
                Case "-":
151
                    simple = False
152
                    realign = True
153
                Case "*":
154
                    simple = False
155
                    If Len(width) = 0 Then width = " "
156
                    If before Then
157
                        width = width & CStr(Args(argc))
158
                    Else
159
                        PART = CStr(Args(argc))
160
                    End If
161
                    argc = argc + 1
162
                Case ".":
163
                    simple = False
164
                    before = False
165
                    If Len(width) = 0 Then width = " "
166
                
167
                'Something goes wrong...
168
                Case Else
169
                    Bvsprintf = Bvsprintf & C
170
                    Exit Do
171
            End Select
172
        Loop
173
        n1 = n2 + 1
174
    Loop
175
End Function
176

177
Public Function DFormat(v As Variant) As String
178
    Dim s As String
179
    s = CStr(v)
180
    If Not simple Then
181
        If realign Then 'align to left
182
            s = PadR(s, Val(width), Left(width, 1))
183
            If Len(PART) > 0 Then s = Right(s, Val(PART))
184
        Else 'align to right
185
            s = PadL(s, Val(width), Left(width, 1))
186
            If Len(PART) > 0 Then s = Left(s, Val(PART))
187
        End If
188
    End If
189
    DFormat = s
190
End Function
191

192
Public Function FFormat(v As Variant, Optional Delim As String = ".") As String
193
    Dim s As String
194
    If simple Then
195
        s = Format(v, "#,0.00")
196
        Mid(s, Len(s) - 2, 1) = Delim
197
    Else
198
        s = Format(v, "#,0." & String(Val(PART), "0"))
199
        Mid(s, Len(s) - Val(PART), 1) = Delim
200
        If realign Then 'align to left
201
            s = PadR(s, Val(width), Left(width, 1))
202
        Else 'align to right
203
            s = PadL(s, Val(width), Left(width, 1))
204
        End If
205
    End If
206
    FFormat = s
207
End Function
208

209
Public Function PFormat(v As Variant, Optional Delim As String = "-") As String
210
    Dim s As String
211
    If simple Then
212
        s = Format(v, "0.00")
213
        Mid(s, Len(s) - 2, 1) = Delim
214
    Else
215
        s = Format(v, "0." & String(Val(PART), "0"))
216
        Mid(s, Len(s) - Val(PART), 1) = Delim
217
        If realign Then 'align to left
218
            s = PadR(s, Val(width), Left(width, 1))
219
        Else 'align to right
220
            s = PadL(s, Val(width), Left(width, 1))
221
        End If
222
    End If
223
    PFormat = s
224
End Function
225

226
Public Function SumFormat(v As Variant) As String
227
    SumFormat = Format(v, "0.00")
228
End Function
229

230
Public Function SFormat(v As Variant) As String
231
    Dim s As String
232
    s = CStr(v)
233
    If Not simple Then
234
        If realign Then 'align to right
235
            s = PadL(s, Val(width), Left(width, 1))
236
            If Len(PART) > 0 Then s = Right(s, Val(PART))
237
        Else 'align to left
238
            s = PadR(s, Val(width), Left(width, 1))
239
            If Len(PART) > 0 Then s = Left(s, Val(PART))
240
        End If
241
    End If
242
    SFormat = s
243
End Function
244