Option Explicit

Function sbDec2Bin(ByVal sDecimal As String, _
               Optional lBits As Long = 32, _
               Optional blZeroize As Boolean = False) As String
'Convert a decimal number into its binary equivalent.
'Source (EN): http://www.sulprobil.com/sbdec2bin_en/
'Source (DE): http://www.bplumhoff.de/sbdec2bin_de/
'(C) (P) by Bernd Plumhoff 18-Dec-2021 PB V0.4
Dim sDec As String
Dim sFrac As String
Dim sD As String 'Internal temp variable to represent decimal
Dim sB As String
Dim blNeg As Boolean
Dim i As Long
Dim lPosDec As Long
Dim lLenBinInt As Long
lPosDec = InStr(sDecimal, Application.DecimalSeparator)
If lPosDec > 0 Then
   If Left(sDecimal, 1) = "-" Then 'So far we cannot handle
                        'negative fractions, will come later
       sbDec2Bin = CVErr(xlErrValue)
       Exit Function
   End If
   sDec = Left(sDecimal, lPosDec - 1)
   sFrac = Right(sDecimal, Len(sDecimal) - lPosDec)
   lPosDec = Len(sFrac)
Else
   sDec = sDecimal
   sFrac = ""
End If
sB = ""
If Left(sDec, 1) = "-" Then
   blNeg = True
   sD = Right(sDec, Len(sDec) - 1)
Else
   blNeg = False
   sD = sDec
End If
Do While Len(sD) > 0
   Select Case Right(sD, 1)
       Case "0", "2", "4", "6", "8"
           sB = "0" & sB
       Case "1", "3", "5", "7", "9"
           sB = "1" & sB
       Case Else
           sbDec2Bin = CVErr(xlErrValue)
           Exit Function
   End Select
   sD = sbDivBy2(sD, True)
   If sD = "0" Then
       Exit Do
   End If
Loop
If blNeg And sB <> "1" & String(lBits - 1, "0") Then
   sB = sbBinNeg(sB, lBits)
End If
'Test whether string representation is in range and correct
'If not, the user has to increase lbits
lLenBinInt = Len(sB)
If lLenBinInt > lBits Then
   sbDec2Bin = CVErr(xlErrNum)
   Exit Function
Else
   If (Len(sB) = lBits) And (Left(sB, 1) <> -blNeg & "") Then
       sbDec2Bin = CVErr(xlErrNum)
       Exit Function
   End If
End If

If blZeroize Then sB = Right(String(lBits, "0") & sB, lBits)

If lPosDec > 0 And lLenBinInt + 1 < lBits Then
   sB = sB & Application.DecimalSeparator
   i = 1
   Do While i + lLenBinInt < lBits
       sFrac = sbDecAdd(sFrac, sFrac) 'Double fractional part
       If Len(sFrac) > lPosDec Then
           sB = sB & "1"
           sFrac = Right(sFrac, lPosDec)
           If sFrac = String(lPosDec, "0") Then
               Exit Do
           End If
       Else
           sB = sB & "0"
       End If
       i = i + 1
   Loop
   sbDec2Bin = sB
Else
   sbDec2Bin = sB
End If
End Function

Function sbBin2Dec(sBinary As String, _
    Optional lBits As Long = 32) As String
'Converts a binary number into its decimal equivalent.
'Source (EN): http://www.sulprobil.com/sbdec2bin_en/
'Source (DE): http://www.bplumhoff.de/sbdec2bin_de/
'(C) (P) by Bernd Plumhoff 18-Dec-2021 PB V0.4
Dim sBin As String
Dim sB As String
Dim sFrac As String
Dim sD As String
Dim sR As String
Dim blNeg As Boolean
Dim i As Long
Dim lPosDec As Long

lPosDec = InStr(sBinary, Application.DecimalSeparator)
If lPosDec > 0 Then
   If (Left(Right(String(lBits, "0") & sBinary, lBits), 1) = "1") And _
       Len(sBin) >= lBits Then 'So far we cannot handle Right(String(lBits, "0") & sB, lBits)
                    'negative fractions, will come later
       sbBin2Dec = CVErr(xlErrValue)
       Exit Function
   End If
   sBin = Left(sBinary, lPosDec - 1)
   sFrac = Right(sBinary, Len(sBinary) - lPosDec)
   lPosDec = Len(sFrac)
