PDA

View Full Version : script vba aneh??

ruboW
16-02-2007, 04:53 PM
maaf saya buat topik baru
ini problemnya..
silakan klik link yg saya berikan (keduanya sama) kl ngak bisa rar.. pasti anda bisa buka yg zip.

berikut ini kode yg jadi sumber malapetaka
Function num2txt(hrg As Integer) As String
PNJ = Len(Str(hrg))

j = 0
For i = PNJ To 1
angka2 = Mid(hrg, i, 1)
angka1 = angka2 & "_" & angka1
j = j + 1

Next

num2txt = angka2
End Function

Private Sub InvoiceAmount_Click()

'InvoiceDescription.SetFocus
PNJ = Len(Str(InvoiceAmount)) - 4
ANGKANYA = Mid(InvoiceAmount, 1, PNJ)
'
' hrg = Str(InvoiceAmount)
Dim Panjang%, StrRuas$, Ulangan%, Rep%, Sisa%, StrSisa$, StrBlok$, UlanganX&
Dim Belakang%, BelakangNum%, IntSwap%, Int10%, RibuRef%
Dim Bilangan%, StrRuasX$, RepX%, StrBilangan$
If ANGKANYA = "0" Or ANGKANYA = "" Then
BacaAngka = "NOL "
'Exit Function
End If
Panjang = Len(CStr(ANGKANYA))
If Panjang > 18 Then 'kalu lebih dari 999.999.999.999.999 (seribu bilyun!?)
BacaAngka = ""
'Exit Function
End If 'misal angkanya Rp 123.456.789.123 terus
Sisa = Panjang Mod 3 'nge-cek apakah jumlah angkanya berkelipatan 3 ?
If Sisa = 0 Then 'kalu angkanya kayak gini: 23.456.789.123
Ulangan = (Panjang - Sisa) / 3
Else
Ulangan = ((Panjang - Sisa) / 3) + 1
End If
UlanganX = Ulangan * 3
StrBlok = Space((Ulangan * 3) - Panjang) & CStr(ANGKANYA)

For Rep = 1 To UlanganX Step 3
StrRuas = Mid(StrBlok, Rep, 3) ' -> ruas string yang isinya tiga angka or less
If StrRuas <> "000" Then
StrRuasX = Trim(StrRuas) ' trimmed ruas, kalu less than 3
For RepX = 1 To Len(StrRuasX)
Bilangan = CInt(Mid(StrRuasX, RepX, 1)) 'number yg mo dibaca dalam satu ruas "###"
Select Case Bilangan
Case 1
Belakang = Len(StrRuasX) - RepX
If Belakang = 2 Then ' -> ***.1##.***
StrBilangan = StrBilangan & "SERATUS "
ElseIf Belakang = 1 Then ' -> ***.#1#.***
IntSwap = CInt(Mid(StrRuasX, RepX, 2))
Select Case IntSwap
Case 10
StrBilangan = StrBilangan & "SEPULUH "
Exit For
Case 11
StrBilangan = StrBilangan & "SEBELAS "
Exit For
Case 12
StrBilangan = StrBilangan & "DUA BELAS "
Exit For
Case 13
StrBilangan = StrBilangan & "TIGA BELAS "
Exit For
Case 14
StrBilangan = StrBilangan & "EMPAT BELAS "
Exit For
Case 15
StrBilangan = StrBilangan & "LIMA BELAS "
Exit For
Case 16
StrBilangan = StrBilangan & "ENAM BELAS "
Exit For
Case 17
StrBilangan = StrBilangan & "TUJUH BELAS "
Exit For
Case 18
StrBilangan = StrBilangan & "DELAPAN BELAS "
Exit For
Case 19
StrBilangan = StrBilangan & "SEMBILAN BELAS "
Exit For
End Select
Else
If Ulangan < 3 And UlanganX > 3 And RepX = 1 Then
StrBilangan = StrBilangan & "SE" '"SERIBU "
Else
StrBilangan = StrBilangan & "SATU "
End If
End If
Case 2
StrBilangan = StrBilangan & "DUA "
Case 3
StrBilangan = StrBilangan & "TIGA "
Case 4
StrBilangan = StrBilangan & "EMPAT "
Case 5
StrBilangan = StrBilangan & "LIMA "
Case 6
StrBilangan = StrBilangan & "ENAM "
Case 7
StrBilangan = StrBilangan & "TUJUH "
Case 8
StrBilangan = StrBilangan & "DELAPAN "
Case 9
StrBilangan = StrBilangan & "SEMBILAN "
End Select
If Bilangan <> 0 Then
BelakangNum = Len(StrRuasX) - RepX
If BelakangNum = 2 Then
If Bilangan <> 1 Then
StrBilangan = StrBilangan & "RATUS "
End If
ElseIf BelakangNum = 1 Then
StrBilangan = StrBilangan & "PULUH "
End If
End If
Next 'nomor selandjutnja dalam satu ruas
End If
If StrRuas <> "000" Then
Int10 = UlanganX - Rep
txt = txt & Str(Int10)
Select Case Int10
'Case Is = 2
'If Bilangan <> 1 Then

