Vba code : Spellling number can running in ms excel and ms word

[muhammad susanto]

hi all,

i am looking someone could help me, how to modify/change this macro code below can running in ms word 2007,
actually this macro worked in excel 2007 and i want to run too in ms word 2007..the macro code called "spelling number in indonesia language (rupiah)

Public Function Terbilang(x As Currency)    Dim triliun As Currency
    Dim milyar As Currency
    Dim juta As Currency
    Dim ribu As Currency
    Dim satu As Currency
    Dim sen As Currency
    Dim baca As String
    If x > 1000000000000# Then
       Terbilang = "< di atas satu triliun rupiah >"
       Exit Function
    End If
    'Jika x adalah 0, maka dibaca sebagai 0
    If x = 0 Then
       baca = angka(0, 1)
    Else
       'Pisah masing-masing bagian untuk triliun, milyar, juta, ribu, rupiah, dan sen
       triliun = Int(x * 0.001 ^ 4)
       milyar = Int((x - triliun * 1000 ^ 4) * 0.001 ^ 3)
       juta = Int((x - triliun * 1000 ^ 4 - milyar * 1000 ^ 3) / 1000 ^ 2)
       ribu = Int((x - triliun * 1000 ^ 4 - milyar * 1000 ^ 3 - juta * 1000 ^ 2) / 1000)
       satu = Int(x - triliun * 1000 ^ 4 - milyar * 1000 ^ 3 - juta * 1000 ^ 2 - ribu * 1000)
       sen = Int((x - Int(x)) * 100)
       'Baca bagian triliun dan ditambah akhiran triliun
       If triliun > 0 Then
          baca = ratus(triliun, 5) + "triliun "
       End If
       'Baca bagian milyar dan ditambah akhiran milyar
       If milyar > 0 Then
          baca = ratus(milyar, 4) + "milyar "
       End If
       'Baca bagian juta dan ditambah akhiran juta
       If juta > 0 Then
          baca = baca + ratus(juta, 3) + "juta "
       End If
       'Baca bagian ribu dan ditambah akhiran ribu
       If ribu > 0 Then
          baca = baca + ratus(ribu, 2) + "ribu "
       End If
       'Baca bagian rupiah dan ditambah akhiran rupiah
       If satu > 0 Then
          baca = baca + ratus(satu, 1) + "rupiah "
       Else
          baca = baca + "rupiah"
       End If
       'Baca bagian sen dan ditambah akhiran sen
       If sen > 0 Then
          baca = baca + ratus(sen, 0) + "sen"
       End If
    End If
    Terbilang = UCase(Left(baca, 1)) & LCase(Mid(baca, 2))
End Function


Function ratus(x As Currency, Posisi As Integer) As String
    Dim a100 As Integer, a10 As Integer, a1 As Integer
    Dim baca As String
    a100 = Int(x * 0.01)
    a10 = Int((x - a100 * 100) * 0.1)
    a1 = Int(x - a100 * 100 - a10 * 10)
    'Baca Bagian Ratus
    If a100 = 1 Then
       baca = "Seratus "
    Else
       If a100 > 0 Then
          baca = angka(a100, Posisi) + "ratus "
       End If
    End If
    'Baca Bagian Puluh dan Satuan
    If a10 = 1 Then
       baca = baca + angka(a10 * 10 + a1, Posisi)
    Else
       If a10 > 0 Then
          baca = baca + angka(a10, Posisi) + "puluh "
       End If
       If a1 > 0 Then
          baca = baca + angka(a1, Posisi)
       End If
    End If
    ratus = baca
End Function


Function angka(x As Integer, Posisi As Integer)
    Select Case x
        Case 0: angka = "Nol"
        Case 1:
            If Posisi <= 1 Or Posisi > 2 Then
               angka = "Satu "
            Else
               angka = "Se"
            End If
        Case 2: angka = "Dua "
        Case 3: angka = "Tiga "
        Case 4: angka = "Empat "
        Case 5: angka = "Lima "
        Case 6: angka = "Enam "
        Case 7: angka = "Tujuh "
        Case 8: angka = "Delapan "
        Case 9: angka = "Sembilan "
        Case 10: angka = "Sepuluh "
        Case 11: angka = "Sebelas "
        Case 12: angka = "Duabelas "
        Case 13: angka = "Tigabelas "
        Case 14: angka = "Empatbelas "
        Case 15: angka = "Limabelas "
        Case 16: angka = "Enambelas "
        Case 17: angka = "Tujuhbelas "
        Case 18: angka = "Delapanbelas "
        Case 19: angka = "Sembilanbelas "
    End Select
End Function

it's possible? anyone assistance, will be greatly appreciated...

m.susanto
cheers

 

[Macropod]

The only problem with your function is that you have:
Public Function Terbilang(x As Currency) Dim triliun As Currency
This should be:
Public Function Terbilang(x As Currency)
Dim triliun As Currency
Fix that and it will work in any Office application, as there is no particular Excel code in it.

 

[muhammad susanto]

hi Paul, thanks but i have do it like as your suggestion but not working...

i don't know how can it's work..

could you help me?

 

[muhammad susanto]

here my correction code...

Option Explicit

Sub ctvTerbilang()
  '== STDEV(i) <setiyowati.devi@Gmail.com>,===
  ' retouched: awal Janari 2012
  '--------------------------------------------
   Dim Number As Variant, SeTtxt As Variant
   Dim Kata As String, sText As String
   Const Ttel As String = "ctv_Terbilang Max 18 digit!!"
   
