Attribute VB_Name = "Modul1"
Option Explicit

Public Trenner As String

'+ FÜR WORD 97 angepaßte Excel 97 Anwendung!
'+ entwickelt von Winfried Radner
'+ e-mail: Wolf.W.Radzinski@onlinehome.de
'+ Benutzung frei - ohne Gewähr
'+ Excelversion siehe http://www.rendar.de
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ WorteinBetragUmwandeln():
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ diese Funktion wandelt ein ausgeschriebenes Zahlwort in
'+ einen Ziffernstring zurück, da M$ max. "Long" Zahlen verkraftet
'+ hab ich ersatzweise meine Langziffernaddition benutzt, um die
'+ Zahl auch wirklich korrekt darzustellen.
'+ d.h. 1000*10^63 -1 ist die höchste umwandelbare Zahl, das entspricht
'+ "neunhundertneunundneunzigdekilliarden...usw"
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Sub WorteinBetragUmwandeln()

Dim Titel As String
Dim x As String

If Selection.Type <> wdSelectionNormal Then
    MsgBox "Markieren Sie einen Betrag.", , Titel
    End
    End If
x = Selection.Text
If Right(x, 1) = Chr(13) Then x = Left(x, Len(x) - 1)

Selection.Text = Wort_in_Zahl(x)
End Sub


Sub getTrenner()
    'dient nur dazu bei Zeilentrennung die unterschiedlichen Trennungen
    'evtl. inkl. Rahmung der Zeilen automatisch zu erfassen
    'einfach von Ende eines Textes bis zum Anfang des Textes
    'in der nächsten Zeile markieren und dieses Makro aufrufen.
    Trenner = ""
    If Selection.Type = wdSelectionNormal Then Trenner = Selection.Text
End Sub

'HINWEIS:
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+ SO KANN MAN sich seine eigene Umwandlungsfunktion zurechtbiegen
'+ für evtl Erweiterungen!
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+ FÜR WORD WERDEN NUR DIE PARAMETER DER FOLGENDEN FUNKTION AN EIGENE
'+ WÜNSCHE ANGEPASST!

Public Function Wort_in_Zahl(ByVal i As String) As String

'Standard passend zur Wahl in "inWorten" gewählt
    If Trenner = "" Then Trenner = "-" & Chr(13)
    
    Wort_in_Zahl = inZahlen(i, , Trenner)
    
End Function

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+
'+
'+
'+ inZahlen(): wandelt einen (Zahlwort)String in
'+ eine Zahl (oder einen Ziffernstring)um
'+
'+
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Public Function inZahlen(Eingabezahl As String, _
                         Optional anz_double = False, _
                         Optional Worttrennung = "-" & vbNewLine) As String

'lokale Variablendeklaration
Dim n(20, 1) As String
Dim m(21, 1) As String
Dim a(11, 1) As String

Dim zw As String
Dim zahl As Double
Dim ergebnis As Double
Dim tausendertrennung As Boolean
Dim tt As String
Dim zahl_s As String
Dim ergebnis_s As String

'Schleifenvariable
Dim i As Integer

On Error Resume Next

'Initialisierung
If IsNull(anz_double) Then anz_double = False

zahl = 0
ergebnis = 0

zahl_s = "0"
ergebnis_s = "0"

tt = ""
tausendertrennung = True
If tausendertrennung Then tt = "."

'Number defs
n(0, 0) = "null": n(0, 1) = "+ 0 "
n(10, 0) = "ein": n(10, 1) = "+ 1 "
n(13, 0) = "zwei": n(13, 1) = "+ 2 "
n(14, 0) = "drei": n(14, 1) = "+ 3 "
n(15, 0) = "vier": n(15, 1) = "+ 4 "
n(16, 0) = "fünf": n(16, 1) = "+ 5 "
n(17, 0) = "sech": n(17, 1) = "+ 6 "
n(18, 0) = "sieb": n(18, 1) = "+ 7 "
n(19, 0) = "acht": n(19, 1) = "+ 8 "
n(20, 0) = "neun": n(20, 1) = "+ 9 "
n(1, 0) = "zehn": n(1, 1) = "+ 10 "
n(11, 0) = "elf": n(11, 1) = "+ 11 "
n(12, 0) = "zwölf": n(12, 1) = "+ 12 "
n(2, 0) = "zwanzig": n(2, 1) = "+ 20 "
n(3, 0) = "dreißig": n(3, 1) = "+ 30 "
n(4, 0) = "vierzig": n(4, 1) = "+ 40 "
n(5, 0) = "fünfzig": n(5, 1) = "+ 50 "
n(6, 0) = "sechzig": n(6, 1) = "+ 60 "
n(7, 0) = "siebzig": n(7, 1) = "+ 70 "
n(8, 0) = "achtzig": n(8, 1) = "+ 80 "
n(9, 0) = "neunzig": n(9, 1) = "+ 90 "