Else
   sBin = sBinary
   sFrac = ""
End If

Select Case Sgn(Len(sBin) - lBits)
   Case 1
       sbBin2Dec = CVErr(xlErrNum)
       Exit Function
   Case 0
       If Left(sBin, 1) = "1" Then
           sB = sbBinNeg(sBin, lBits)
           blNeg = True
       Else
           sB = sBin
           blNeg = False
       End If
   Case -1
       sB = sBin
       blNeg = False
End Select
sD = "1"
sR = "0"
For i = Len(sB) To 1 Step -1
   Select Case Mid(sB, i, 1)
       Case "1"
           sR = sbDecAdd(sR, sD)
       Case "0"
           'Do nothing
       Case Else
           sbBin2Dec = CVErr(xlErrNum)
           Exit Function
   End Select
   sD = sbDecAdd(sD, sD) 'Double sd
Next i

If lPosDec > 0 Then 'now the fraction
   sD = "0" & Application.DecimalSeparator & "5"
   For i = 1 To lPosDec
       If Mid(sFrac, i, 1) = "1" Then
           sR = sbDecAdd(sR, sD)
       End If
       sD = sbDivBy2(sD, False)
   Next i
End If

If blNeg Then
   sbBin2Dec = "-" & sR
Else
   sbBin2Dec = sR
End If
End Function

Function sbDivBy2(sDecimal As String, blInt As Boolean) As String
'Divide positive sDecimal by two, blInt = TRUE returns integer only
'Source (EN): http://www.sulprobil.com/sbdec2bin_en/
'Source (DE): http://www.bplumhoff.de/sbdec2bin_de/
'(C) (P) by Bernd Plumhoff 18-Dec-2021 PB V0.4
Dim i As Long
Dim lPosDec As Long
Dim sDec As String
Dim sD As String
Dim lCarry As Long

If Not blInt Then
   lPosDec = InStr(sDecimal, Application.DecimalSeparator)
   If lPosDec > 0 Then
       sDec = Left(sDecimal, lPosDec - 1) & _
              Right(sDecimal, Len(sDecimal) - lPosDec) 'Without decimal point
       'lposdec already defines location of decimal point
   Else
       sDec = sDecimal
       lPosDec = Len(sDec) + 1 'Location of decimal point
   End If
   If ((1 * Right(sDec, 1)) Mod 2) = 1 Then
       sDec = sDec & "0"  'Append zero so that integer algorithm
                          'below calculates division exactly
   End If
Else
   sDec = sDecimal
End If

lCarry = 0
For i = 1 To Len(sDec)
   sD = sD & Int((lCarry * 10 + Mid(sDec, i, 1)) / 2)
   lCarry = (lCarry * 10 + Mid(sDec, i, 1)) Mod 2
Next i

If Not blInt Then
   If Right(sD, Len(sD) - lPosDec + 1) <> _
       String(Len(sD) - lPosDec + 1, "0") Then   'frac part is non-zero
       i = Len(sD)
       Do While Mid(sD, i, 1) = "0"
           i = i - 1  'Skip trailing zeros
       Loop
       sD = Left(sD, lPosDec - 1) & Application.DecimalSeparator & _
            Mid(sD, lPosDec, i - lPosDec + 1) 'Insert decimal point again
   End If
End If

i = 1
Do While i < Len(sD)
   If Mid(sD, i, 1) = "0" Then
       i = i + 1
   Else
       Exit Do
   End If
Loop
If Mid(sD, i, 1) = Application.DecimalSeparator Then
   i = i - 1
End If
sbDivBy2 = Right(sD, Len(sD) - i + 1)

End Function

Function sbBinNeg(sBin As String, _
               Optional lBits As Long = 32) As String
'Negate sBin: take the 2's-complement, then add one
'Source (EN): http://www.sulprobil.com/sbdec2bin_en/
'Source (DE): http://www.bplumhoff.de/sbdec2bin_de/
'(C) (P) by Bernd Plumhoff 18-Dec-2021 PB V0.4
Dim i As Long
Dim sB As String

