Habe Ansatzweise etwas gefunden. Muss das aber erst noch ausprobieren.
' -------------------------------------------------------------
' Beschreibung:
' -----------------------------------------------------
' IEEE Standard 754 Floating Point Numbers
'
' Umrechnung FloatingPoint - Normalzahl
'
' (c)2003 by Urs Dietrich
'
' -----------------------------------------------------
' Ein Beispiel:
'
' Eingabe: @rÀ
' ASCII-Werte: 64, 114, 192
' ASCII-Wetrte in Binär umgewandelt:
' 01000000, 01110010, 11000000
' Diese Aneinandergereiht und auf 64bit ergänzt:
' 0100000001110010110000000000000000000000000000000000000000000000
'
' Aufteilung:
' Bit1 (ganz Rechts): Vorzeichen (0=+, 1=-)
' Bit2-11: Exponent
' Rest: Mantisse
'
' Exponent:
' 10000000111(bin) = 1031(dec), das Minus Bias(=1027) -> Exponent = 8
'
' Mantisse:
' 0010110000000000000000000000000000000000000000000000
' in Hex: 2C0000000000
' Dem Hexwert eine 1 voranstellen: 12C0000000000
' Dann in Dec umwandeln: 5277655813324800
' Diesen Wert solange durch 2 dividieren, bis der Wert < 2 ist
' -> 1.171875
'
' Jetzt alles zusammenfügen:
' Mantisse * 2^Exponent
' 1.171875 * 2^8
' = 300
'
' Der gesuchte Wert ist also 300
'-----------------------------------------------------
Option Explicit
Hauptfunktion:
Public Function FloatingPointToDec(AsciiString As String) As Long
' Übergeben wird ein String mit ASCII Zeichen
Dim Vorzeichen As Integer
Dim exponent As Long
Dim exponentDec As Long
Dim exponentBin As String
Dim mantisse As Double
Dim mantisseDec As Double
Dim mantisseBin As String
Dim mantisseHex As String
Dim tempBin As String
Dim tempLänge As Long
Dim tempAscii As String
Dim anzZeichen As Long
Dim arZeichen()
Dim i As Integer
Dim Resultat As Long
' Die Basis ist immer 2
Const basis = 2
' Bei Double Precision wird mit 64bit = 8Byte gearbeitet
Const anzByte = 8
' Die Bias ist bei 64bit 1023, bei 32bit 127
Const Bias = 1023
ReDim arZeichen(0 To anzByte - 1)
anzZeichen = Len(AsciiString)
For i = 0 To anzZeichen - 1
' ASCII Code des Zeichens ermitteln
tempAscii = Asc(Mid(AsciiString, i + 1, 1))
' den ASCII Code in das Binärsystem umwandeln
tempAscii = DezToBin(tempAscii)
tempLänge = Len(tempAscii)
' Vorne mit 0 Auffüllen, bis die länge von einem Byte (8bit)
' erreicht ist
While tempLänge < 8
tempAscii = "0" & tempAscii
tempLänge = Len(tempAscii)
Wend
arZeichen(i) = tempAscii
Next i
' Die restlichen Bytes mit dem Wert 0 auffüllen,
' damit die 64bit erreicht werden
For i = anzZeichen To anzByte - 1
tempAscii = "00000000"
arZeichen(i) = tempAscii
Next i
tempBin = Join(arZeichen, "") ' alle 8Byte aneinanderreihen
Vorzeichen = Mid(tempBin, 1, 1) ' Vorzeichen
' Der Exponent wird aus den bits 2-12 zusammengesetzt
exponentBin = Mid(tempBin, 2, 11)
' Dieser wird in eine Dezimale Zahl umgewandelt
exponentDec = BinToDez(exponentBin)
' Bias vom Exponent subtrahieren
exponent = exponentDec - Bias
' Die Mantisse besteht aus den restlichen Zeichen...
mantisseBin = Mid(tempBin, 13)
' ...die in das Hex-System umgewandelt werden
mantisseHex = BinToHex(mantisseBin)
' Dann wird vor den Hex-Wert eine 1 geschrieben
mantisseHex = "1" & mantisseHex
' Die Nullen am Schluss können in diesem speziellen
' Fall gestrichen werden, weil anschliessend
' durch 2 dividiert wird, und jede Stelle im Hex ja
' den Faktor 16^x hat, und 16/2 aufgeht
While Right$(mantisseHex, 1) = "0"
mantisseHex = Mid$(mantisseHex, 1, Len(mantisseHex) - 1)
Wend
' Und der Wert wieder in das Dezimalsystem umgewandelt
mantisseDec = HexToDez(mantisseHex)
' Nun wird die Zahl so lange durch 2 dividiert,
' bis sie < 2 ist
While mantisseDec >= 2
mantisseDec = mantisseDec / 2
Wend
' Das ist nun die gesuchte mantisse
mantisse = mantisseDec
' Schlussendliche Formel
Resultat = mantisse * 2 ^ exponent
If Vorzeichen = 1 Then
' Nun wird allenfalls noch das Vorzeichen
' gesetzt (nur bei 1 (=-))
Resultat = "-" & Resultat
End If
FloatingPointToDec = Resultat
End Function
Hilfsfunktionen
Private Function BinToDez(ByVal Number As String) As Long
' Binär-Dezimal-Umrechnung
Dim Länge As Integer
Dim Multiplikator As Integer
Dim i As Integer
' Anzahl Stellen der eingegebenen Zahl ermitteln
Länge = Len(Number)
Multiplikator = 1
For i = Länge To 1 Step -1
' Dezimalzahl wird zusammengesetzt
BinToDez = BinToDez + CInt(Mid(Number, i, 1)) * Multiplikator
Multiplikator = Multiplikator * 2
Next i
End Function
Private Function BinToHex(Number As String) As String
' Binär-Hex - Umrechnung
Dim Länge As Integer
Dim tempBin As String
Dim tempHex As String
Dim tempDec As Variant
Dim hex As String
Dim i As Integer
Länge = Len(Number)
While Länge >= 4
tempDec = 0
tempBin = Right(Number, 4)
Number = Left(Number, Len(Number) - 4)
For i = 1 To 4
tempDec = tempDec + Mid(tempBin, 5 - i, 1) * 2 ^ (i - 1)
Next i
Select Case tempDec
Case 10
tempDec = "A"
Case 11
tempDec = "B"
Case 12
tempDec = "C"
Case 13
tempDec = "D"
Case 14
tempDec = "E"
Case 15
tempDec = "F"
End Select
hex = tempDec & hex
Länge = Len(Number)
Wend
BinToHex = hex
End Function
Private Function DezToBin(Number) As String
' Dezimal-Binär-Umrechnung
Dim Rest As Double
Dim Digit As Byte
Dim erha
Rest = Number
Do
Digit = Rest Mod 2 ' Aktuelle Zahl
DezToBin = CStr(Digit) & DezToBin
' Den Rest korrekt abrunden
If Digit = 1 Then
Rest = Rest / 2
Rest = Rest - 0.5
Else
Rest = Rest / 2
End If
Loop Until Rest = 0
End Function
Private Function HexToDez(ByVal Number As String) As Long
' Hex -Dezimal - Umrechnung
Dim Länge As Integer
Dim Multiplikator As Long
Dim i As Integer
Dim Currentpos As String
Dim CurrentInt As Long
Länge = Len(Number)
Multiplikator = 1
For i = Länge To 1 Step -1
Currentpos = Mid(Number, i, 1)
' Buchstaben müssen in Zahlen umgewandelt werden
Select Case LCase(Currentpos)
Case Is = "a"
CurrentInt = 10
Case Is = "b"
CurrentInt = 11
Case Is = "c"
CurrentInt = 12
Case Is = "d"
CurrentInt = 13
Case Is = "e"
CurrentInt = 14
Case Is = "f"
CurrentInt = 15
Case Else
If Asc(Currentpos) >= 48 And Asc(Currentpos) <= 57 Then
CurrentInt = CInt(Currentpos)
Else
MsgBox "Zahl ist ungültig!", vbCritical
Exit Function
End If
End Select
HexToDez = HexToDez + (CurrentInt * Multiplikator)
Multiplikator = Multiplikator * 16
Next i
End Function