'Multiplikationsworte
m(0, 0) = "hundert": m(0, 1) = "* 02 "
m(1, 0) = "tausend": m(1, 1) = "* 03 "
m(2, 0) = "million": m(2, 1) = "* 06 "
m(3, 0) = "milliarde": m(3, 1) = "* 09 "
m(4, 0) = "billion": m(4, 1) = "* 12 "
m(5, 0) = "billiarde": m(5, 1) = "* 15 "
m(6, 0) = "trillion": m(6, 1) = "* 18 "
m(7, 0) = "trilliarde": m(7, 1) = "* 21 "
m(8, 0) = "quadrillion": m(8, 1) = "* 24 "
m(9, 0) = "quadrilliarde": m(9, 1) = "* 27 "
m(10, 0) = "quintillion": m(10, 1) = "* 30 "
m(11, 0) = "quintilliarde": m(11, 1) = "* 33 "
m(12, 0) = "sextillion": m(12, 1) = "* 36 "
m(13, 0) = "sextilliarde": m(13, 1) = "* 39 "
m(14, 0) = "septillion": m(14, 1) = "* 42 "
m(15, 0) = "septilliarde": m(15, 1) = "* 45 "
m(16, 0) = "oktillion": m(16, 1) = "* 48 "
m(17, 0) = "oktilliarde": m(17, 1) = "* 51 "
m(18, 0) = "nonillion": m(18, 1) = "* 54 "
m(19, 0) = "nonilliarde": m(19, 1) = "* 57 "
m(20, 0) = "dekillion": m(20, 1) = "* 60 "
m(21, 0) = "dekilliarde": m(21, 1) = "* 63 "
'Quelle: http://www.rhrk.uni-kl.de/~jonietz/jufo/1999a/node16.html

'Anpassungen
a(0, 0) = "ss": a(0, 1) = "ß"
a(1, 0) = "ue": a(1, 1) = "ü"
a(2, 0) = "oe": a(2, 1) = "ö"
a(3, 0) = "ardeneun": a(3, 1) = "arde+9 "
a(4, 0) = "arden": a(4, 1) = "arde"
a(5, 0) = "ionen": a(5, 1) = "ion"
a(6, 0) = "eins": a(6, 1) = "ein"
a(7, 0) = "eine": a(7, 1) = "ein"
a(8, 0) = "sechs": a(8, 1) = "sech"
a(9, 0) = "sieben": a(9, 1) = "sieb"
a(10, 0) = "und": a(10, 1) = ""
a(11, 0) = "hert": a(11, 1) = "hundert"
'evtl. Worttrennung aufheben
a(12, 0) = Worttrennung: a(12, 1) = ""
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ Berechnung starten
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

zw = LCase(Eingabezahl)

'mache Textanpassungen
For i = 0 To 12
    zw = ersatz_text(1, a(i, 0), a(i, 1), zw)
    Next i

'füge Multiplikatoren ein
For i = 0 To 21
    zw = ersatz_text(1, m(i, 0), m(i, 1), zw)
    Next i

'füge Zahlen ein
For i = 0 To 20
    zw = ersatz_text(1, n(i, 0), n(i, 1), zw)
    Next i

'entferne an beiden Enden falsche Zeichen
Do While Left(zw, 1) <> "+"
    zw = Right(zw, Len(zw) - 1)
    If Len(zw) < 1 Then Exit Function
    Loop

Do While Right(zw, 1) <> " "
    zw = Left(zw, Len(zw) - 1)
    If Len(zw) < 1 Then Exit Function
    Loop

'Anzeige in Double
If Not anz_double Then GoTo anz_str
Do While Len(zw) > 0
    Select Case Left(zw, 1)
        Case "+": zahl = zahl + Val(zw)
                  zw = Right(zw, Len(zw) - InStr(3, zw, " "))
        Case "*": zahl = zahl * 10 ^ Val(Right(zw, Len(zw) - 1))
                  If Val(Right(zw, Len(zw) - 1)) > 2 Then
                      ergebnis = ergebnis + zahl
                      zahl = 0
                      End If
                  zw = Right(zw, Len(zw) - InStr(3, zw, " "))
        Case Else: zw = ""
        End Select
    Loop
inZahlen = CStr(ergebnis + zahl)
Exit Function

anz_str:

Do While Len(zw) > 0
    Select Case Left(zw, 1)
        Case "+": zahl_s = lz_plus(zahl_s, CStr(Val(zw)))
                  zw = Right(zw, Len(zw) - InStr(3, zw, " "))
        Case "*": zahl_s = lz_mult(zehnhoch(Val(Right(zw, Len(zw) - 1))), zahl_s)
                  If Val(Right(zw, Len(zw) - 1)) > 2 Then
                      ergebnis_s = lz_plus(ergebnis_s, zahl_s)
                      zahl_s = "0"
                      End If
                  zw = Right(zw, Len(zw) - InStr(3, zw, " "))
        Case Else: zw = ""
             'falsches Zeichen im String
             'Zahl hier zu Ende!
        End Select
    Loop
inZahlen = tsdtrenn(lz_plus(ergebnis_s, zahl_s), tt)

