Sulprobil
Search…
sbLongDec2Bin
What is the binary representation (with bitlength = 256) of the decimal number -872362346234627834628734627834627834628 ? Don't ask Excel's built-in function dec2bin(). It cannot handle numbers greater than 511. If you want to get the correct answer 1111111111111111111111111111111111111111111111111111111111111111111111111111 1111111111111111111111111111111111111111111111111101011011111011010100011111 1001110111100101111001000010000111010110010010100110011010001001100111101010 0001010101001011110011111100 then have a look at the functions listed below.
I intend to enhance the functionality. So far fractional parts are possible only for positive decimals which will be transformed into binaries by sbLongDec2Bin(). The decimal 0.5 is in binary format equal to 0.1, for example.
Please read my Disclaimer.
1
Option Explicit
2
3
Function sbLongDec2Bin(ByVal sDecimal As String, _
4
Optional lBits As Long = 32, _
5
Optional blZeroize As Boolean = False) As String
6
'Transforms decimal number into binary number.
7
'Reverse("moc.LiborPlus.www") V0.3 PB 16-Jan-2011
8
Dim sDec As String
9
Dim sFrac As String
10
Dim sD As String 'Internal temp variable to represent decimal
11
Dim sB As String
12
Dim blNeg As Boolean
13
Dim i As Long
14
Dim lPosDec As Long
15
Dim lLenBinInt As Long
16
lPosDec = InStr(sDecimal, Application.DecimalSeparator)
17
If lPosDec > 0 Then
18
If Left(sDecimal, 1) = "-" Then 'So far we cannot handle
19
'negative fractions, will come later
20
sbLongDec2Bin = CVErr(xlErrValue)
21
Exit Function
22
End If
23
sDec = Left(sDecimal, lPosDec - 1)
24
sFrac = Right(sDecimal, Len(sDecimal) - lPosDec)
25
lPosDec = Len(sFrac)
26
Else
27
sDec = sDecimal
28
sFrac = ""
29
End If
30
sB = ""
31
If Left(sDec, 1) = "-" Then
32
blNeg = True
33
sD = Right(sDec, Len(sDec) - 1)
34
Else
35
blNeg = False
36
sD = sDec
37
End If
38
Do While Len(sD) > 0
39
Select Case Right(sD, 1)
40
Case "0", "2", "4", "6", "8"
41
sB = "0" & sB
42
Case "1", "3", "5", "7", "9"
43
sB = "1" & sB
44
Case Else
45
sbLongDec2Bin = CVErr(xlErrValue)
46
Exit Function
47
End Select
48
sD = sbDivBy2(sD, True)
49
If sD = "0" Then
50
Exit Do
51
End If
52
Loop
53
If blNeg And sB <> "1" & String(lBits - 1, "0") Then
54
sB = sbBinNeg(sB, lBits)
55
End If
56
'Test whether string representation is in range and correct
57
'If not, the user has to increase lbits
58
lLenBinInt = Len(sB)
59
If lLenBinInt > lBits Then
60
sbLongDec2Bin = CVErr(xlErrNum)
61
Exit Function
62
Else
63
If (Len(sB) = lBits) And (Left(sB, 1) <> -blNeg & "") Then
64
sbLongDec2Bin = CVErr(xlErrNum)
65
Exit Function
66
End If
67
End If
68
69
If blZeroize Then sB = Right(String(lBits, "0") & sB, lBits)
70
71
If lPosDec > 0 And lLenBinInt + 1 < lBits Then
72
sB = sB & Application.DecimalSeparator
73
i = 1
74
Do While i + lLenBinInt < lBits
75
sFrac = sbDecAdd(sFrac, sFrac) 'Double fractional part
76
If Len(sFrac) > lPosDec Then
77
sB = sB & "1"
78
sFrac = Right(sFrac, lPosDec)
79
If sFrac = String(lPosDec, "0") Then
80
Exit Do
81
End If
82
Else
83
sB = sB & "0"
84
End If
85
i = i + 1
86
Loop
87
sbLongDec2Bin = sB
88
Else
89
sbLongDec2Bin = sB
90
End If
91
End Function
92
93
Function sbLongBin2Dec(sBinary As String, _
94
Optional lBits As Long = 32) As String
95
'Transforms binary number into decimal number.
96
'Reverse("moc.LiborPlus.www") V0.3 PB 16-Jan-2011
97
Dim sBin As String
98
Dim sB As String
99
Dim sFrac As String
100
Dim sD As String
101
Dim sR As String
102
Dim blNeg As Boolean
103
Dim i As Long
104
Dim lPosDec As Long
105
106
lPosDec = InStr(sBinary, Application.DecimalSeparator)
107
If lPosDec > 0 Then
108
If (Left(sBinary, 1) = "1") And _
109
Len(sBin) >= lBits Then 'So far we cannot handle
110
'negative fractions, will come later
111
sbLongBin2Dec = CVErr(xlErrValue)
112
Exit Function
113
End If
114
sBin = Left(sBinary, lPosDec - 1)
115
sFrac = Right(sBinary, Len(sBinary) - lPosDec)
116
lPosDec = Len(sFrac)
117
Else
118
sBin = sBinary
119
sFrac = ""
120
End If
121
122
Select Case Sgn(Len(sBin) - lBits)
123
Case 1
124
sbLongBin2Dec = CVErr(xlErrNum)
125
Exit Function
126
Case 0
127
If Left(sBin, 1) = "1" Then
128
sB = sbBinNeg(sBin, lBits)
129
blNeg = True
130
Else
131
sB = sBin
132
blNeg = False
133
End If
134
Case -1
135
sB = sBin
136
blNeg = False
137
End Select
138
sD = "1"
139
sR = "0"
140
For i = Len(sB) To 1 Step -1
141
Select Case Mid(sB, i, 1)
142
Case "1"
143
sR = sbDecAdd(sR, sD)
144
Case "0"
145
'Do nothing
146
Case Else
147
sbLongBin2Dec = CVErr(xlErrNum)
148
Exit Function
149
End Select
150
sD = sbDecAdd(sD, sD) 'Double sd
151
Next i
152
153
If lPosDec > 0 Then 'now the fraction
154
sD = "0.5"
155
For i = 1 To lPosDec
156
If Mid(sFrac, i, 1) = "1" Then
157
sR = sbDecAdd(sR, sD)
158
End If
159
sD = sbDivBy2(sD, False)
160
Next i
161
End If
162
163
If blNeg Then
164
sbLongBin2Dec = "-" & sR
165
Else
166
sbLongBin2Dec = sR
167
End If
168
End Function
169
170
Function sbDivBy2(sDecimal As String, blInt As Boolean) As String
171
'Divide sDecimal by two, blInt = TRUE returns integer only
172
'Reverse("moc.LiborPlus.www") V0.3 PB 16-Jan-2011
173
Dim i As Long
174
Dim lPosDec As Long
175
Dim sDec As String
176
Dim sD As String
177
Dim lCarry As Long
178
179
If Not blInt Then
180
lPosDec = InStr(sDecimal, Application.DecimalSeparator)
181
If lPosDec > 0 Then
182
sDec = Left(sDecimal, lPosDec - 1) & _
183
Right(sDecimal, Len(sDecimal) - lPosDec) 'Without decimal point
184
'lposdec already defines location of decimal point
185
Else
186
sDec = sDecimal
187
lPosDec = Len(sDec) + 1 'Location of decimal point
188
End If
189
If ((1 * Right(sDec, 1)) Mod 2) = 1 Then
190
sDec = sDec & "0" 'Append zero so that integer algorithm
191
'below calculates division exactly
192
End If
193
Else
194
sDec = sDecimal
195
End If
196
197
lCarry = 0
198
For i = 1 To Len(sDec)
199
sD = sD & Int((lCarry * 10 + Mid(sDec, i, 1)) / 2)
200
lCarry = (lCarry * 10 + Mid(sDec, i, 1)) Mod 2
201
Next i
202
203
If Not blInt Then
204
If Right(sD, Len(sD) - lPosDec + 1) <> _
205
String(Len(sD) - lPosDec + 1, "0") Then 'frac part is non-zero
206
i = Len(sD)
207
Do While Mid(sD, i, 1) = "0"
208
i = i - 1 'Skip trailing zeros
209
Loop
210
sD = Left(sD, lPosDec - 1) & Application.DecimalSeparator & _
211
Mid(sD, lPosDec, i - lPosDec + 1) 'Insert decimal point again
212
End If
213
End If
214
215
i = 1
216
Do While i < Len(sD)
217
If Mid(sD, i, 1) = "0" Then
218
i = i + 1
219
Else
220
Exit Do
221
End If
222
Loop
223
If Mid(sD, i, 1) = Application.DecimalSeparator Then
224
i = i - 1
225
End If
226
sbDivBy2 = Right(sD, Len(sD) - i + 1)
227
228
End Function
229
230
Function sbBinNeg(sBin As String, _
231
Optional lBits As Long = 32) As String
232
'Negate sBin: take the 2's-complement, then add one
233
'Reverse("moc.LiborPlus.www") V0.3 PB 16-Jan-2011
234
Dim i As Long
235
Dim sB As String
236
237
If Len(sBin) > lBits Or sBin = "1" & String(lBits - 1, "0") Then
238
sbBinNeg = CVErr(xlErrValue)
239
Exit Function
240
End If
241
242
'Calculate 2's-complement
243
For i = Len(sBin) To 1 Step -1
244
Select Case Mid(sBin, i, 1)
245
Case "1"
246
sB = "0" & sB
247
Case "0"
248
sB = "1" & sB
249
Case Else
250
sbBinNeg = CVErr(xlErrValue)
251
Exit Function
252
End Select
253
Next i
254
255
sB = String(lBits - Len(sBin), "1") & sB
256
257
'Now add 1
258
i = lBits
259
Do While i > 0
260
If Mid(sB, i, 1) = "1" Then
261
Mid(sB, i, 1) = "0"
262
i = i - 1
263
Else
264
Mid(sB, i, 1) = "1"
265
i = 0
266
End If
267
Loop
268
269
'Finally strip leading zeros
270
i = InStr(sB, "1")
271
If i = 0 Then
272
sbBinNeg = "0"
273
Else
274
sbBinNeg = Right(sB, Len(sB) - i + 1)
275
End If
276
277
End Function
278
279
Function sbDecAdd(sOne As String, sTwo As String) As String
280
'Sum up two string decimals.
281
'Reverse("moc.LiborPlus.www") V0.3 PB 16-Jan-2011
282
283
Dim lStrLen As Long
284
Dim s1 As String
285
Dim s2 As String
286
Dim sA As String
287
Dim sB As String
288
Dim sR As String
289
Dim d As Long
290
Dim lCarry As Long
291
Dim lPosDec1 As Long
292
Dim lPosDec2 As Long
293
Dim sF1 As String
294
Dim sF2 As String
295
296
lPosDec1 = InStr(sOne, Application.DecimalSeparator)
297
If lPosDec1 > 0 Then
298
s1 = Left(sOne, lPosDec1 - 1)
299
sF1 = Right(sOne, Len(sOne) - lPosDec1)
300
lPosDec1 = Len(sF1)
301
Else
302
s1 = sOne
303
sF1 = ""
304
End If
305
lPosDec2 = InStr(sTwo, Application.DecimalSeparator)
306
If lPosDec2 > 0 Then
307
s2 = Left(sTwo, lPosDec2 - 1)
308
sF2 = Right(sTwo, Len(sTwo) - lPosDec2)
309
lPosDec2 = Len(sF2)
310
Else
311
s2 = sTwo
312
sF2 = ""
313
End If
314
315
If lPosDec1 + lPosDec2 > 0 Then
316
If lPosDec1 > lPosDec2 Then
317
sF2 = sF2 & String(lPosDec1 - lPosDec2, "0")
318
Else
319
sF1 = sF1 & String(lPosDec2 - lPosDec1, "0")
320
lPosDec1 = lPosDec2
321
End If
322
sF1 = sbDecAdd(sF1, sF2) 'Add fractions as integer numbers
323
If Len(sF1) > lPosDec1 Then
324
lCarry = 1
325
sF1 = Right(sF1, lPosDec1)
326
Else
327
lCarry = 0
328
End If
329
Do While lPosDec1 > 0
330
If Mid(sF1, lPosDec1, 1) <> "0" Then
331
Exit Do
332
End If
333
lPosDec1 = lPosDec1 - 1
334
Loop
335
sF1 = Left(sF1, lPosDec1)
336
Else
337
lCarry = 0
338
End If
339
340
lStrLen = Len(s1)
341
If lStrLen < Len(s2) Then
342
lStrLen = Len(s2)
343
sA = String(lStrLen - Len(s1), "0") & s1
344
sB = s2
345
Else
346
sA = s1
347
sB = String(lStrLen - Len(s2), "0") & s2
348
End If
349
350
Do While lStrLen > 0
351
d = 0 + Mid(sA, lStrLen, 1) + Mid(sB, lStrLen, 1) + lCarry
352
If d > 9 Then
353
sR = (d - 10) & sR
354
lCarry = 1
355
Else
356
sR = d & sR
357
lCarry = 0
358
End If
359
lStrLen = lStrLen - 1
360
Loop
361
If lCarry > 0 Then
362
sR = lCarry & sR
363
End If
364
365
If lPosDec1 > 0 Then
366
sbDecAdd = sR & Application.DecimalSeparator & sF1
367
Else
368
sbDecAdd = sR
369
End If
370
371
End Function
Copied!
Last modified 1yr ago
Copy link