'   sText = Replace(Selection, Chr(10), "")
'   Selection = sText
   
   On Error Resume Next
   SeTtxt = CDec(Selection)
   If Not TypeName(SeTtxt) = "Decimal" Then
      ' membalik [titik] vs [koma] jika ada
      Selection = Replace(Selection, ",", "\")
      Selection = Replace(Selection, ".", "|")
      Selection = Replace(Selection, "\", ".")
      Selection = Replace(Selection, "|", ",")
   End If
   
   If IsNumeric(Selection) Then
      Number = CDec(Selection)
      With Selection
         .Copy
         .EndKey Unit:=wdLine
         .TypeParagraph
      End With


      Select Case Number
         Case 0
            Kata = "Zero"
         Case 0.001 To 1E+18
            Kata = TERBILANG(Number)
         Case Else
            MsgBox "Bilangan Terlalu besar!", 48, Ttel
      End Select
   Else
      MsgBox "Maaf, karakters yg diblok: tidak dapat dianggap sbg bilangan!!", 48, Ttel
      Exit Sub
   End If
   Selection = Kata
End Sub




Private Function TERBILANG(Nnum As Variant) As String
  '== siti Vi  <Villager.girl@Gmail.com>,=====
  '== STDEV(i) <setiyowati.devi@Gmail.com>,===
  '--- revisi awal jan 2012 ------------------
   Dim nUtuh As Variant, nDesi As Variant
   Dim sUtuh As String, sDesi As String
   Nnum = CDec(Round(Nnum, 2))
   nUtuh = CDec(Int(Nnum))
   nDesi = CDec(Round((Nnum - nUtuh) * 100, 0))
   sUtuh = TransX(nUtuh)
   If nDesi = 0 Then
      sDesi = ""
   Else
      sDesi = "dan " & TransX(nDesi) & " per seratus"
   End If
   TERBILANG = Trim(sUtuh & " " & sDesi)
End Function




Private Function TransX(Bilangan As Variant) As String
  '== siti Vi  <Villager.girl@Gmail.com>,=====
  '== STDEV(i) <setiyowati.devi@Gmail.com>,===
  '--------------------------------------------
   Dim TxtBil As String, Teks As String, i As Integer, Pos As Integer
   Dim Angka(19) As String, Puluh(9) As String, Letak(4) As String
   Dim DwiDigit As Byte, TriD1 As Byte, TriD2 As Byte, TriD3 As Byte
   Angka(1) = "satu":         Angka(2) = "dua":           Angka(3) = "tiga"
   Angka(4) = "empat":        Angka(5) = "lima":          Angka(6) = "enam"
   Angka(7) = "tujuh":        Angka(8) = "delapan":       Angka(9) = "sembilan":
   Angka(10) = "sepuluh":     Angka(11) = "sebelas":      Angka(12) = "dua belas"
   Angka(13) = "tiga belas":  Angka(14) = "empat belas":  Angka(15) = "lima belas"
   Angka(16) = "enam belas":  Angka(17) = "tujuh belas":  Angka(18) = "delapan belas"
   Angka(19) = "sembilan belas"
   Puluh(0) = "":             Puluh(2) = "dua puluh":     Puluh(3) = "tiga puluh"
   Puluh(4) = "empat puluh":  Puluh(5) = "lima puluh":    Puluh(6) = "enam puluh"
   Puluh(7) = "tujuh puluh":  Puluh(8) = "delapan puluh": Puluh(9) = "sembilan puluh"
   Letak(0) = "ribu":    Letak(1) = "juta"
   Letak(2) = "milyar":  Letak(3) = "triliun":   Letak(4) = "kuadriliun"
   Bilangan = CDec(Bilangan)
   TxtBil = Trim(Str(Round(Abs(Bilangan), 0)))
   If CDec(TxtBil) = 0 Then
      Teks = "nol "
   Else
      i = 0
      Do
         TxtBil = "000" + TxtBil
         DwiDigit = CByte(Right(TxtBil, 2))
         If (DwiDigit > 0) And (DwiDigit < 20) Then
            Teks = IIf((Bilangan < 2000 And i = 1), "se", Angka(DwiDigit) + " ") + Teks
         Else
            TriD3 = CByte(Right(TxtBil, 1))
            If (TriD3 > 0) Then Teks = Angka(TriD3) + " " + Teks
            TriD2 = CByte(Left(Right(TxtBil, 2), 1))
            If (TriD2 > 0) Then Teks = Puluh(TriD2) + " " + Teks
         End If
         TriD1 = CByte(Left(Right(TxtBil, 3), 1))
         If (TriD1 = 1) Then Teks = "seratus " + Teks
         If (TriD1 > 1) Then Teks = Angka(TriD1) + " ratus " + Teks
         TxtBil = Left(TxtBil, Len(TxtBil) - 3)
         If (CDec(TxtBil) > 0) Then
            Teks = IIf(CInt(Right(TxtBil, 3)) = 0, "", Letak(i) + " ") + Teks
            i = i + 1
         End If
      Loop While ((CDec(TxtBil) > 0) And (i < 6))
   End If
   TransX = Trim(Teks)
End Function
'------------------------

how to adding string "rupiah" in last of sentences....

example :
1000
seribu rupiah
555.750
lima ratus lima puluh .......rupiah