End Function

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ ersatz_text(): ändert in Eingabestring alle "altText" in "neuText"
'+ muß ich halt doch meine eigene Funktion verwenden, die
'+ Funktion soll Worksheetfunction.Substitute ersetzen
'+ (zu finden unter http://www.rendar.de)
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Function ersatz_text(pos As Integer, _
                             altText As String, _
                             neuText As String, _
                             t As String) As String
On Error Resume Next

Dim pos_is As Integer
Dim lt As Integer
Dim ls As Integer

ersatz_text = ""
If pos > 1 And altText <> "" Then
  If pos < Len(t) Then
     ersatz_text = Left(t, pos - 1)
     t = Right(t, Len(t) - pos + 1)
  Else
     ersatz_text = t
     Exit Function
  End If
End If
lt = Len(t)
ls = Len(altText)
Do
   pos_is = InStr(1, t, altText)
   If pos_is > 0 Then
       ersatz_text = ersatz_text & Left(t, pos_is - 1) & neuText
       lt = lt - pos_is - ls + 1
       t = Right(t, lt)
   End If
Loop Until pos_is < 1 Or altText = ""
ersatz_text = ersatz_text & t
End Function


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ lz_plus(() addiert zwei beliebig lange Zahlen
'+
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Private Function lz_plus(ByVal x As String, ByVal y As String) As String

Dim stelle As Integer
Dim ue As Integer

Dim lx As Integer
Dim ly As Integer
Dim i As Integer

lz_plus = ""
stelle = 0
ue = 0

lx = Len(x)
ly = Len(y)

Do While lx < ly
   x = "0" & x
   lx = lx + 1
Loop

Do While ly < lx
   y = "0" & y
   ly = ly + 1
Loop

For i = lx To 1 Step -1
  stelle = CInt(Mid(x, i, 1)) + CInt(Mid(y, i, 1)) + ue
  ue = stelle \ 10
  stelle = stelle Mod 10
  lz_plus = CStr(stelle) & lz_plus
Next i
If ue > 0 Then lz_plus = CStr(ue) & lz_plus

Do While Left(lz_plus, 1) = "0" And Len(lz_plus) > 1
lz_plus = Right(lz_plus, Len(lz_plus) - 1)
Loop
End Function


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ lz_mult(() multipliziert zwei beliebig lange Zahlen
'+
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Private Function lz_mult(ByVal x As String, y As String) As String

Dim mult As String
Dim mult_i As String

Dim tempy As String
Dim gz As Boolean

Dim i As Long
Dim j As Long
Dim jx As Long

Dim k As Integer

'berechnung x*y
mult = "0"
j = Len(y)
jx = Len(x)
'Zahl der For-Schleifen minimieren, wenn nötig
'tausche x und y
If j > jx Then
  tempy = y
  y = x
  x = tempy
  j = jx
End If
gz = False 'führende Nullen in y?

If j > 0 Then
  For i = 1 To j
    mult_i = "0"
    k = CInt(Mid(y, i, 1))
    Select Case k
    Case Is > 0:
       mult_i = x '1x
       If k > 1 Then mult_i = lz_plus(x, x) '2x
       Select Case k
         Case 3, 6, 7:
            mult_i = lz_plus(mult_i, x) '3x
            If k > 5 Then mult_i = lz_plus(mult_i, mult_i) '6x
            If k = 7 Then mult_i = lz_plus(mult_i, x) '7x
         Case 4, 5, 8, 9:
            mult_i = lz_plus(mult_i, mult_i) '4x
            If k = 5 Then mult_i = lz_plus(mult_i, x) '5x
            If k > 7 Then mult_i = lz_plus(mult_i, mult_i) '8x
            If k = 9 Then mult_i = lz_plus(mult_i, x) '9x
         Case Else: 'wie kommt?
       End Select
       mult = lz_plus(mult, mult_i)
       gz = True 'k war größer Null
    Case 0: 'tue nichts
    Case Else: 'falsches Zeichen
    End Select
    If gz And i < j Then
       mult = mult & "0" '10x
     End If
  Next i
End If
lz_mult = mult
End Function


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ zehnhoch(() gibt 10^x als String aus
'+
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Private Function zehnhoch(ByVal x As Integer) As String
    zehnhoch = "1"
    Do While x > 0
        zehnhoch = zehnhoch & "0"
        x = x - 1
        Loop
End Function


'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ tsdtrenn(() fügt Tausendertrennung zum Zahlstring hinzu
'+
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++


Private Function tsdtrenn(ByVal x As String, _
                          Optional tt = ".") As String
    tsdtrenn = ""
    If Len(x) <= 3 Or Len(tt) < 1 Then
        tsdtrenn = x
        Exit Function
        End If
    If Len(x) Mod 3 > 0 Then
       tsdtrenn = Left(x, Len(x) Mod 3)
       x = Right(x, Len(x) - (Len(x) Mod 3))
       End If
    Do While Len(x) > 0
       tsdtrenn = tsdtrenn & tt & Left(x, 3)
       x = Right(x, Len(x) - 3)
       Loop
    If Left(tsdtrenn, 1) = tt Then tsdtrenn = Right(tsdtrenn, Len(tsdtrenn) - 1)
End Function