'End If
Case Is <= 5
If Int10 = 5 Then
StrBilangan = StrBilangan & "RIBU "
block2 = 1
End If
If Int10 = 2 And Not block2 = 1 Then
StrBilangan = StrBilangan & "RIBU "
End If
Case 7 To 9
StrBilangan = StrBilangan & "JUTA "
Case 10 To 12
StrBilangan = StrBilangan & "MILYAR "
Case 13 To 15
StrBilangan = StrBilangan & "TRILIUN "
Case 16 To 18
StrBilangan = StrBilangan & "BILYUN "
End Select
End If
Next 'ruas selandjutnja
'BacaAngka = StrBilangan

InvoiceDescription.SetFocus
InvoiceDescription = StrBilangan & " RUPIAH."
InvoiceAmount.SetFocusmoga2 spacenya cukup
script ini bertujuan mengubah angka jadi text
contoh 3400 jadi tiga ribut empat ratus

yg jadi masalah adalah.. saat masuk 250 keluarnya cuma rupiah
1000 keluar satu ribu.. kira2 kenapa ya?

maaf kl udah menyulitkan saudara/i
bukan mau double post.. ini biar ngak tembus batasnya
ruboW
16-02-2007, 05:31 PM
Link (akan kadaluarsa dalam 30 hari): http://gudangupload.com/filelink.php?filecode=33ce29922e81cbfc67b18c875350acd68ca4c1486fbf95505a74c817c11f25d4 (rar type)
Link (akan kadaluarsa dalam 30 hari): http://gudangupload.com/filelink.php?filecode=6fbf7a9ae325d4ae045fa09b915cba0686ffa5340cbff2863667cfe8f9c8fe89 (zip type)

coba jalankan dahulu programnya
klik pada mdb yg ada lalu pilih "masukkan order"
pilih record terakhir yg bernilai 250
klik preview invoice..
walah.. ngak ada isinya

untuk scriptnya.. anda bisa buka form "print invoice"
lalu buka vbnya.. salah satu scriptnya akan ada tertulis seperti di atas.. ignore yg pas buka.. langsung menuju ke arah Private Sub InvoiceAmount_Click()
masalahnya akan muncul lagi bila nilai harga obat yg dimasukkan 10 ribu?? yg pasti wa coba masukin 1000 keluarnya "satu ribu" bahkan 1100 masih tetap 1 ribu???
ruboW
17-02-2007, 09:33 AM
tambahan aja
saya melakukan tes dengan menulis 1000 yg hasilnya kacau
lalu saya masukkan 1999 hasilnya tetap kacau

tapi saya masukkan 2000 = hasilnya malah benar
kesimpulannya.. error program atas kalau berhadapan dengan angka dibawah 2000 (aneh ya)

kl begitu.. gini aja.. saya takut merepotkan anda lebih byk
1. script yg saya berikanFunction num2txt(hrg As Integer) As String
PNJ = Len(Str(hrg))

j = 0
For i = PNJ To 1
angka2 = Mid(hrg, i, 1)
angka1 = angka2 & "_" & angka1
j = j + 1

Next

num2txt = angka2
End Function

Private Sub InvoiceAmount_Click()

'InvoiceDescription.SetFocus
PNJ = Len(Str(InvoiceAmount)) - 4
ANGKANYA = Mid(InvoiceAmount, 1, PNJ)
'
' hrg = Str(InvoiceAmount)
Dim Panjang%, StrRuas$, Ulangan%, Rep%, Sisa%, StrSisa$, StrBlok$, UlanganX&
Dim Belakang%, BelakangNum%, IntSwap%, Int10%, RibuRef%
Dim Bilangan%, StrRuasX$, RepX%, StrBilangan$
If ANGKANYA = "0" Or ANGKANYA = "" Then
BacaAngka = "NOL "
'Exit Function
End If
Panjang = Len(CStr(ANGKANYA))
If Panjang > 18 Then 'kalu lebih dari 999.999.999.999.999 (seribu bilyun!?)
BacaAngka = ""
'Exit Function
End If 'misal angkanya Rp 123.456.789.123 terus
Sisa = Panjang Mod 3 'nge-cek apakah jumlah angkanya berkelipatan 3 ?
If Sisa = 0 Then 'kalu angkanya kayak gini: 23.456.789.123
Ulangan = (Panjang - Sisa) / 3
Else
Ulangan = ((Panjang - Sisa) / 3) + 1
End If
UlanganX = Ulangan * 3
StrBlok = Space((Ulangan * 3) - Panjang) & CStr(ANGKANYA)

