Я работаю над этой проблемой уже около недели, пытаясь разобраться в ней для нашей организации.
Наш финансовый отдел использует IRIS Exchequer, и нам нужно снизить расходы.Используя приведенный выше код PHP, мне удалось заставить его работать в Excel VBA со следующим кодом (включает зависимые функции).Если не правильно приписать ниже, я получил все длинные функции dec to bin с www.sulprobil.com.Если вы скопируете и вставите следующий блок кода в модуль, вы можете ссылаться на мою функцию ExchequerDouble из ячейки.
Прежде чем продолжить, я должен указать на одну ошибку в приведенном выше коде C / PHP.Если вы посмотрите на циклы Significand:
C/PHP: Significand = Significand + 2 ^ (-i)
VBA: Significand = Significand + 2 ^ (1 - i)
Во время тестирования я заметил, что ответы были очень близкими, но часто неправильными.Развернув все дальше вниз, я сузил его до сигниал.Это может быть проблема с переводом кода с одного языка / методологии на другой, или, возможно, это просто опечатка, но добавление, что (1 - i) имеет все значение.
Function ExchequerDouble(Val1 As Integer, Val2 As Long) As Double
Dim Int2 As String
Dim Int4 As String
Dim Real48 As String
Dim Exponent As String
Dim Sign As String
Dim Significand As String
'Convert each value to binary
Int2 = LongDec2Bin(Val1, 16, True)
Int4 = LongDec2Bin(Val2, 32, True)
'Concatenate the binary strings to produce a 48 bit "Real"
Real48 = Int4 & Int2
'Calculate the exponent
Exponent = LongBin2Dec(Right(Real48, 8)) - 129
'Calculate the sign
Sign = Left(Real48, 1)
'Begin calculation of Significand
Significand = "1.0"
For i = 2 To 40
If Mid(Real48, i, 1) = "1" Then
Significand = Significand + 2 ^ (1 - i)
End If
Next i
ExchequerDouble = CDbl(((-1) ^ Sign) * Significand * (2 ^ Exponent))
End Function
Function LongDec2Bin(ByVal sDecimal As String, Optional lBits As Long = 32, Optional blZeroize As Boolean = False) As String
'Transforms decimal number into binary number.
'Reverse("moc.LiborPlus.www") V0.3 P3 16-Jan-2011
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 'negative fractions later..
LongDec2Bin = 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
LongDec2Bin = 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
LongDec2Bin = CVErr(x1ErrNum)
Exit Function
Else
If (Len(sB) = lBits) And (Left(sB, 1) <> -blNeg & "") Then
LongDec2Bin = 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
LongDec2Bin = sB
Else
LongDec2Bin = sB
End If
End Function
Function LongBin2Dec(sBinary As String, Optional lBits As Long = 32) As String
'Transforms binary number into decimal number.
'Reverse("moc.LiborPlus.www") V0.3 PB 16-Jan-2011
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(sBinary, 1) = "1") And Len(sBin) >= lBits Then 'negative fractions later..
LongBin2Dec = CVErr(xlErrVa1ue)
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
LongBin2Dec = CVErr(x1ErrNum)
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
LongBin2Dec = CVErr(xlErrNum)
Exit Function
End Select
sD = sbDecAdd(sD, sD) 'Double sd
Next i
If lPosDec > 0 Then 'now the fraction
sD = "0.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
LongBin2Dec = "-" & sR
Else
LongBin2Dec = sR
End If
End Function
Function sbDivBy2(sDecimal As String, blInt As Boolean) As String
'Divide sDecimal by two, blInt = TRUE returns integer only
'Reverse("moc.LiborPlus.www") V0.3 PB 16-Jan-2011
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
'Without decimal point lPosDec already defines location of decimal point
sDec = Left(sDecimal, lPosDec - 1) & Right(sDecimal, Len(sDecimal) - lPosDec)
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 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
'Insert decimal point again
sD = Left(sD, lPosDec - 1) _
& Application.DecimalSeparator & Mid(sD, lPosDec, i - lPosDec + 1)
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
'Reverse("moc.LiborPlus.www") V0.3 PB 16-Jan-2011
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 string decimals.
'Reverse("moc.LiborPlus.www") V0.3 PB 16-Jan-2011
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 lPosDecl > lPosDec2 Then
sF2 = sF2 & String(lPosDec1 - lPosDec2, "0")
Else
sF1 = sFl & String(lPosDec2 - lPosDec1, "0")
lPosDec1 = lPosDec2
End If
sF1 = sbDecAdd(sF1, sF2) 'Add fractions as integer numbers
If Len(sF1) > lPosDecl 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(sl)
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
Этот код работает, но иногда (около 1% моих тестовых данных) вы получаете пару копеек по сравнению с функцией Iris EntDouble из надстройки Excel.Я приписываю это точности, если кто-то не может понять это.
В конечном счете, получение этой работы в VBA было моим доказательством концепции проверки того, что все работает.Предполагаемой платформой для этой функциональности был SQL Server.Если у вас есть Exchequer DB, связанная с SQL Server, вы должны иметь возможность запускать эту функцию непосредственно для данных из Pervasive DB.В моем случае мы собираемся выгрузить данные транзакций за последние 2,5 года в статическую таблицу на SQL Server, но мы работаем с этими данными только один раз в год, поэтому это не проблема.Следующие две функции должны отсортировать вас.С точки зрения точности, они эквивалентны приведенному выше коду VBA, причем некоторые из них иногда выпадают на пару пенни, но кажется, что в 99% случаев это точно так же.Мы используем SQL Server 2000, поэтому есть некоторые вещи, которые, вероятно, можно оптимизировать (Varchar (MAX) для одной) для более новых версий, но в конечном итоге, насколько я знаю, это должно работать нормально.
CREATE FUNCTION dbo.FUNCTION_Exchequer_Double
(
@Val1 AS SmallInt,
@Val2 AS BigInt
)
RETURNS Decimal(38, 10)
AS
BEGIN
-- Declare and set decoy variables
DECLARE @Val1_Decoy AS SmallInt
DECLARE @Val2_Decoy AS BigInt
SELECT @Val1_Decoy = @Val1,
@Val2_Decoy = @Val2
-- Declare other variables
DECLARE @Val1_Binary AS Varchar(16)
DECLARE @Val2_Binary AS Varchar(32)
DECLARE @Real48_Binary AS Varchar(48)
DECLARE @Real48_Decimal AS BigInt
DECLARE @Exponent AS Int
DECLARE @Sign AS Bit
DECLARE @Significand AS Decimal(19, 10)
DECLARE @BitCounter AS Int
DECLARE @Two As Decimal(38, 10) -- Saves us casting inline in the code
DECLARE @Output AS Decimal(38, 10)
-- Convert values into two binary strings of the correct length (Val1 = 16 bits, Val2 = 32 bits)
SELECT @Val1_Binary = Replicate(0, 16 - Len(dbo.FUNCTION_Convert_To_Base(Cast(@Val1_Decoy AS Binary(2)), 2)))
+ dbo.FUNCTION_Convert_To_Base(Cast(@Val1_Decoy AS Binary(2)), 2),
@Val2_Binary = Replicate(0, 32 - Len(dbo.FUNCTION_Convert_To_Base(Cast(@Val2_Decoy AS Binary(4)), 2)))
+ dbo.FUNCTION_Convert_To_Base(Cast(@Val2_Decoy AS Binary(4)), 2)
-- Find the decimal value of the new 48 bit number and its binary value
SELECT @Real48_Decimal = @Val2_Decoy * Power(2, 16) + @Val1_Decoy
SELECT @Real48_Binary = @Val2_Binary + @Val1_Binary
-- Determine the Exponent (takes the first 8 bits and subtracts 129)
SELECT @Exponent = Cast(@Real48_Decimal AS Binary(1)) - 129
-- Determine the Sign
SELECT @Sign = Left(@Real48_Binary, 1)
-- A bit of setup for determining the Significand
SELECT @Significand = 1,
@Two = 2,
@BitCounter = 2
-- Determine the Significand
WHILE @BitCounter <= 40
BEGIN
IF Substring(@Real48_Binary, @BitCounter, 1) Like '1'
BEGIN
SELECT @Significand = @Significand + Power(@Two, 1 - @BitCounter)
END
SELECT @BitCounter = @BitCounter + 1
END
SELECT @Output = Power(-1, @Sign) * @Significand * Power(@Two, @Exponent)
-- Return the output
RETURN @Output
END
CREATE FUNCTION dbo.FUNCTION_Convert_To_Base
(
@value AS BigInt,
@base AS Int
)
RETURNS Varchar(8000)
AS
BEGIN
-- Code from http://dpatrickcaldwell.blogspot.co.uk/2009/05/converting-decimal-to-hexadecimal-with.html
-- some variables
DECLARE @characters Char(36)
DECLARE @result Varchar(8000)
-- the encoding string and the default result
SELECT @characters = '0123456789abcdefghijklmnopqrstuvwxyz',
@result = ''
-- make sure it's something we can encode. you can't have
-- base 1, but if we extended the length of our @character
-- string, we could have greater than base 36
IF @value < 0 Or @base < 2 Or @base > 36
RETURN Null
-- until the value is completely converted, get the modulus
-- of the value and prepend it to the result string. then
-- devide the value by the base and truncate the remainder
WHILE @value > 0
SELECT @result = Substring(@characters, @value % @base + 1, 1) + @result,
@value = @value / @base
-- return our results
RETURN @result
END
Не стесняйтесьиспользуйте мой VBA или SQL-код.По-настоящему тяжелую работу проделал тот, кто конвертировал его в PHP выше.Если кто-нибудь найдет способ улучшить что-либо, пожалуйста, дайте мне знать, чтобы мы могли сделать этот код максимально совершенным.
Спасибо!