If Len(sBin) > lBits Or sBin = "1" & String(lBits - 1, "0") Then
   sbBinNeg = CVErr(xlErrValue)
   Exit Function
End If

'Calculate 2's-complement
For i = Len(sBin) To 1 Step -1
   Select Case Mid(sBin, i, 1)
       Case "1"
           sB = "0" & sB
       Case "0"
           sB = "1" & sB
       Case Else
           sbBinNeg = CVErr(xlErrValue)
           Exit Function
   End Select
Next i

sB = String(lBits - Len(sBin), "1") & sB

'Now add 1
i = lBits
Do While i > 0
   If Mid(sB, i, 1) = "1" Then
       Mid(sB, i, 1) = "0"
       i = i - 1
   Else
       Mid(sB, i, 1) = "1"
       i = 0
   End If
Loop

'Finally strip leading zeros
i = InStr(sB, "1")
If i = 0 Then
   sbBinNeg = "0"
Else
   sbBinNeg = Right(sB, Len(sB) - i + 1)
End If

End Function

Function sbDecAdd(sOne As String, sTwo As String) As String
'Sum up two positive string decimals.
'Source (EN): http://www.sulprobil.com/sbdec2bin_en/
'Source (DE): http://www.bplumhoff.de/sbdec2bin_de/
'(C) (P) by Bernd Plumhoff 18-Dec-2021 PB V0.4
Dim lStrLen As Long
Dim s1 As String
Dim s2 As String
Dim sA As String
Dim sB As String
Dim sR As String
Dim d As Long
Dim lCarry As Long
Dim lPosDec1 As Long
Dim lPosDec2 As Long
Dim sF1 As String
Dim sF2 As String

lPosDec1 = InStr(sOne, Application.DecimalSeparator)
If lPosDec1 > 0 Then
   s1 = Left(sOne, lPosDec1 - 1)
   sF1 = Right(sOne, Len(sOne) - lPosDec1)
   lPosDec1 = Len(sF1)
Else
   s1 = sOne
   sF1 = ""
End If
lPosDec2 = InStr(sTwo, Application.DecimalSeparator)
If lPosDec2 > 0 Then
   s2 = Left(sTwo, lPosDec2 - 1)
   sF2 = Right(sTwo, Len(sTwo) - lPosDec2)
   lPosDec2 = Len(sF2)
Else
   s2 = sTwo
   sF2 = ""
End If

If lPosDec1 + lPosDec2 > 0 Then
   If lPosDec1 > lPosDec2 Then
       sF2 = sF2 & String(lPosDec1 - lPosDec2, "0")
   Else
       sF1 = sF1 & String(lPosDec2 - lPosDec1, "0")
       lPosDec1 = lPosDec2
   End If
   sF1 = sbDecAdd(sF1, sF2) 'Add fractions as integer numbers
   If Len(sF1) > lPosDec1 Then
       lCarry = 1
       sF1 = Right(sF1, lPosDec1)
   Else
       lCarry = 0
   End If
   Do While lPosDec1 > 0
       If Mid(sF1, lPosDec1, 1) <> "0" Then
           Exit Do
       End If
       lPosDec1 = lPosDec1 - 1
   Loop
   sF1 = Left(sF1, lPosDec1)
Else
   lCarry = 0
End If

lStrLen = Len(s1)
If lStrLen < Len(s2) Then
   lStrLen = Len(s2)
   sA = String(lStrLen - Len(s1), "0") & s1
   sB = s2
Else
   sA = s1
   sB = String(lStrLen - Len(s2), "0") & s2
End If

Do While lStrLen > 0
   d = 0 + Mid(sA, lStrLen, 1) + Mid(sB, lStrLen, 1) + lCarry
   If d > 9 Then
       sR = (d - 10) & sR
       lCarry = 1
   Else
       sR = d & sR
       lCarry = 0
   End If
   lStrLen = lStrLen - 1
Loop
If lCarry > 0 Then
   sR = lCarry & sR
End If

If lPosDec1 > 0 Then
   sbDecAdd = sR & Application.DecimalSeparator & sF1
Else
   sbDecAdd = sR
End If

End Function