For Rep = 1 To UlanganX Step 3
StrRuas = Mid(StrBlok, Rep, 3) ' -> ruas string yang isinya tiga angka or less
If StrRuas <> "000" Then
StrRuasX = Trim(StrRuas) ' trimmed ruas, kalu less than 3
For RepX = 1 To Len(StrRuasX)
Bilangan = CInt(Mid(StrRuasX, RepX, 1)) 'number yg mo dibaca dalam satu ruas "###"
Select Case Bilangan
Case 1
Belakang = Len(StrRuasX) - RepX
If Belakang = 2 Then ' -> ***.1##.***
StrBilangan = StrBilangan & "SERATUS "
ElseIf Belakang = 1 Then ' -> ***.#1#.***
IntSwap = CInt(Mid(StrRuasX, RepX, 2))
Select Case IntSwap
Case 10
StrBilangan = StrBilangan & "SEPULUH "
Exit For
Case 11
StrBilangan = StrBilangan & "SEBELAS "
Exit For
Case 12
StrBilangan = StrBilangan & "DUA BELAS "
Exit For
Case 13
StrBilangan = StrBilangan & "TIGA BELAS "
Exit For
Case 14
StrBilangan = StrBilangan & "EMPAT BELAS "
Exit For
Case 15
StrBilangan = StrBilangan & "LIMA BELAS "
Exit For
Case 16
StrBilangan = StrBilangan & "ENAM BELAS "
Exit For
Case 17
StrBilangan = StrBilangan & "TUJUH BELAS "
Exit For
Case 18
StrBilangan = StrBilangan & "DELAPAN BELAS "
Exit For
Case 19
StrBilangan = StrBilangan & "SEMBILAN BELAS "
Exit For
End Select
Else
If Ulangan < 3 And UlanganX > 3 And RepX = 1 Then
StrBilangan = StrBilangan & "SE" '"SERIBU "
Else
StrBilangan = StrBilangan & "SATU "
End If
End If
Case 2
StrBilangan = StrBilangan & "DUA "
Case 3
StrBilangan = StrBilangan & "TIGA "
Case 4
StrBilangan = StrBilangan & "EMPAT "
Case 5
StrBilangan = StrBilangan & "LIMA "
Case 6
StrBilangan = StrBilangan & "ENAM "
Case 7
StrBilangan = StrBilangan & "TUJUH "
Case 8
StrBilangan = StrBilangan & "DELAPAN "
Case 9
StrBilangan = StrBilangan & "SEMBILAN "
End Select
If Bilangan <> 0 Then
BelakangNum = Len(StrRuasX) - RepX
If BelakangNum = 2 Then
If Bilangan <> 1 Then
StrBilangan = StrBilangan & "RATUS "
End If
ElseIf BelakangNum = 1 Then
StrBilangan = StrBilangan & "PULUH "
End If
End If
Next 'nomor selandjutnja dalam satu ruas
End If
If StrRuas <> "000" Then
Int10 = UlanganX - Rep
txt = txt & Str(Int10)
Select Case Int10
'Case Is = 2
'If Bilangan <> 1 Then

'End If
Case Is <= 5
If Int10 = 5 Then
StrBilangan = StrBilangan & "RIBU "
block2 = 1
End If
If Int10 = 2 And Not block2 = 1 Then
StrBilangan = StrBilangan & "RIBU "
End If
Case 7 To 9
StrBilangan = StrBilangan & "JUTA "
Case 10 To 12
StrBilangan = StrBilangan & "MILYAR "
Case 13 To 15
StrBilangan = StrBilangan & "TRILIUN "
Case 16 To 18
StrBilangan = StrBilangan & "BILYUN "
End Select
End If
Next 'ruas selandjutnja

