vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Zippen wie die Profis!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Variablen/Strings · Algorithmen/Mathematik   |   VB-Versionen: VB4, VB5, VB620.11.03
IEEE Standard 754 Floating Point Numbers

Funktion zur Umrechnung von FloatingPoint in Normalzahlen

Autor:   Urs DietrichBewertung:     [ Jetzt bewerten ]Views:  24.176 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 Beispielprojekt auf CD 
' -------------------------------------------------------------
' 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

Beispiel:
Die Funktion wird aufgerufen wird durch:

MsgBox FloatingPointToDec(txtFP.Text)

wobei in txtFP die Zeichenfolge steht, deren ASCII Werte umgerechnet werden sollen.
 

Dieser Tipp wurde bereits 24.176 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel