Saturday, July 19, 2008
Enkrip-Dekrip di VB6
Private Function Encrypt(ByVal astring)
Dim x, i, tmp
For i = 1 To Len(astring)
x = Mid(astring, i, 1)
tmp = tmp & Chr(Asc(x) + 1)
Next
tmp = StrReverse(tmp)
Encrypt = tmp
End Function
Private Function Decrypt(ByVal encryptedstring)
Dim x, i, tmp
encryptedstring = StrReverse(encryptedstring)
For i = 1 To Len(encryptedstring)
x = Mid(encryptedstring, i, 1)
tmp = tmp & Chr(Asc(x) - 1)
Next
Decrypt = tmp
End Function
Private Sub Command1_Click()
Text2.Text = Encrypt(Text1.Text)
End Sub
Private Sub Command2_Click()
Text3.Text = Decrypt(Text2.Text)
End Sub
Private Sub Command3_Click()
End
End Sub
Private Sub Command4_Click()
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
End Sub
Private Sub Form_Load()
Text1.Text = ""
End Sub
Unload MDI
Private Sub MDIForm_Unload(Cancel As Integer)Baca selengkapnya....
Dim Jawab As Integer
Jawab = MsgBox("Anda yakin akan keluar dari program ini ?", _
vbQuestion + vbYesNo, "Konfirmasi Keluar")
If Jawab = vbNo Then Cancel = -1
End Sub
Membuat Folder
Dim fso As New FileSystemObject
Private Sub Command1_Click()
Dim Pathnya As String
Pathnya = App.Path
fso.CreateFolder Pathnya & "Kau_selalu_ygterbaik_"
End Sub
Menghapus Layar
********************
FUNCTION HapusLayar
********************
* Menghapus Layar dengan pola tertentu
PARAMETERS pola, lama
PRIVATE maxrow, maxcol, midpoint, xx, yy, mrow, buffer
IF PCOUNT() = 0
pola := 1
lama := 100
ELSEIF PCOUNT() = 1
lama := 100
ENDIF
maxrow := 24
maxcol := 79
midpoint := int((maxcol + 1) / 2)
DO CASE
CASE pola = 1 && hapus ke bawah
FOR xx := 0 to maxrow
SCROLL(xx, 0, xx, maxcol, 0)
FOR yy := 1 TO lama
NEXT
NEXT
CASE pola = 2 && Hapus ke atas
FOR xx := maxrow to 0 step -1
SCROLL(xx, 0, xx, maxcol, 0)
FOR yy := 1 TO lama
NEXT
NEXT
CASE pola = 3 && Hapus ke kanan
FOR xx := 0 to maxcol
SCROLL(0, xx, maxrow, xx, 0)
FOR yy := 1 TO lama
NEXT
NEXT
CASE pola = 4 && Hapus ke kiri
FOR xx := maxcol to 0 step -1
SCROLL(0, xx, maxrow, xx, 0)
FOR yy := 1 TO lama
NEXT
NEXT
CASE pola = 5 && Tirai terbuka
FOR xx := midpoint to maxcol
SCROLL(00, maxcol-xx, maxrow, maxcol-xx, 0)
SCROLL(0, xx, maxrow, xx, 0)
FOR yy := 1 TO lama
NEXT
NEXT
CASE pola = 6 && Tirai tertutup
FOR xx := maxcol to midpoint step -1
SCROLL(00, maxcol-xx, maxrow, maxcol-xx, 0)
SCROLL(0, xx, maxrow, xx, 0)
FOR yy := 1 TO lama
NEXT
NEXT
CASE pola = 7 && Lensa tertutup
mrow := 0
FOR xx := 0 to 33 step 3
scroll(mrow, xx, mrow, maxcol - xx, 0)
scroll(maxrow - mrow, xx, maxrow - mrow, maxcol - xx, 0)
scroll(mrow, xx, maxrow - mrow, xx + 3, 0)
SCROLL(mrow, 76 - xx, maxrow - mrow, maxcol - xx, 0)
FOR yy := 1 TO lama
NEXT
mrow := mrow + 1
NEXT
scroll(mrow, 37, mrow, 42, 0)
CASE pola = 8 && terbelah diagonal
FOR xx := 0 to maxcol
scroll(int(xx/3.2), xx, maxrow, xx, 0)
scroll(0, maxcol - xx, maxrow - int(xx/3.2), maxcol - xx, 0)
FOR yy := 1 to lama
NEXT
NEXT
otherwise && terbelah dua, kiri dan kanan
FOR xx := 0 to maxrow
buffer := savescreen(xx, 0, maxrow - 1, MIDPOINT - 1)
scroll(xx, 0, xx, MIDPOINT - 1, 0)
if xx <>
restscreen(xx+1, 0, maxrow, MIDPOINT - 1, buffer)
endif
buffer := savescreen(1, MIDPOINT, maxrow-xx, maxcol)
scroll(maxrow-xx, MIDPOINT, maxrow-xx, maxcol, 0)
if xx <>
restscreen(0, MIDPOINT, maxrow - 1 - xx, maxcol, buffer)
endif
FOR yy := 1 to lama
NEXT
NEXT
ENDCASE
RETURN .T.
Prosedur Gerak
***********************
PROCEDURE GERAK
***********************
* Procedure ini untuk menggerakkan Kotak supaya Kotak yang mungkin akan
* mengganggu penglihatan pemakai Komputer, dapat digeser
PRIVATE BRii, KLii, WAR_GER, LAY_GER, TEBAL, LEBAR
BRii:= brs + jml_brs + jml_pil + 4
KLii:= kol + 49
WAR_GER:= warna
LAY_GER:= mpopmenu
GERAKAN:= SAVESCREEN(BRi, KLi, BRii, KLii)
SET KEY 3 TO
SET KEY 18 TO
SET KEY 1 TO
SET KEY 6 TO
SET KEY 5 TO
SET KEY 24 TO
SET KEY 4 TO
SET KEY 19 TO
DO WHILE .T.
GER:= INKEY(0)
DO CASE
CASE GER = 8 && <- (BACK SPACE)
KEYBOARD CHR(27)
EXIT
CASE GER = 5 .AND. BRi > 0 && PANAH ATAS
BRi:= BRi - 1
BRii:= BRii - 1
brs:= BRi
CASE GER = 24 .AND. BRii <>
BRi:= BRi + 1
BRii:= BRii + 1
brs:= BRi
CASE GER = 4 .AND. KLii <>
KLi:= KLi + 1
KLii:= KLii + 1
kol:= KLi
CASE GER = 19 .AND. KLi > 0 && PANAH KIRI
KLi:= KLi - 1
KLii:= KLii - 1
kol:= KLi
CASE GER = 18 .AND. BRi > 0 && PAGE UP
TEBAL:= BRii - BRi
BRi:= 0
BRii:= BRi + TEBAL
brs:= BRi
CASE GER = 3 .AND. BRii <>
TEBAL:= BRii - BRi
BRii:= 23
BRi:= BRii - TEBAL
brs:= BRi
CASE GER = 1 .AND. KLi > 0 && HOME
LEBAR:= KLii - KLi
KLi:= 0
KLii:= KLi + LEBAR
kol:= KLi
CASE GER = 6 .AND. KLii <>
LEBAR:= KLii - KLi
KLii:= 77
KLi:= KLii - LEBAR
kol:= KLi
ENDCASE
RESTORE SCREEN FROM LAY_GER
RESTSCREEN(BRi, KLi, BRii, KLii, GERAKAN)
SHADOW(BRi, KLi, BRii, KLii)
ENDDO
RETURN
Fungsi Nota dan Faktur
*--------------
Function B_Nota
*--------------
Parameter Seed01
Seed01:= Iif(PCount() <>
Use Nota.Dbs Alias Nota New
If Seed01= 1 .Or. ! File("Nota0.Ntx")
Pesan_Ntx("Nota0.Ntx")
Index On NoNota + KodeLang + DToC(TgNota) To Nota0 Eval Indi_Ntx()
EndIf
Set Index To Nota0
Return .T.
*---------
*----------------
Function B_Faktur
*----------------
Parameter Seed01
Seed01:= Iif(PCount() <>
Use Faktur.Dbs Alias Faktur New
If Seed01= 1 .Or. ! File("Faktur0.Ntx")
Pesan_Ntx("Faktur0.Ntx")
Index On DToC(TgFaktur) + AngFak + HurFak To Faktur0 Eval Indi_Ntx()
EndIf
Set Index To Faktur0
Return .T.
*---------
Lihat nama komputer
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function GetWinComputerName() As String
Dim sBuffer As String
Dim lBufSize As Long
Dim lStatus As Long
lBufSize = 255
sBuffer = String$(lBufSize, " ")
lStatus = GetComputerName(sBuffer, lBufSize)
GetWinComputerName = ""
If lStatus <> 0 Then
GetWinComputerName = Left(sBuffer, lBufSize)
End If
End Function
--------------
Di coding form :
Label1.Caption = "Nama Komputer ini : " & GetWinComputerName
Enable-Disable di VB6
Private Sub Command1_Click()
Command1.Enabled = False
Command2.Enabled = True
End Sub
Private Sub Command2_Click()
Command2.Enabled = False
Command1.Enabled = True
End Sub
Private Sub Form_Load()
Command2.Enabled = False
End Sub
Terbilang dlm bhs Indonesia
<%
'---------------------------------------------------------------------------
' Menampilkan tanda terima angka uang dalam bentuk abjad
' Seperti tanda terima kwitansi
' Oleh : Armansyah
' Kamis, 14 Juli 2005 23:28 Wib
'---------------------------------------------------------------------------
Public Function terbilang(x)
Dim triliun
Dim milyar
Dim juta
Dim ribu
Dim satu
Dim sen
Dim baca
'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 "
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, posisi)
Dim a100, a10 , a1
Dim baca
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, 2) + "ratus "
End If
End If
'Baca Bagian Puluh dan Satuan
If a10 = 1 Then
baca = baca + angka(a10 * 10 + a1, 2)
Else
If a10 > 0 Then
baca = baca + angka(a10, 2) + "puluh "
End If
If a1 > 0 Then
If posisi = 2 And a100 = 0 And a10 = 0 Then
baca = baca + angka(a1, 1)
Else
baca = baca + angka(a1, 2)
End If
End If
End If
ratus = baca
End Function
Function angka(x, posisi)
Select Case x
Case 0: angka = "Nol"
Case 1:
If 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
'------------- Untuk Test ----------------
'Dim Test, nomorik
' nomorik = 2002003
' Test = terbilang(nomorik)
'Response.Write formatnumber(nomorik,0)
'Response.Write "
"
'Response.Write test
'------------- Untuk Test ----------------
%>
Tanggal dalam Bhs Indonesia
<%Baca selengkapnya....
'--------------------------------------------------------------------
'File ini bernama : script_waktu_indonesia.asp
' Fungsi : untuk menampilkan nama bulan dalam bahasa Indonesia
'Tanggal Pembuatan : Senin, 30 Juni 2003 Pkl. 13:29 Wib
' Modifikasi : Selasa, 07 Juni 2005 Pkl. 13:46 Wib
' Programmed By : Armansyah
'--------------------------------------------------------------------
Function TampilBulan(b)
Dim bulan
bulan = array("Januari","Pebruari", "Maret", "April", _
"Mei", "Juni", "Juli", "Agustus", "September", _
"Oktober", "November", "Desember")
TampilBulan = bulan(b)
end function
' Function ini berguna untuk menampilkan
' nama hari dalam bahasa Indonesia
function TampilHari(c)
Dim hari
hari = array("Minggu", "Senin","Selasa","Rabu","Kamis",_
"Jumat","Sabtu")
TampilHari = hari(c)
end function
function FormatTanggal(tgl)
Dim s
s = TampilHari(DatePart("w",tgl)-1)
s = s & " " & DatePart("d", tgl)
s = s & " " & TampilBulan(DatePart("m", tgl)-1)
s = s & " " & DatePart("yyyy", tgl)
FormatTanggal = s
end function
%>
Buat File Log di ASP
<%
Dim fso, MyFile
Set fso = CreateObject("Scripting.FileSystemObject")
Dim CekIp
CekIP = Request.ServerVariables("REMOTE_ADDR")
If (fso.FileExists(Server.MapPath("LogHapus.log"))) Then
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Filenyo = Server.MapPath("LogHapus.log")
Set f = fso.OpenTextFile(Filenyo, ForAppending, True)
f.WriteLine
f.WriteLine
f.WriteLine("=================================================")
f.Write("Waktu Penghapusan : ")
f.WriteLine (FormatTanggal(now()) + " " + Bla + " Wib")
f.WriteLine("-------------------------------------------------")
f.Write("Penghapusan dari Ip address : ")
f.WriteLine(CekIP)
f.Write("Yang Melakukan Penghapusan : ")
f.WriteLine(Request.Cookies("Operator_Sales"))
f.WriteLine("=================================================")
f.Close
Else
Set MyFile = fso.CreateTextFile(Server.MapPath("LogHapus.log"))
MyFile.WriteLine
MyFile.WriteLine("-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-")
MyFile.WriteLine("Contoh buat Log")
MyFile.WriteLine("Copyright©2003, Armansyah")
MyFile.WriteLine("-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-")
MyFile.WriteLine
MyFile.WriteLine("~~~~~~~~~~~~~~~~~~~")
MyFile.Write("Waktu Penghapusan Awal : ")
MyFile.WriteLine (FormatTanggal(now()) + " " + Bla + " Wib")
MyFile.Write("Penghapusan dari Ip address : ")
MyFile.WriteLine(CekIP)
MyFile.Write("Yang Melakukan Penghapusan : ")
MyFile.WriteLine(Request.Cookies("Operator_Sales"))
MyFile.WriteLine("~~~~~~~~~~~~~~~~~~~")
MyFile.Close
End If
%>
Buka Database di ASP
<%
'-----------------------------------------------
'----
'---- Buka Database di ASP
'----
'---- CopyRight(c)2003, Armansyah
'----
'-----------------------------------------------
Dim Koneksi
Dim RsBukaDb
Dim SQLBukaDb
Dim DaftarUser
Set Koneksi = Server.CreateObject("ADODB.Connection")
Koneksi.Open "DRIVER={Microsoft Access Driver (*.mdb)};uid=;pwd=hebat;DBQ=" & Server.MapPath("karyawan.mdb")
Set RsBukaDb = Server.CreateObject("ADODB.Recordset")
SQLBukaDb = "Select * from karya Order By namowong Asc"
RsBukaDb.Open SQLBukaDb, Koneksi, adOpenStatic
%>
Mengecek keberadaan file dan folder
'Fungsi mengecek keberadaan suatu file dan folder
Function FileExist(ByRef sFname) As Boolean
If Len(Dir(sFname, 16)) Then FileExist = True Else FileExist = False
End Function
Cek Keberadaan Folder di VB6
Dim CekFolderFile As String
CekFolderFile = App.path
If Right$(CekFolderFile, 1) <> "\" Then CekFolderFile = CekFolderFile & "\Database\"
CekFolderFile = CekFolderFile & "DB_Login.mdb"
If Not FileExist(CekFolderFile) Then
MsgBox "Maaf, file Database Login tidak ada ... gagal loading, hubungi Administrator ! ", vbCritical, _
"Terjadi Kesalahan : Aplikasi tidak bisa dilanjutkan "
End
Else
End If
Membuka Database di VB6
Public db As New ADODB.ConnectionBaca selengkapnya....
Public rs As New ADODB.Recordset
Public Sub data_connect()
Dim path As String
path = App.path & "\database\karyawan.mdb"
db.CursorLocation = adUseClient
db.Open "Provider=microsoft.jet.oledb.4.0;persist security info=false;data source=" & path & ";"
End Sub
Contoh Integrasi VB6 dan ASP
<%
'Contoh integrasi ActiveX-VB6 dengan Classic ASP
Dim komponenvbku
set komponenvbku = Server.CreateObject("roundmin2.VB6forASP")
'Pastikan komponen roundmin2.dll sudah diregister kesystem
'roundmin2.dll adalah component fungsi round -2 yg dibuat dengan VB6 untuk ASP
if MBruto <>
MPPH = 0
else
if MBruto <= MSubsII Then
MPPH = komponenvbku.FungsiRound(MPPH-MPPHSub*1, -2)
else
MPPH = komponenvbku.FungsiRound(MPPH*1, -2)
end if
end if
%>
Contoh Active X VB6 u/. ASP
'Pembuatan Fungsi Round -2
'Sebagai Active X
'Dengan Visual Basic 6
'Untuk di-integrasikan dengan Classic ASP
'Copyright 2006, Armansyah
Public Function FungsiRound(angkanya As Double, Optional letakdesimalnya As Integer) As Double
Membuat fungsi Round -2 seperti di excel & Clipper
'Sintaksis : x = FungsiRound(test, -2)
Dim nilainya As Double
nilainya = 10 ^ letakdesimalnya
FungsiRound = Int(CDbl(angkanya * nilainya + 0.5)) / nilainya
End Function
Fungsi Pencarian String
Clear
Private Cari1, Kata1, Kata2, Nama1, Nama2:= {}
Store Space(20) To Cari1, Nama1
@3, 15 Say 'Mencari kata dlm "File Teks"'
@4, 15 Say '-------------' + Repl("-", 20)
@5, 15 Say "Cari kata : " Get Cari1
@6, 15 Say "Nama file : " Get Nama1 Pict "@!"
@7, 15 Say '-------------' + Repl("-", 20)
Read
Cari1:= AllTrim(Cari1)
Nama1:= AllTrim(Nama1)
If Empty(Cari1) .Or. Empty(Nama1) .Or. LastKey()= 27
Clear
Quit
EndIf
Kata1:= Directory(Nama1, "D")
AEval(Kata1, {|Kata2| AAdd(Nama2, Kata2[1])})
Clear
Pjg1:= Len(Nama2)
? "Banyaknya file : " + TransForm(Pjg1, "999,999")
? "-----------------------------"
For x:= 1 To Pjg1
Teks:= MemoRead(Nama2[x])
Ada1:= At(Cari1, Teks)
If Ada1 > 0
Pjg2 := Len(Nama2[x])
Pesan:= Nama2[x] + Space(14 - Pjg2)
Pesan:= Pesan + "->" + TransForm(Ada1, " 999,999,999 ")
Pesan:= Pesan + "->" + SubStr(Teks, Ada1 - 3, Len(Cari1) + 6)
? Pesan
MemoWrit(Pesan, "Cari.Txt")
EndIf
Next
Quit
Prosedur Terimakasih
********************************
* PROCEDURE UCAPAN TERIMA KASIH
********************************
PROCEDURE thanks
KELUAR:= POPMENU(06, 16, "Keluar ke Dos Prompt ?", ;
" Setuju ", " Batal ")
IF KELUAR = 2
SET KEY 19 TO P_KIRI
SET KEY 4 TO P_KANAN
set key 301 to thanks
return
EndIf
SET COLOR TO W/N
tone(261.7 * 9,4)
tone(196.0 * 9,2)
tone(196.0 * 9,2)
tone(220.0 * 9,2)
tone(196.1 * 9,2)
tone(0,1)
tone(246.9 * 9,2)
tone(261.1 * 9,4)
HapusLayar(MOD(VAL(SUBS(TIME(),1,2)+SUBS(TIME(),4,2)+SUBS(TIME(),7,2)),10)+1;
,50)
RELEASE ALL
public ucapan
UCAPAN1:= "Terima Kasih, Anda telah memanfaatkan Software ini"
UCAPAN2:= " Salam Saya : Armansyah "
box3d(02,07,21,68,1)
shadow(02,07,21,68)
A = " ÛÛÛÛ ÛÛÛÛ "
B = " ÛÛ ÛÛ "
C = " ÛÛ ÛÛ "
D = " ÛÛ ÛÛ "
E = " ÛÛ ÛÛ "
F = " ÛÛ ÛÛ "
G = " ÛÛ ÛÛ "
H = " ÛÛ ÛÛ "
I = " ÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛÛ "
J = " ÛÛ ÛÛ "
K = " ÛÛÛÛ ÛÛÛÛ "
L = " ÛÛÛÛ ÛÛÛÛ "
M = " ÛÛÛÛÛÛ ÛÛÛÛÛÛ "
SET COLOR TO GR/W
@4,10 SAY A
set colo to gr+/w
@5,10 SAY B
@6,10 SAY C
@7,10 SAY D
@8,10 SAY E
* SET COLOR TO gr/W
* set colo to 13/7
@9,10 SAY F
@10,10 SAY G
@11,10 SAY H
set colo to n+/w
@12,10 SAY I
set colo to gr+/w
@13,10 SAY J
set colo to r/w
@14,10 SAY K
@15,10 say l
set colo to n+/w
@16,10 say m
set colo to b/w
@ 18, 40 - LEN(UCAPAN1) / 2 SAY UCAPAN1
@ 19, 40 - len(ucapan2) / 2 say ucapan2
SET COLOR TO W/N
@ 23, 00
SET CURSOR ON
CLEAR ALL
QUIT
* EOF ( END OF FILE )
Contoh Buka Database
Baca selengkapnya....
<%
'-----------------------------------------------
'----
'---- Contoh Buka Database
'----
'---- CopyRight(c)2005, Armansyah
'----
'-----------------------------------------------
Dim Koneksi
Dim RsBukaDb
Dim SQLBukaDb
Dim DaftarUser
Set Koneksi = Server.CreateObject("ADODB.Connection")
Koneksi.Open "DRIVER={Microsoft Access Driver (*.mdb)};uid=;pwd=akunianini;DBQ=" & Server.MapPath("./../.../Databaseng/mdbq/pusatdata.mdb")
Set RsBukaDb = Server.CreateObject("ADODB.Recordset")
SQLBukaDb = "Select * from data_aku Order By namo Asc"
RsBukaDb.Open SQLBukaDb, Koneksi, adOpenStatic
%>
Contoh Skrip Logoff
<%Baca selengkapnya....
'Contoh proses logoff dan simpan kedatabase
Dim adoLog
Dim rsLog
Dim ConLog
Dim LacakKukis
LacakKukis = Request.Cookies("kapanmasoknyo")
Set adoLog = Server.CreateObject("ADODB.Connection")
adoLog.Open "DRIVER={Microsoft Access Driver (*.mdb)};uid=;pwd=manomatokau;DBQ=" & Server.MapPath("../.../Database/mdb/masuklahoiy.mdb")
Set rsLog = Server.CreateObject("ADODB.Recordset")
Dim SqlLog
SqlLog = "Select * from logoff Where waktuloginid Like '%" & LacakKukis & "%' "
rsLog.CursorType = 2
rsLog.LockType = 3
rsLog.Open SqlLog, adoLog
Dim Bla2
Dim DatNow2
DatNow2 = now()
Bla2 = Server.HTMLEncode(FormatDateTime(datNow2,3))
Dim TanggalSekarangId
TanggalSekarangId = Server.HTMLEncode(FormatTanggal(now()))
Dim TanggalIndonesia
TanggalIndonesia = TanggalSekarangId + " " + Bla2
rsLog.Fields("waktulogoffid") = TanggalIndonesia
rsLog.Fields("waktulogoff") = now()
rsLog.Update
rsLog.Close
Set rsLog = Nothing
Set adoLog = Nothing
'-------- akhir proses penyimpanan data login
If Session("iyodakye") = True then
Session.Contents.Remove("iyodakye")
Else
If Session("iyodakye") = False or IsNull(Session("iyodakye")) = True then
End If
End If
%>
Fungsi Enkripsi dan Dekripsi
<%
'---- Fungsi Enkripsi
'---- Melakukan Enkripsi terhadap semua karakter yang ada
'---- Melakukan Dekripsi saat pembacaan
'---- Armansyah, S.Kom > 31 Agustus 2005
Private Function Encrypt(ByVal string)
Dim x, i, tmp
For i = 1 To Len( string )
x = Mid( string, i, 1 )
tmp = tmp & Chr( Asc( x ) + 1 )
Next
tmp = StrReverse( tmp )
Encrypt = tmp
End Function
'---- Fungsi Dekripsi
Private Function Decrypt(ByVal encryptedstring)
Dim x, i, tmp
encryptedstring = StrReverse( encryptedstring )
For i = 1 To Len( encryptedstring )
x = Mid( encryptedstring, i, 1 )
tmp = tmp & Chr( Asc( x ) - 1 )
Next
Decrypt = tmp
End Function
%>
Membuat Restore Data
PRIVATE LAYAR,WARNA
SAVE SCREEN TO LAYAR
WARNA=SETCOLOR()
IF !FILE('BACKSIS.CAD')
POPERROR('Backup DataBase Mahasiswa Belum ada. Tidak ada yang perlu di Restore !')
RETURN
ENDIF
IF !FILE('BACKNIL.CAD')
POPERROR('Backup DataBase Nilai Mahasiswa Belum Ada. Tidak ada yang perlu direstore !')
RETURN
ENDIF
IF !FILE('BACKABS.CAD')
POPERROR('Backup DataBase Absen Mahasiswa Belum Ada. Tidak ada yang perlu direstore !')
RETURN
ENDIF
IF !FILE('BACKTPU.CAD')
POPERROR('Backup DataBase Tanda Peserta Belum Ada. Tidak ada yang perlu direstore !')
RETURN
ENDIF
PRIVATE REST1,REST2,REST3,REST4, REST5,REST6,REST7,REST8
PRIVATE PESAN,PESAN1,PESAN2,PESAN3,PILIH,TOMBOL,NILAIKU
REST1='MHSISWA.DBF'
REST2='DAFNILA.DBF'
REST3='ABSEN.DBF'
REST4='TPUMIBA.DBF'
REST5='MHSISWA.NTX'
REST6='DAFNILA.NTX'
REST7='ABSEN.NTX'
REST8='TPUMIBA.NTX'
atas = 01
bawah = 07
kiri = 15
kanan = 64
pesan1 = "Akan Merestore semua DataBase ? "
pesan3 = "Sembarang tombol : Terus, Escape : Batal"
pesan2 = REPLICATE(CHR(196),LEN(pesan3))
Box3D(atas, kiri, bawah, kanan)
Shadow(atas, kiri, bawah, kanan)
DO WHILE .T.
@ atas + 2, 40 - LEN(pesan1)/2 SAY pesan1
@ atas + 3, 40 - LEN(pesan2)/2 SAY pesan2
@ atas + 4, 40 - LEN(pesan3)/2 SAY pesan3
Tombol = INKEY(0)
IF Tombol = 27
Nilaiku = .F.
EXIT
ENDIF
BOX3D(09,05,15,74)
Shadow(09,05,15,74)
IF FILE('BACKSIS.CAD')
PESAN='SEDANG ME-RESTORE MHSISWA.DBF.....'
@12,45-LEN(PESAN)/2 SAY PESAN
COPY FILE BACKSIS.CAD TO &REST1
COPY FILE BNTXSIS.CAD TO &REST5
ENDIF
IF FILE('BACKNIL.CAD')
PESAN='SEDANG ME-RESTORE DAFNILAI.DBF....'
@12,45-LEN(PESAN)/2 SAY PESAN
COPY FILE BACKNIL.CAD TO &REST2
COPY FILE BNTXNIL.CAD TO &REST6
ENDIF
IF FILE('BACKABS.CAD')
PESAN='SEDANG ME-RESTORE ABSEN.DBF.......'
@12,45-LEN(PESAN)/2 SAY PESAN
COPY FILE BACKABS.CAD TO &REST3
COPY FILE BNTXABS.CAD TO &REST7
ENDIF
IF FILE('BACKTPU.CAD')
PESAN='Sedang ME-RESTORE TPUMIBA.DBF.....'
@12,45-LEN(PESAN)/2 SAY PESAN
COPY FILE BACKTPU.CAD TO &REST4
COPY FILE BNTXTPU.CAD TO &REST8
ENDIF
PESAN='Proses Restore File DataBase Selesai.'
@12,45-LEN(PESAN)/2 SAY PESAN
Exit
Enddo
SETCOLOR(WARNA)
REST SCRE FROM LAYAR
RETURN
Program Kwitansi
* =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
* Program Untuk mencetak Kwitansi
* (c) Armansyah 1997
* =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Set Wrap On
Set Talk Off
Set Status Off
Set ScoreBoard Off
Set Century On
Set Deleted On
Set Message To 24 Center
Save Screen To Armansyahskom
Public xOleh, xUsaha, xAlamat1, xAlamat2, xAlamat3
If ! File("kwitansi.ini")
Do Konfig
EndIf
Clea
Set Color To Bg++
For x= 1 To 23
@x, 0 Say Repl("Û", 80)
Next
Set Color To Gr+/B
BlowUp(0,0,02,78)
@0, 0 Clear To 2, 78
@0, 0 To 2, 78
Shadow(0,0,02,78)
xUsaha = Alltrim(xUsaha)
@1, 40 - Len(xUsaha) / 2 Say xUsaha
Do Panggil
Do Blangko With 4, 5, 70
SetColor("B/W, W/B,,, R/W")
BlowUp(20,0,23,78)
@20, 0 Clear To 23, 78
@20, 0 To 23, 78
Shadow(20,0,23,78)
Do While .T.
@24, 00
Set Key 5 To Up
Set Key 24 To Under
@ 21, 05 Prompt " Tambah " ;
Message "Menambah data baru"
@ 21, Col() Prompt " Ralat " ;
Message "Meralat data yang dituju"
@ 21, Col() Prompt " Hapus " ;
Message "Menghapus data yang dipilih"
@ 21, Col() Prompt " Mundur " ;
Message "Mundur satu Record"
@ 21, Col() Prompt " Maju " ;
Message "Maju satu Record"
@ 21, Col() Prompt " Awal " ;
Message "Menuju Record paling awal"
@ 21, Col() Prompt " Akhir " ;
Message "Menuju Record paling akhir"
@ 22, 05 Prompt " Tujuan " ;
Message "Mencari Record tertentu"
@ 22, Col() Prompt " Tabel " ;
Message "Menampilkan Data dalam bentuk Tabel"
@ 22, Col() Prompt " Jumlah " ;
Message "Menghitung Jumlah Seluruh Record DataBase"
@ 22, Col() Prompt " Indeks " ;
Message "Mengindeks DataBase kembali"
@ 22, Col() Prompt " Cetak " ;
Message "Mencetak Kwitansi keatas Kertas"
@ 22, Col() Prompt " Konfig " ;
Message "Konfigurasi Program"
@ 22, Col() Prompt " Keluar " ;
Message "Keluar dari Menu Kwitansi"
Menu To Pilih
Set Key 5 To
Set Key 24 To
Do Case
Case Pilih= 1
Do Isi With "Entry"
Case Pilih= 2
If RecCount() # 0
Do Isi With "Edit"
Else
Nitip("Data masih kosong !")
EndIf
Case Pilih= 3
If RecCount() # 0
Do Show_it With "Hapus"
Else
Nitip("Data masih kosong !")
EndIf
Case Pilih= 4
If RecCount()= 0
Nitip("Data masih kosong !")
Loop
EndIf
If ! Bof()
Skip -1
Do Show_it With "Tampil"
Else
Nitip("Awal Record !")
EndIf
Case Pilih= 5
If RecCount()= 0
Nitip("Data masih kosong !")
Loop
EndIf
If ! Eof()
Skip 1
Do Show_it With "Tampil"
Else
Nitip("Akhir Record !")
EndIf
Case Pilih= 6
If RecCount() # 0
Go Top
Do Show_it With "Tampil"
Else
Nitip("Data masih kosong !")
EndIf
Case Pilih= 7
If RecCount() # 0
Go Bottom
Do Show_it With "Tampil"
Else
Nitip("Data masih kosong !")
EndIf
Case Pilih= 8
If RecCount() # 0
Rek= Tanya()
GoTo(Rek)
Do Show_it With "Tampil"
Else
Nitip("Data masih kosong !")
EndIf
Case Pilih= 9
If RecCount() # 0
Do Tabel
Else
Nitip("Data masih kosong !")
EndIf
Case Pilih= 10
If RecCount() # 0
Do Jumlah
Else
Nitip("Data masih kosong !")
EndIf
Case Pilih= 11
If RecCount() # 0
Do Indeks
Else
Nitip("Data masih kosong !")
EndIf
Case Pilih= 12
Lanjut= 0
If RecCount()= 0
Nitip("Data masih kosong !")
EndIf
Do While ! IsPrinter()
Lanjut= PopMenu(0, 0, "Printer belum siap !", ;
" Batal ", " Lanjut ")
If Lanjut= 0
Exit
ElseIf Lanjut= 1
Exit
EndIf
Enddo
If Lanjut # 1
Do Cetak
EndIf
Case Pilih= 13
Do Konfig
Case Pilih= 14 .or. Pilih = 0
Exit
Restore Screen From Armansyahskom
EndCase
EndDo
* =-=-=
* Under
* =-=-=
Procedure Under
SetColor("B/W, B/W,,, B/W")
KeyBoard Chr(4) + Chr(4) + Chr(4) + Chr(4) + Chr(4) + Chr(4) + Chr(4)
SetColor("B/W, W/B,,, B/W")
Return
* =-=-
* Up
* =-=-
Procedure Up
SetColor("B/W, B/W,,, B/W")
KeyBoard Chr(19) + Chr(19) + Chr(19) + Chr(19) + Chr(19) + Chr(19) + Chr(19)
SetColor("B/W, W/B,,, B/W")
Return
* =-=-=-=-=-=
* Konfigurasi
* =-=-=-=-=-=
Procedure Konfig
Private Ya, Klm, Warna, Layar, Usaha, Alamat1, Alamat2, Alamat3
If ! File("kwitansi.ini")
xUsaha= Space(30)
xAlamat1= Space(34)
xAlamat2= Space(34)
xAlamat3= Space(34)
EndIf
Warna= SetColor()
Set Color To Gr+/B
@1, 40 - Len(xUsaha) / 2 Say Space(Len(xUsaha))
Save Screen To Layar
SetColor("Gr/B+, B+/Gr,,, Gr/B+")
BlowUp(03,05,12,75)
@ 3, 5 Clear To 12, 75
@ 3, 5 To 12, 75
Shadow(03,05,12,75)
@ 5, 8 Say "Nama Perusahaan : "
@ 6, 8 Say "Alamat Perusahaan : "
Klm= Col()
@ 10, 8 Say "Anda Yakin Data Benar ? ( Y/T ) : "
Do While .T.
Ya= " "
xUsaha= xUsaha + Space(30 - Len(xUsaha))
SetColor("Gr+/B, N/Bg,,, Gr+/B")
@ 5, Klm Get xUsaha
@ 6, Klm Get xAlamat1
@ 7, Klm Get xAlamat2
@ 8, Klm Get xAlamat3
@ 10, Klm + 13 Get Ya
Set Cursor On
Read
Ya= Alltrim(Upper(Ya))
Set Cursor Off
If Ya= "" .Or. Ya= "Y"
Exit
EndIf
EndDo
Save All Like x* To kwitansi.ini
Restore From kwitansi.ini Additive
Restore Screen From Layar
xUsaha = Alltrim(xUsaha)
@1, 40 - Len(xUsaha) / 2 Say xUsaha
SetColor(Warna)
Return
* =-=-=
* Cetak
* =-=-=
Procedure Cetak
Private Rek, Warna, Layar, Nitip
Private x, Ptg, JlmBrs, Bl, Judul, Usaha, Alamat, Telepon, Bilangan
Warna= SetColor()
Save Screen To Layar
Judul= " Tanda Bukti Pembayaran "
Nitip= "Siapkan kertas, lalu tekan sembarang tombol. . ."
Set Color To Gr+/R
BlowUp(05,05,09,75)
@ 5, 5 Clear To 9, 75
@ 5, 5 To 9, 75
Shadow(05,05,09,75)
@ 7, 40 - Len(Nitip) / 2 Say Nitip
InKey(0)
If Kwitansi->Ubah= .T.
Nitip("Maaf tidak dicetak ganda !")
SetColor(Warna)
Restore Screen From Layar
Return
EndIf
Replace Kwitansi->Ubah with .T.
SetColor(Warna)
Restore Screen From Layar
xUsaha = Alltrim(xUsaha)
xAlamat1 = Alltrim(xAlamat1)
xAlamat2 = Alltrim(xAlamat2)
xAlamat3 = Alltrim(xAlamat3)
Declare Huruf[10]
Huruf[01]= Chr(27)+Chr(15) && Kecil
Huruf[02]= Chr(18) && Normal Kecil
Huruf[03]= Chr(27)+Chr(14) && Besar
Huruf[04]= Chr(20) && NBesar
Huruf[05]= Chr(27)+Chr(69) && Tebal
Huruf[06]= Chr(27)+Chr(70) && Normal Tebal
Huruf[07]= Chr(27)+Chr(52) && Miring
Huruf[08]= Chr(27)+Chr(53) && Normal Miring
Huruf[09]= Chr(27)+Chr(45)+Chr(1) && Garis Bawah
Huruf[10]= Chr(27)+Chr(45)+Chr(0) && Normal Garis Bawah
Set Device To Print
@ 01, 46 Say Huruf[1] + Huruf[5] + xUsaha
@ 02, 46 Say xAlamat1
@ 03, 46 Say xAlamat2
@ 04, 46 Say xAlamat3 + Huruf[7] + Huruf[2]
@ 05, 05 Say "Jam Cetak : "
@ 05, PCol() Say Time()
@ 06, 05 Say "Tgl Cetak : "
@ 06, PCol() Say Date()
@ 09, 26 Say Huruf[8] + Huruf[5] + Huruf[9] + Judul + ;
Huruf[10]
@ 12, 05 Say "Nomor Kwitansi : " + Nomor
@ 13, 05 Say "Sudah diterima dari : " + Dari
@ 14, 05 Say "Pada tanggal : " + TGL
@ 15, 05 Say "Sejumlah Rp. " + TransForm(Rupiah, ;
"999,999,999,999,-")
@ 16, 05 Say "Untuk pembayaran : " + Untuk
@ 17, 05 Say "Terbilang Banyaknya : " + Huruf[7]
Bilangan= Alltrim(Terbilang(Int(Rupiah / 1))) + ' Rupiah.'
JmlBrs= MlCount(Bilangan, 50)
For x= 1 To JmlBrs
Ptg= MemoLine(Bilangan, 50, x)
Ptg= If(Right(Ptg, 1)= " ", Ptg, Ptg + "-")
@ 16 + x, 30 Say Huruf[9] + Alltrim(Ptg) + Huruf[10]
Next
@ 22, 50 Say Huruf[8] + "Hormat Kami,"
@ 28, 45 Say "(" + Huruf[9] + Repl(" ", 20) + Huruf[10] + ")" + ;
Huruf[5]
Eject
Set Device To Screen
Return
* =-=-=
* Tabel
* =-=-=
Procedure Tabel
Private Warna, Layar
Declare Nam[6], Pik[6], Kep[6]
Tone(750, 1)
Tone(500, 1)
Warna= SetColor()
Save Screen To Layar
Nam[1]= "NOMOR"
Pik[1]= "@!"
Kep[1]= "Nomor"
Nam[2]= "TGL"
Pik[2]= "@!"
Kep[2]= "Tanggal"
Nam[3]= "DARI"
Pik[3]= "@!"
Kep[3]= "Diterima dari"
Nam[4]= "RUPIAH"
Pik[4]= "Rp 999,999,999,999,-"
Kep[4]= "Sebanyak"
Nam[5]= "UNTUK"
Pik[5]= "@!"
Kep[5]= "Untuk Pembayaran"
SetColor("N/Bg, Gr+/B,,, N/Bg")
BlowUp(04,02,19,78)
@ 4, 2 Clear To 19, 78
@ 4, 2 To 19, 78 Double
Shadow(04,02,19,78)
DbEdit(5, 3, 18, 77, Nam, "", Pik, Kep)
SetColor(Warna)
Restore Screen From Layar
Return
* =-=-=-
* Jumlah
* =-=-=-
Procedure Jumlah
Private Warna, Layar, Rek
Tone(750, 1)
Tone(500, 1)
Rek= LastRec()
Rek= Str(Rek, 3)
Warna= SetColor()
Save Screen To Layar
Set Color To Gr+/Bg
Nitip= "Jumlah Record yang ada : " + Rek
BlowUp(05,05,09,75)
@ 5, 5 Clear To 9, 75
@ 5, 5 To 9, 75
Shadow(05,05,09,75)
@ 7, 40 - Len(Nitip) / 2 Say Nitip
InKey(1.5)
SetColor(Warna)
Restore Screen From Layar
Return
* =-=
* Pop
* =-=
Function Pop
Parameters Brs, Klm, Nitip, Par1, Par2
Private Warna, Layar, Pilih
Tone(750, 1)
Tone(500, 1)
Warna= SetColor()
Save Screen To Layar
SetColor("N/W, W/N,,, N/W")
@ Brs, Klm Clear To Brs + 5, Klm + 40
@ Brs, Klm To Brs + 5, Klm + 40
@ Brs + 1, Klm + 2 Say Nitip
Nitip= Repl("Ä", 38)
@ Brs + 2, Klm + 1 Say Nitip
Do While .T.
@24, 00
@ Brs + 3, Klm + 2 Prompt " " + Par1 + " "
@ Brs + 4, Klm + 2 Prompt " " + Par2 + " "
Menu To Pilih
If LastKey()= 13 .Or. LastKey()= 27
Exit
EndIf
EndDo
SetColor(Warna)
Restore Screen From Layar
Return(Pilih)
Restore Screen From Ferawati
* =-=-=
* Nitip
* =-=-=
Function Nitip
Parameters Nitip
Private Warna, Layar
Set Cursor Off
Tone(750, 1)
Tone(500, 1)
Warna= SetColor()
Save Screen To Layar
Set Color To Gr+/R
BlowUp(05,05,09,75)
@ 5, 5 Clear To 9, 75
@ 5, 5 To 9, 75
@ 7, 40 - Len(Nitip) / 2 Say Nitip
Shadow(05,05,09,75)
InKey(1.5)
SetColor(Warna)
Restore Screen From Layar
Set Cursor On
Return .T.
* =-=-=-
* Indeks
* =-=-=-
Procedure Indeks
Private Warna, Layar, Nitip
Tone(750, 1)
Tone(500, 1)
Warna= SetColor()
Save Screen To Layar
Set Color To Gr+/Bg
Nitip= "Tunggu proses Reindex sedang berlangsung. . ."
BlowUp(05,05,09,75)
@ 5, 5 Clear To 9, 75
@ 5, 5 To 9, 75
Shadow(05,05,09,75)
@ 7, 40 - Len(Nitip) / 2 Say Nitip
Erase Kwitansi.Ids
Index On Nomor To Kwitansi.Ids
InKey(1.5)
SetColor(Warna)
Restore Screen From Layar
Return
* =-=-=
* Tanya
* =-=-=
Function Tanya
Private x, Ada, Temu, Ketik, Warna, Layar, NoRek
Warna= SetColor()
Save Screen To Layar
NoRek= RecNo()
Do While .T.
Ketik= Space(25)
Set Color To Gr+/Bg
BlowUp(05,12,09,68)
@ 5, 12 Clear To 9, 68
@ 5, 12 To 9, 68
Shadow(05,12,09,68)
SetColor("Gr+/Bg, N/W,,, Gr+/Bg")
@ 7, 18 Say "Yang dicari : " Get Ketik Pict "@!"
Set Cursor On
Read
Set Cursor Off
Ketik= Alltrim(Ketik)
If LastKey()= 27
GoTo(NoRek)
Exit
EndIf
Ada= .F.
Temu= 0
Set Exact Off
For x= 1 To RecCount()
GoTo(x)
Temu= At(Ketik, NOMOR)
If Temu # 0
Ada= .T.
Exit
EndIf
Temu= At(Ketik, DARI)
If Temu # 0
Ada= .T.
Exit
EndIf
Temu= At(Ketik, TGL)
If Temu # 0
Ada= .T.
Exit
EndIf
Temu= At(Ketik, UNTUK)
If Temu # 0
Ada= .T.
Exit
EndIf
Next
If Ada
Exit
Else
Nitip("Maaf, tidak ditemukan !")
Loop
EndIf
EndDo
Set Exact On
NoRek= RecNo()
SetColor(Warna)
Restore Screen From Layar
Return(NoRek)
* =-=-=-=-
* Isi Data
* =-=-=-=-
Procedure Isi
Parameter Perlu1
Private x, No, Sw, Byk, Brs, Klm, Ptg, Warna, JmlBrs, Bilangan
Sw= 1
Brs= 7
Klm= 30
Byk= FCount()
Warna= SetColor()
Declare MVar[Byk + 1], MTip[Byk], MLeb[Byk]
AFields("", MTip, MLeb)
Do While .T.
If Sw= 1
For x= 1 To Byk
If MTip[x]= "C"
MVar[x]= Space(MLeb[x])
Else
MVar[x]= 0
EndIf
Next
EndIf
No= If(RecCount()= 0 .Or. Perlu1= "Edit", RecNo(), RecNo() + 1)
MVar[1]= StrZero(No, MLeb[1])
MVar[3]= DToC(Date())
SetColor("Gr+/B, N/Bg,,, Gr+/B")
@Brs - 2, Klm + 20 Say No Pict "@E 99999"
@Brs + 1, Klm Get MVar[1] Pict "@!" Valid ! Empty(MVar[1])
Set Cursor On
Read
Set Cursor Off
If LastKey()= 27
Exit
EndIf
Seek MVar[1]
If Perlu1= "Entry"
If Found()
Nitip("Nomor tersebut sudah ada !")
Loop
EndIf
ElseIf Perlu1= "Edit"
If ! Found()
Nitip("Nomor tersebut tidak ada !")
Loop
EndIf
Do Show_it With "Tampil"
EndIf
@Brs + 2, Klm Get MVar[2] Pict "@!" Valid ! Empty(MVar[2])
@Brs + 3, Klm Get MVar[3] Pict "99/99/9999" Valid ! Empty(MVar[3])
@Brs + 4, Klm Get MVar[4] Pict "999,999,999,999,-" Valid ! Empty(MVar[4])
Set Cursor On
Read
Set Cursor Off
Set Color To B/Bg
@Brs + 8, 0 Clear To Brs + 12, 79
@Brs + 8, 0 To Brs + 12, 79
@Brs + 9, 5 Say "Terbilang : "
Set Color To Gr+/Bg
Bilangan= Alltrim(Terbilang(Int(MVar[4] / 1))) + ' Rupiah.'
JmlBrs= MlCount(Bilangan, 65)
For x= 1 To JmlBrs
Ptg= MemoLine(Bilangan, 65, x)
@x + (Brs + 9), 5 Say Alltrim(Ptg)
Next
Set Color To Gr+/B
@Brs + 5, Klm Get MVar[5] Pict "@!" Valid ! Empty(MVar[5])
Set Cursor On
Read
Set Cursor Off
If Perlu1= "Entry"
Benar= PopMenu(0, 0, "Data mau direkam (Y/T) ? ", "Ya ", "Tidak")
ElseIf Perlu1= "Edit"
Benar= Popmenu(0, 0, "Data mau diubah (Y/T) ? ", "Ya ", "Tidak")
EndIf
If Benar= 0
Exit
ElseIf Benar= 1
Sw= 1
ElseIf Benar= 2
Sw= 0
Loop
EndIf
If Perlu1= "Entry"
Append Blank
Do Rekam
No= No + 1
ElseIf Perlu1= "Edit"
If Kwitansi->Ubah= .T.
EndIf
Do Rekam
EndIf
Do Blangko With 4, 5, 70
EndDo
SetColor(Warna)
Return
* =-=-=-=-=
* Show_it
* =-=-=-=-=
Procedure Show_it
Parameters Perlu2
Private Brs, Klm, Warna
Brs= 7
Klm= 30
If RecNo() > LastRec()
Return
EndIf
Warna= SetColor()
Do While .T.
MKode= Space(Len(Nomor))
SetColor("Gr+/B, N/Bg,,, Gr+/B")
@Brs - 2, Klm + 20 Say RecNo() Pict "@E 99999"
Read
If Perlu2= "Hapus"
@Brs + 1, Klm Get MKode Pict "@!" Valid ! Empty(MKode)
Set Cursor On
Read
Set Cursor Off
If LastKey()= 27
Exit
EndIf
Seek MKode
If ! Found()
Nitip("Nomor tersebut tidak ditemukan !")
Loop
EndIf
EndIf
@Brs - 2, Klm + 20 Say RecNo() Pict "@E 99999"
@Brs + 1, Klm Say Nomor
@Brs + 2, Klm Say Dari
@Brs + 3, Klm Say TGL
@Brs + 4, Klm Say TransForm(Rupiah, "999,999,999,999,-")
@Brs + 5, Klm Say Untuk
Read
Set Color To B/Bg
@Brs + 8, 0 Clear To Brs + 12, 79
@Brs + 8, 0 To Brs + 12, 79
@Brs + 9, 5 Say "Terbilang : "
Set Color To Gr+/Bg
Bilangan= Alltrim(Terbilang(Int(Rupiah / 1))) + ' Rupiah.'
JmlBrs= MlCount(Bilangan, 65)
For x= 1 To JmlBrs
Ptg= MemoLine(Bilangan, 65, x)
@x + (Brs + 9), 5 Say Alltrim(Ptg)
Next
If Perlu2= "Hapus"
Benar= PopMenu(0, 0, "Data mau dihapus (Y/T) ? ", "Ya ", "Tidak")
*Benar= Pop(0, 0, "Data mau dihapus (Y/T) ? ", "Ya ", "Tidak")
If Benar= 0
Exit
ElseIf Benar= 1
If Kwitansi->Ubah= .T.
EndIf
Delete
Pack
ElseIf Benar= 2
Loop
EndIf
ElseIf Perlu2= "Tampil"
Exit
EndIf
EndDo
SetColor(Warna)
Return
* =-=-=-=-=-
* Rekam data
* =-=-=-=-=-
Procedure Rekam
Replace ;
Kwitansi->NOMOR With MVar[1], ;
Kwitansi->DARI With MVar[2], ;
Kwitansi->TGL With MVar[3], ;
Kwitansi->RUPIAH With MVar[4], ;
Kwitansi->UNTUK With MVar[5], ;
Kwitansi->UBAH With .F.
Return
* =-=-=-=-=-=-=
* Buat DataBase
* =-=-=-=-=-=-=
Procedure Panggil
Private x, Warna, Layar, Nitip
Warna= SetColor()
Save Screen To Layar
If ! File("Kwitansi.fxh")
Tone(750, 1)
Tone(500, 1)
Declare Nam[6], Tip[6], Leb[6]
Set Color To Gr+/B
Nitip= "Proses pembentukkan DataBase sedang berlangsung. . ."
BlowUp(05,05,09,75)
@ 5, 5 Clear To 9, 75
@ 5, 5 To 9, 75
Shadow(05,05,09,75)
@ 7, 40 - Len(Nitip) / 2 Say Nitip
Nam[1]= "NOMOR"
Tip[1]= "C"
Leb[1]= 5
Nam[2]= "DARI"
Tip[2]= "C"
Leb[2]= 30
Nam[3]= "TGL"
Tip[3]= "C"
Leb[3]= 10
Nam[4]= "RUPIAH"
Tip[4]= "N"
Leb[4]= 12
Nam[5]= "UNTUK"
Tip[5]= "C"
Leb[5]= 30
Nam[6]= "UBAH"
Tip[6]= "L"
Leb[6]= 1
Creat Temp
For x= 1 To Len(Nam)
Append Blank
Replace ;
Field_Name With Nam[x], ;
Field_Type With Tip[x], ;
Field_Len With Leb[x], ;
Field_Dec With 0
Next
Use
Creat Kwitansi.fxh From Temp
Erase Temp
Close DataBase
SetColor(Warna)
Restore Screen From Layar
EndIf
Use Kwitansi.fxh
If ! File("Kwitansi.Ids")
Tone(750, 1)
Tone(500, 1)
Set Color To Gr+/B
Nitip= "Proses pembentukkan File Index sedang berlangsung. . ."
BlowUp(05,05,09,75)
@ 5, 5 Clear To 9, 75
@ 5, 5 To 9, 75
Shadow(05,05,09,75)
@ 7, 40 - Len(Nitip) / 2 Say Nitip
Index On Nomor To Kwitansi.Ids
InKey(1.5)
SetColor(Warna)
Restore Screen From Layar
EndIf
Set Index To Kwitansi.Ids
Go Bottom
Return
Subscribe to:
Posts (Atom)