kl bisa code ini jgn di otak-atik.. bisakah atau saya tantang neh.. (sry kl nyebelin)
buatlah program yg bisa baca angka dibawah 2000an..
oh ya.. sebelumnya terima kasih atas bantuan 2 orang (sy lupa nama dan id nya) untuk memberikan script yg sebenarnya ada di forum ini tapi wa lupa yg mana...
gomen2
second_life
17-02-2007, 05:03 PM
g paling males priksa coding ;D
g bikin baru nih. tp cuman sampe 12 digit doang


Option Explicit
'Dim vi
Private Function Konv(ByVal nilai As Currency) As String
Dim Grade As Variant
Dim StrTerbilang, strpart As String
Dim dummygrade As Byte

Grade = Array("Milyar", "Juta", "Ribu", "")
StrTerbilang = ""
If Len(CStr(nilai)) > 12 Then
StrTerbilang = "Melebihi Batas!!"
Else: strpart = Format(nilai, String(12, "0"))
For dummygrade = 1 To 4
If Val(Mid(strpart, (dummygrade - 1) * 3 + 1, 3)) > 0 Then
StrTerbilang = StrTerbilang & _
konv2(Mid(strpart, (dummygrade - 1) * 3 + 1, 3), dummygrade)
StrTerbilang = StrTerbilang & Grade(dummygrade - 1)
End If
Next dummygrade
End If

Konv = StrTerbilang

End Function

Private Function konv2(ByVal strpart As String, ByVal dummygrade As Byte) As String
Dim angka1, angka2 As Variant
Dim A As Integer
Dim StrHasil As String
Dim Temp As Byte
angka1 = Array(" Satu", " Dua", " Tiga", " Empat", " Lima", " Enam", " Tujuh", " Delapan", " Sembilan")
angka2 = Array("Ratus", "Puluh", "")

For A = 1 To 3
Temp = Val(Mid(strpart, A, 1))
If Temp = 1 Then
If A = 1 Then
StrHasil = "Seratus"
ElseIf A = 2 Then
A = A + 1
Temp = Val(Mid(strpart, A, 1))
If Temp = 0 Then
StrHasil = StrHasil & " Sepuluh"
ElseIf Temp = 1 Then
StrHasil = StrHasil & " Sebelas"
Else
StrHasil = StrHasil & angka1(Temp - 1) & "Belas"
End If
ElseIf Val(strpart) = 1 And dummygrade = 3 Then
StrHasil = StrHasil & "Se"
Else
StrHasil = StrHasil & " Satu"
End If
ElseIf Temp <> 0 Then
StrHasil = StrHasil + angka1(Temp - 1) + angka2(A - 1)
End If
Next A

konv2 = StrHasil



End Function

Private Sub Command1_Click()
Text2.Text = Konv(Text1.Text)
End Sub



semoga membantu :D
second_life
17-02-2007, 05:09 PM
sudah d coba untuk angka2 dbawah 2000. tp ga semua.
gempor aja g ;D
klo masih ada salah tlg kasih tau.

nb. klo soal urutan tulisan yg besar kecil ato nyambung/ga nyambung mah g ga peduli. pinter2ny yg ngoding ajah ;D
ruboW
19-02-2007, 09:23 AM
ma kasih
sebenarnya sih yg request rese aja.. mau ngerjain gw

padahal angka dibawah 2000 bisa dikatakan tidak ada lho!! nah.. tujuan dia apa ya??
second_life
19-02-2007, 12:30 PM
wakakak, sama2 :)
tanya ajah ma dia :D
Denny Lim
20-02-2007, 02:33 PM
O ituw yach ... gue pernah buat juga ... dah lama banget sech ...
tips gue ... klo bisa jgn pake array ... soalnya ...

Pake Array untuk Store Puluhan ... Angka
Pluz : Lebih Cepat
Minus: Makan Memory

Pake Property aja ... atau function returnnya string
ruboW
20-02-2007, 04:11 PM
>>tanya ajah ma dia
orgnya rese.. sekarang mau request virus!! ada yg mau bikin??

>>Pake Property aja ... atau function returnnya string
ini buat proyek kl pake suara org aja deh.. yg diatas lebih cocok sih..

secondlife: oh iya.. sebenarnya sih maunya tlg buatin tp ngak enak donk kl ngak nunjukin kl wa dah berusaha.. jadilah ada ketikan script yg pjg kayak kereta
second_life
21-02-2007, 08:59 AM
bikin virus mah gampang!!!
buka word trus

ketik VIRUS
jadi d ::hihi::

maap2, bcanda

wekekeke, minta d bikinin toh :D