Dim strConnection As String
Dim cnn As ADODB.Connection
' strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
' "Data Source=C:\Users\Brendan Reynolds\Documents\test.accdb;" & _
' "Jet OLEDB:Database Password=test"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
Set cnn = New ADODB.Connection
cnn.ConnectionString = strConnection
cnn.Properties("Jet OLEDB:Database Password") = "test"
cnn.Open
Debug.Print cnn.State = adStateOpen
cnn.Close
Alternatif lain :
Dim cnn As New ADODB.Connection
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Test Files\DatabasewPassword.accdb;Jet OLEDB:Database Password='currentpassword';Mode=Share Exclusive"
cnn.Execute "ALTER DATABASE PASSWORD newpassword currentpassword"
cnn.Close
Wednesday, September 17, 2008
ACCDB dengan Password
Friday, August 1, 2008
Koneksi data dengan Access 2007
Bingung membuat koneksi ke access 2007 ?
Silahkan baca petunjuk berikut :
MS Access 2007 OLE DB & OleDbConnection (.NET framework) connection strings
Open connection to Access database 2007:
"Provider=Microsoft.ACE.OLEDB.12.0; Data Source=c:\ yourdbpath \ DBName.accdb; User Id=admin; Password="
Open connection to password protected Access database 2007:
"Provider=Microsoft.ACE.OLEDB.12.0; Data Source=c:\ yourdbpath \ DBName.accdb; Jet OLEDB:Database Password=YourPassword"
Open connection to Access database 2007 located on a network share:
"Provider=Microsoft.ACE.OLEDB.12.0; Data Source=\\ServerName\ShareName\SharePath\ DBName.accdb"
Open connection to Access database 2007 located on a remote server:
"Provider=MS Remote; Remote Server=http://Server-IP; Remote Provider=Microsoft.ACE.OLEDB.12.0; Data Source=c:\ yourdbpath \ DBName.accdb"
MS Access ODBC connection strings
Standard Security:
"Driver= {MicrosoftAccessDriver(*.mdb)};DBQ=C:\yourdbpath\DBName.mdb;Uid=Your_Username;Pwd=YourPassword;"
Workgroup:
"Driver={Microsoft Access Driver (*.mdb)}; Dbq=C:\ yourdbpath \ DBName.mdb; SystemDB=C:\ yourdbpath \ DBName.mdw;"
Exclusive "Driver={Microsoft Access Driver (*.mdb)}; DBQ=C:\ yourdbpath \ DBName.mdb; Exclusive=1; Uid=YourUsername; Pwd=YourPassword;"
MS Access OLE DB & OleDbConnection (.NET framework) connection strings
Open connection to Access database:
"Provider=Microsoft.Jet.OLEDB.4.0; Data Source=c:\ yourdbpath \ DBName.mdb; User Id=admin; Password="
Open connection to Access database using Workgroup (System database):
"Provider=Microsoft.Jet.OLEDB.4.0; Data Source=c:\ yourdbpath \ DBName.mdb; Jet OLEDB:System Database=c:\App1\ DBName.mdw"
Open connection to password protected Access database:
"Provider=Microsoft.Jet.OLEDB.4.0; Data Source=c:\ yourdbpath \ DBName.mdb; Jet OLEDB:Database Password=YourPassword"
Open connection to Access database located on a network share:
"Provider=Microsoft.Jet.OLEDB.4.0; Data Source=\\ServerName\ShareName\SharePath\ DBName.mdb"
Open connection to Access database located on a remote server:
"Provider=MS Remote; Remote Server=http://Server-IP; Remote Provider=Microsoft.Jet.OLEDB.4.0; Data Source=c:\ yourdbpath \ DBName.mdb"
Download 2007 MS-Office System Driver
Microsoft menyiapkan engine untuk membaca data dari aplikasi office 2007 mereka yang terbaru. Salah satunya seperti Driver untuk Access 2007 di ODBC.
Alamat Download adalah :
http://www.microsoft.com/downloads/details.aspx?FamilyID=7554F536-8C28-4598-9B72-EF94E038C891&displaylang=en
Besar file : l/k 25 MB
Nama : AccessDatabaseEngine.exe
Berikut uraian dari Microsoft : This download will install a set of components that can be used by non-Microsoft Office applications to read data from 2007 Office system files such as Microsoft Office Access 2007 (mdb and accdb) files and Microsoft Office Excel 2007 (xls, xlsx, and xlsb) files. Connectivity to Microsoft Windows SharePoint Services and Text files is also supported.
ODBC and OLEDB drivers are installed for application developers to use in developing their applications with connectivity to Office file formats.
Classic ASP dan Access 2007
Setelah mencoba-coba sendiri mengupdate script untuk proses input di Classic ASP dengan menggunakan Database Microsoft Access 2007, maka terdapat beberapa hal yang mungkin perlu disharing disini.
Berikut contoh sintaksisnya, semoga bermanfaat.
<%
'Contoh Koneksi Classic ASP dengan Access 2007
'Oleh : Armansyah
Dim koneksi
Dim rekamdata
Dim databasenya
databasenya= "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
Server.MapPath("database/accdb/07/test.accdb")
Set koneksi = Server.CreateObject("ADODB.Connection")
koneksi.open databasenya
Set rekamdata = Server.CreateObject("ADODB.Recordset")
Dim Sqlnya
Sqlnya = "select * from bukutamu"
rekamdata.CursorLocation = 3
rekamdata.CursorType = 2
rekamdata.LockType = 3
rekamdata.Open Sqlnya, koneksi
rekamdata.AddNew
rekamdata.Fields("nama") = request.form("form_nama")
rekamdata.Fields("alamat") = request.form("form_alamat")
rekamdata.Fields("WaktuKmptr") = now()
rekamdata.Update
rekamdata.Close
Set rekamdata = Nothing
Set koneksi= Nothing
'--- Akhiri dengan senyum keikhlasan .... :-)
'--- By : Armansyah
%>
Monday, July 28, 2008
Contoh Membuka Enkripsi
* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
* Membuat Tampilan Awal Program
* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Do Lambang
A=" ÜÜÜ ÜÜÜ ÜÜ ÜÜ Û "
B=" ÜÛÛ Û Û Û Û Û Û Û Üß "
C=" ÛÛÜÜÜÜÜ Û Û Û Û Û Û ÛÜß "
D=" ÜÜ Û Û Û Û Û Û Û ßÜ "
E=" ÛÜÜÜÜÜÛ Û Û Û Û Û ßÜ "
* -=-=-=-=-=-=-=-=-=-=-
* Latar Belakang Box3D
* -=--=-=-=-=-=-=-=-=-=
Box3D(0,0,24,79)
* -=-=-=-=-=-=-=-=-=-=-=-
* Box3D untuk logo STMIK
* -=-=-=-=-=-=-=-=-=-=-=-
Box3D(02,04,22,50)
* -=-=-=-=-=-=-=-=-=-=-=-==-=-=-=-=-=-=-=-=-=--=
* Box3D untuk penampilan tulisan "Aplikasi PMB"
* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Box3D(03,52,20,75)
Set colo to rb/w
@13,10 Say A
@14,10 Say B
@15,10 Say C
@16,10 Say D
@17,10 Say E
* -=-=-=-=-=-=-=-=
* Buat judul menu
* -=-=-=-=-=-=-=-=
Set Colo to r+/w
@ 04,09 Say "Praktek Kerja Lapangan"
Set colo to b/w
@ 05,09 Say REPL(CHR(4),22)
set colo to gr++/w
@ 06,09 Say "Dibuat Oleh :"
Set colo to b/w
@ 07,09 Say HakCipta() // tampilkan nama Armansyah
set colo to rb/w
@ 08,09 Say "Mahasiswa STMIK BINA DARMA" // Tahun 1996
set colo to b+/w
@ 09,09 Say Nim()
set colo to n/w
@ 10,09 Say Phone()
set colo to b/w
@ 11,08 Say repl(chr(196),39)
set colo to g+/W
@ 19,8 Say "BINA DARMA PALEMBANG "
@ 20,8 Say "Jl. Jend. A. Yani 03 Telp.(0711)-515582"
set colo to r/w
@ 05,57 Say " Aplikasi PMB "
@ 06,57 Say "Tahun Akademik"
@ 07,57 Say " 1997/1998 "
set colo to n+/w
@ 08,56 Say repl(chr(219),16)
set colo to n/w
@ 10,56 Say " UNIVERSITAS "
@ 11,56 Say " I B A "
@ 12,56 Say " PALEMBANG "
@ 13,56 Say " Telp. 351364 "
@ 14,56 Say " Fax. 372625 "
Set color to r+/w
@ 16,56 Say "Tunggu sebentar"
set colo to r*/w
@ 18,56 Say "SEDANG PROSES..."
set colo to b/w
@ 21,53 Say "Program ini dilindungi"
@ 22,53 Say "Undang-Undang Hak Cipta"
* -=-=-=-=-=-=-=-=-=-=-=-=-=-
* Membuka Enkripsi Help.Hlp
* -=-=--=-=-=-=-=-=-=-=-=-=-=
If ! File('HELP.HLP')
PopError("File HELP.HLP Tidak Ada ... !?!")
Return
EndIf
HnQ= MemoRead('Help.Hlp')
HnQ= Deskrip2(HnQ)
MemoWrit('Help.Tmp', HnQ)
tone(100,2)
tone(300,4)
set colo to w/n
clea
Tuesday, July 22, 2008
Cari Temporary Folder
Private Declare Function GetTempPathA Lib "kernel32" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Function GetTempPath() As String
Dim S As String
Dim i As Integer
i = GetTempPathA(0, "")
S = Space(i)
Call GetTempPathA(i, S)
GetTempPath = AddBackslash(Left$(S, i - 1))
End Function
Cari Folder System
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Function WindowsDir() As String
Dim X As Long
Dim strPath As String
strPath = Space$(1024)
X = GetWindowsDirectory(strPath, Len(strPath))
strPath = Left$(strPath, X)
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
WindowsDir = strPath
End Function
Monday, July 21, 2008
Copy file di ASP
<%
Dim fso, MyFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.GetFile(Server.MapPath("data_arman.mdb"))
MyFile.Copy (Server.MapPath("backupofdata_armanmdb"))
%>
Fungsi Split di ASP
<% " "
Dim Test_Split, Data1, Test_Split2,Data2,Data3, Test_Split3, SisipTeks1,SisipTeks2
SisipTeks = " EDISI "
SisipTeks2 = date()
Data1 = "SKH KOMPAS ED. 16 - 30 NOVEMBER 2004"
Test_Split = split(Data1,"ED")
Data2 = "SKH. TRANSPARAN ED. NOVEMBER 2004"
Test_Split2 = split(Data2,"ED")
Data3 = "SKH SRIPO ED. NOVEMBER 2004"
Test_Split3 = split(Data3,"ED")
Response.Write Data1
Response.Write "
"
Response.Write "Sesudah di split hasilnya > "
Response.Write Test_Split(0)
Response.Write "
Response.Write Data2
Response.Write "
"
Response.Write "Sesudah di split hasilnya > "
Response.Write Test_Split2(0)
Response.Write "
Response.Write Data3
Response.Write "
"
Response.Write "Sesudah di split hasilnya > "
Response.Write Test_Split3(0)
Response.Write SisipTeks
Response.Write SisipTeks2
%>
Script Hapus di ASP
<%
Dim adoCon
Dim rsDeleteEntry
Dim strSQL
Dim Waktu1
Waktu1=Request.Form("Waktu")
Set adoCon = Server.CreateObject("ADODB.Connection")
adoCon.Open "DRIVER={Microsoft Access Driver (*.mdb)};uid=;pwd=password; DBQ=" & Server.MapPath("dunia_it_armansyah.mdb")
Set rsDeleteEntry = Server.CreateObject("ADODB.Recordset")
StrSql = "Select * from Tabel_tabelan Where Tabel_tabelan.waktunyo = '" & Waktu1 & "'"
rsDeleteEntry.LockType = 3
rsDeleteEntry.Open strSQL, adoCon
rsDeleteEntry.Delete
rsDeleteEntry.Close
Set rsDeleteEntry = Nothing
Set adoCon = Nothing
Response.Redirect "okebos.asp"
%>
Fungsi Tanggal di ASP
<%
Dim tg, mt, tn
tg = day(now)
mt = month(now)
tn = year(now)
Response.Write tg
Response.Write "
"
Response.Write mt
Response.Write "
"
Response.Write tn
%>
Contoh Fungsi Cdate
<%
Dim A, B, C
A = "18 April 2005"
B = Cdate(A)
C = b - 3
Response.Write B
Response.Write "
"
Response.Write C
%>
Script Hijriyah
var g, thistory, sDay, sMonth, sWeek, bora, month, day, year, ayear, cyear;
var aDay, aMonth, theYear, HDAY, HMONTH;
var myDay = new Array(7);
myDay[0] = "Sunday";
myDay[1] = "Monday";
myDay[2] = "Tuesday";
myDay[3] = "Wednesday";
myDay[4] = "Thursday";
myDay[5] = "Friday";
myDay[6] = "Saturday";
var myiDay = new Array(7);
myiDay[0] = "";
myiDay[1] = "";
myiDay[2] = "";
myiDay[3] = "";
myiDay[4] = "";
myiDay[5] = "Jummah";
myiDay[6] = "";
var sDate = new Date();
var sString;
var sYear;
g = 0;
thistory=1;
bora = "AD";
sString = sDate.toString();
sYear = parseInt(sString.substring(sString.length-4,sString.length));
/* Untuk merubah penanggalan Hijriah, tinggal ubah saja pada teks :
* sDay = sDate.getDate() - 1;
* Aslinya : sDay = sDate.getDate();
* Jika ada sesuatu yang lain, maka modifikasi saja bagian ini
*
*/
sDay = sDate.getDate()-1;
sMonth = sDate.getMonth() + 1;
sWeek = sDate.getDay();
function check()
{
day=sDay;
month=sMonth;
year=sYear;
var dday=g+day*1
ayear=year;
if (bora=="BC") {ayear=-year+1}
convert ()
}
function convert () {
var NOTE=''
var hijri=0;
var georgean=1;
if (georgean>0)
{
georgean=0;
var cdays=day*1;
cdays += (month>11) ?30 : 0;
cdays += (month>10) ?31 : 0;
cdays += (month>9) ? 30 : 0;
cdays += (month>8) ? 31 : 0;
cdays += (month>7) ? 31 : 0;
cdays += (month>6) ? 30 : 0;
cdays += (month>5) ? 31 : 0;
cdays += (month>4) ? 30 : 0;
cdays += (month>3) ? 31 : 0;
cdays += (month>2) ? 28 : 0;
cdays += (month>1) ? 31 : 0;
leap=0;cdays +=0;
if (ayear/4 == Math.floor(ayear/4)) {leap=1;}
if (ayear/100 == Math.floor(ayear/100)) {if (ayear/400 != Math.floor(ayear/400)) {leap=0;}}
if (leap==1) {if (month>2) {cdays +=1;}}
if (day>28+leap) {if (month==2) {kill ()}}
myear = ayear*1+cdays/(365+leap);
process1 ();
}
result();
}
function process1()
{
cyear=(myear-621.578082192)/0.97022298;
cyear += Math.floor(Math.abs(cyear)/3000)*30/10631
cday= cyear-Math.floor(cyear);
cyear -= cday;
if ((cday*10631/30)-Math.floor(cday*10631/30)<.5){cday= Math.floor(cday*10631/30) +1} else {cday= Math.floor(cday*10631/30) +2};
test2(cday)
mday=HDAY;cmonth=HMONTH;
if (cmonth==13){cmonth=1;cyear +=1};
var Precise=Pcision(JulianDay(ayear*1,month*1,day*1,19,30,0));
if (mday !=Precise) {if (mday==1 && Precise>28) {cmonth -=1;if (cmonth==0) {cmonth=12;cyear -=1}} else {if (mday>28 && Precise<3) cmonth="="13)" cmonth="1;cyear">
mday=Precise
if (cyear<1)>
}
function test2 (HdayN) {
var Monthf=29.53058796;
var Gyear=cyear*0.970224044+621.574981435;
var GyearDf= Gyear-Math.floor(Gyear);
Gyear -= GyearDf;
var l=0;
if (Gyear/4 == Math.floor(Gyear/4)) {l=1;} ;
if (Gyear/100 == Math.floor(Gyear/100)) {if (Gyear/400 != Math.floor(Gyear/400)) {l=0;}};
Gday =Math.floor((365+l)*GyearDf)+1;
Gyear +=Gday/(365+l);
var Hyear=(Gyear-621.574981435)/0.970224044;
var Hdayf=Hyear-Math.floor(Hyear),Hday=Hdayf*10631/30+1;
Hmonth=1;HdayF=1
while (HdayF
Hday +=1;HdayF +=1
if (Hday>= Monthf) {Hday=Hday-Monthf;Hmonth +=1};
}
HDAY=Math.floor(Hday)+1;HMONTH=Hmonth;
}
function Pcision(F)
{
var Status='ok';
var Dn=0;
var jDn=F;
if (Moon(jDn-1)<=0) {jDn -=1;Dn +=1}
while (Status=='ok')
{
var Fn=Moon(jDn);var Fn2=Moon(jDn-1);
if (((Fn/Math.abs(Fn))*(Fn2/Math.abs(Fn2)))==1)
{
Dn +=1;jDn -=1;
}
else
{
if (Math.abs(Fn*Fn2)<.2)
{
Status='End';
}
else
{
Dn +=1;jDn -=1;
}
}
}
return Dn;
}
function Moon(jd)
{
var T_ = (jd-EPOCH*1)/ 36525.0;
var mE=297.8502042
+ 445267.1115168*T_
- 0.0016300*(T_*T_)
+ (T_*T_*T_)/545868.0
- (T_*T_*T_*T_)/113065000
var mA=134.9634114
+ 477198.8676313*T_
+ 0.0089970*(T_*T_)
+ (T_*T_*T_)/69699.0
- (T_*T_*T_*T_)/863310000.0
var SmA=357.5291092
+ (35999.0502909*T_)
- (0.0001536 *T_*T_)
+ ((T_*T_*T_)/24490000)
var D = r(mE)*1;
var S = r(SmA)*1;
var M = r(mA)*1;
var phaseAngle=180-D-6.289*sin(M)+2.1*sin(S)-1.274*sin(r(2*D)-M)-0.658*sin(2*D);
phaseAngle +=-0.214*sin(2*M);
phaseAngle +=-0.110*sin(1*D)
/** k (46.1) **/
var iF=(1+cos(phaseAngle))/2*(phaseAngle/Math.abs(phaseAngle))
return iF
}
function rad(angle)
{return r(angle)*Math.PI/180}
function sin(angle)
{return Math.sin(rad(angle))}
function cos(angle)
{return Math.cos(rad(angle))}
function r(Input)
{if (Input >=0) {var Output=Input-Math.floor(Input/360)*360} else {var Output=Input-Math.ceil(Input/360)*360+360;}
return Output}
function JulianDay (gYear,gMonth,gDay,gHour,gMinutes,gSeconds)
{
var calendar='GREGORIAN'
EPOCH = 2451545.0;
if (gMonth <= 2) { --gYear;gMonth += 12;}
var A = Math.floor(gYear/100);
var B=0;
if (calendar == 'GREGORIAN') {B =Math.floor( 2 - A + (A / 4))} else {B = 0;}
var dayFraction = (gHour + gMinutes/60.0 + gSeconds/3600.0) / 24.0;
var dayAndTime = gDay + dayFraction;
jd_ =Math.floor(365.25 * (gYear + 4712))+Math.floor(30.6001 * (gMonth+1)) + dayAndTime + B -63.5;
return jd_*1;
}
function result()
{
if (thistory==1)
{
WeekDay ();
if (cyear<0) g="="0)" bora="BH" bora="BC" g="="0)" bora="AH" bora="AD">
yfinale=day+"/"+month+"/"+year+" ";
finale=mday+"/"+cmonth+"/"+Math.abs(cyear)+" ";
theYear = Math.abs(cyear);
thistory=0;
}
}
function WeekDay()
{
if (g==1) {var Dyear=cyear;var Dmonth=cmonth;var Dday=mday} else {var Dyear=year*1;var Dmonth=month*1;var Dday=day*1}
if (bora=="BC" || Dyear<0 dyear="-Math.abs(Dyear)+1}
var DayCount=0; var L=0
while (Dyear<10000){
if (Dyear/4==Math.floor(Dyear/4)) {L=1} else {L=0};
if (Dyear/100==Math.floor(Dyear/100)) { if (Dyear/400 !=Math.floor(Dyear/400)) {L=0}};
if (Dmonth==14) {DayCount +=365+L} else {
while (Dmonth<13)>
if (Dmonth==1 || Dmonth==3 || Dmonth==5 || Dmonth==7 || Dmonth==8 || Dmonth==10 || Dmonth==12) {var limit=31} else {var limit=30};
if (Dmonth==2) {limit=28+L}
if (Dday==40) {DayCount +=limit} else {while (Dday
Dday +=1;DayCount +=1;}};
Dmonth +=1;Dday=40}};
Dyear +=1; Dmonth=14};
var Dweek=DayCount%7;
if (Dweek==0) {DAY=" (Fri)"};
if (Dweek==6) {DAY=" (Sat)"};
if (Dweek==5) {DAY=" (Sun)"};
if (Dweek==4) {DAY=" (Mon)"};
if (Dweek==3) {DAY=" (Tue)"};
if (Dweek==2) {DAY=" (Wed)"};
if (Dweek==1) {DAY=" (Thu)"};
}
Grafik Pertumbuhan Order
<%
Const IMAGES_PATH = "images/"
Const WIDTH_YGRAF_IMAGE = 36
Const HEIGHT_YGRAF_IMAGE = 111
Const adStateOpen = &H00000001
Const adCmdTableDirect = &H0200
Dim oChart1, oChart2, oChart3, oChart4, oChart5, oChart6
Dim i, bSuccess
Dim m_oRs
Dim m_sConnectionString
Dim SQLTh2004, SQLTh2005, SQLTh2006
Dim m_arrTh2004, m_arrTh2005, m_arrTh2006
Dim m_arrData()
Dim m_arrLabels(), m_arrLabels2, m_arrLabels3
'Buat label bulan u/. diletakkan pada bagian bawah grafik
m_arrLabels2 = Array("Jan", "Peb", "Mar", "Apr", "Mei", "Jun", "Jul", "Agu", "Sep", "Okt", "Nop", "Des")
m_arrLabels3 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
'Buat koneksi kedalam database
m_sConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & Server.MapPath("Dtbs/Mdb09/tumbuhkembangOrder.mdb")
'Inisialisasi SQL
SQLTh2004 = "SELECT Th2004 FROM Table_Grafik_Pertumbuhan_Order"
SQLTh2005 = "SELECT Th2005 FROM Table_Grafik_Pertumbuhan_Order"
SQLTh2006 = "SELECT Th2006 FROM Table_Grafik_Pertumbuhan_Order"
'Buat RecordSet
Set m_oRs = Server.CreateObject("ADODB.Recordset")
' Ambil 3 field dari database dengan metode GetRows
' Penambahan field bisa dilakukan dengan merubah juga file : grafiknya.asp & cMultipleVerticalChart.asp
m_arrTh2004 = GetRows(SQLTh2004)
m_arrTh2005 = GetRows(SQLTh2005)
m_arrTh2006 = GetRows(SQLTh2006)
'Tutup koneksi kedatabase
m_oRs.Close
Set m_oRs = Nothing
'Panggil data
Call LoadFakeData
'Inisialisasi data untuk label
For i = 0 To UBound(m_arrData)
Redim Preserve m_arrLabels(i)
m_arrLabels(i) = i + 1
Next
'--- Mulai pembentukan grafik
Set oChart2 = New cMultipleVerticalChart
With oChart2
.ChartTitle = " Pertumbuhan Order 2004 - 2006"
.FooterText = " Catatan : Klik Update Grafik u/. menampilkan grafik terbaru"
.TableCaption = "Tabel Pertumbuhan Order"
.BarWidth = 12
.TotalsMode = 2
.DisplayYGrafImage = IMAGES_PATH & "y100.gif"
.AddBarImages = Array(IMAGES_PATH & "1x1_B0C4DD.gif", IMAGES_PATH & "1x1_FFC19F.gif", IMAGES_PATH & "1x1_CC9A7F.gif")
.AddLegendText = Array("2004", "2005", "2006")
If Not .AddData(m_arrTh2004) Then Response.Write "Pesan Kesalahan : " & .ErrorMessage
If Not .AddData(m_arrTh2005) Then Response.Write "Pesan Kesalahan : " & .ErrorMessage
If Not .AddData(m_arrTh2006) Then Response.Write "Pesan Kesalahan : " & .ErrorMessage
If Not .AddLabels(m_arrLabels2) Then Response.Write "Pesan Kesalahan : " & .ErrorMessage
If Not .CreateChart Then Response.Write "Pesan Kesalahan : " & .ErrorMessage
End With
Set oChart2 = Nothing
If Err Then Response.Write "
Kode Kesalahan = " & Err.Number & "
" & Err.Description
%>
Hitung jumlah record di ASP
'-------------- Hitung Jumlah data/Records yang di-isi hari ini saja
Dim adoCon_Hari_ini
Set adoCon_Hari_ini = Server.CreateObject("ADODB.Connection")
adoCon_Hari_ini.Open "DRIVER={Microsoft Access Driver (*.mdb)};uid=;pwd=dunia_it_armansyah;DBQ=" & Server.MapPath("ordermarket.mdb")
Dim rsOEFToday
Set rsOEFToday = Server.CreateObject("ADODB.Recordset")
'---------- Tentukan dulu variabel Tanggal, Bulan, Tahun ----
Dim Tanggal
Dim Bulan
Dim Tahun
Bulan = Month(date())
Tanggal = Day(date())
Tahun = "1999"
'Bisa diganti > Tahun = year(now)
Dim SQLOEFToday
SQLOEFTODAY = "Select * from Tabel1" & _
"Where ((day(WaktuPengisian)= " &Tanggal & ") And " & _
"(month(WaktuPengisian)= " &Bulan & ") And " & _
"(Year(WaktuPengisian)= " &Tahun & "))"
rsOEFToday.Open SQLOEFToday, adoCon_Hari_ini, adOpenStatic
Dim TotalOEFToday
TotalOEFToday = rsOEFToday.recordcount
Script Penyimpangan
'#######################################################################################
'------- Mulai Buat Perhitungan Penyimpangan Order ---
'--------------------------------------------------------------------
'---------- Diprogram oleh Armansyah, S.Kom; Sabtu, 09 Agustus 2003 ------
'--------------------------------------------------------------------
'#######################################################################################
'--- Cari Total Penyimpangan --
Dim SQL_TotalSemuaPenyimpangan
SQL_TotalSemuaPenyimpangan = "Select * from Tabel_Penyimpangan2"
RecordSet_OEF.Open SQL_TotalSemuaPenyimpangan, ActiveXDataObject_Connection, adOpenStatic
Dim Total_Semua_Penyimpangan
Total_Semua_Penyimpangan = RecordSet_OEF.recordcount
RecordSet_OEF.Close
'--- Cari Total Penyimpangan Bulan 1 --
Dim SQL_TotalSemuaPenyimpangan1
SQL_TotalSemuaPenyimpangan1 = "Select * from Tabel_Penyimpangan2 " & _
"Where ((month(JamAsli)= " & "1" & ") And " & _
"(Year(JamAsli)= " &Tahun & "))"
RecordSet_OEF.Open SQL_TotalSemuaPenyimpangan1, ActiveXDataObject_Connection, adOpenStatic
Buat Prosen dan Statistik
'--------------------------------------------------------------------
'---------- Fungsi Penghitungan Persentase dan Gambar Statistik -----
'---------- Diprogram oleh Armansyah, S.Kom; Rabu 18 Juni 2003 ------
'--------------------------------------------------------------------
Dim PanjangGambar1
Dim PanjangGambar2
Dim PanjangGambar3
Dim PanjangGambar4
Dim TotalPersen
Dim Total
Total = Total_Semua_OEFSELESAI + Total_Semua_OEFBLMSELESAI + Total_Semua_OEFBatal
Function HitungPersen(Angka)
TotalPersen = (angka/total) * 100
TotalPersen = Cint(TotalPersen)
HitungPersen = TotalPersen
End Function
Function Gambar1(x)
PanjangGambar1 = (x*2)
Gambar1 = PanjangGambar1
End Function
Function Gambar2(y)
PanjangGambar2 = (y*2)
Gambar2 = PanjangGambar2
End Function
Function Gambar3(z)
PanjangGambar3 = (z*2)
Gambar3 = PanjangGambar3
End Function
Function Gambar4(Arman_Mita)
PanjangGambar4 = (Arman_Mita*2)
Gambar4 = PanjangGambar4
End Function
Contoh Query Database di ASP
<%
'--------------------------------------------------------------------
'File ini bernama : persen_order_2_2006.asp
'Tanggal Pembuatan : Rabu, 18 Juni 2003 Pkl. 15:22
' Programmer : Armansyah, S.Kom
'armansyah.skom@gmail.com / dunia-it-armansyah.blogspot.com / armansyah.swaramuslim.com
'--------------------------------------------------------------------
'-------------- Hitung Jumlah Semua data/Records yang ada ditabel OEF
Dim ActiveXDataObject_Connection
set ActiveXDataObject_Connection = Server.CreateObject("ADODB.Connection")
ActiveXDataObject_Connection.Open "DRIVER={Microsoft Access Driver (*.mdb)};uid=;pwd=akulahthebestcoy;DBQ=" & Server.MapPath("databasenyo.mdb")
Dim RecordSet_OEF
Set RecordSet_OEF = Server.CreateObject("ADODB.Recordset")
Dim SQL_TotalSemuaOef
SQL_TotalSemuaOef = "Select * from Tabel1"
RecordSet_OEF.Open SQL_TotalSemuaOef, ActiveXDataObject_Connection, adOpenStatic
Dim Total_Semua_OEF
Total_Semua_OEF = RecordSet_OEF.recordcount
RecordSet_OEF.Close
'-------------- Hitung Jumlah data/Records yang sudah selesai proses
Dim SQL_Order_Selesai
SQL_Order_Selesai = "Select * from Tabel1 Where Tabel1.StatusOrder = 'SUDAH SELESAI'"
RecordSet_OEF.Open SQL_Order_Selesai, ActiveXDataObject_Connection, adOpenStatic
Dim Total_Semua_OEFSELESAI
Total_Semua_OEFSELESAI = RecordSet_OEF.recordcount
RecordSet_OEF.Close
'-------------- Hitung Jumlah data/Records yang belum selesai proses
Dim SQL_Order_Blm_Selesai
SQL_Order_Blm_Selesai = "Select * from Tabel1 Where Tabel1.StatusOrder <> 'SUDAH SELESAI'"
RecordSet_OEF.Open SQL_Order_Blm_Selesai, ActiveXDataObject_Connection, adOpenStatic
Dim Total_Semua_OEFBLMSELESAI
Total_Semua_OEFBLMSELESAI = RecordSet_OEF.recordcount
RecordSet_OEF.Close
'-------------- Hitung Jumlah data/Records yang batal oiy
Dim SQL_Order_yang_batal
SQL_Order_yang_batal = "Select * from Tabel1 Where Tabel1.StatusOrder = 'BATAL'"
RecordSet_OEF.Open SQL_Order_yang_batal, ActiveXDataObject_Connection, adOpenStatic
Dim Total_Semua_OEFBatal
Total_Semua_OEFBatal = RecordSet_OEF.recordcount
RecordSet_OEF.Close
%>
Buat file Log di VB6
Dim lpBuff As String * 25
Dim ret As Long ', username As String
Dim namauser As String
Dim GetCurrentUser As String
ret = GetUserName(lpBuff, 25)
GetCurrentUser = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)
computer_name = Space$(256)
length = Len(computer_name)
GetComputerName computer_name, length
computer_name = Left$(computer_name, length)
Dim fsoLog As New FileSystemObject
Dim oTS As TextStream
Dim PesanLog As Integer
Dim Teksnya, Teksnya2, Teksnya3 As String
Teksnya = GetCurrentUser
Teksnya2 = computer_name
Dim WaktuSekarang
Dim FormatWaktuSekarang
WaktuSekarang = Now()
FormatWaktuSekarang = FormatDateTime(WaktuSekarang, 3)
Teksnya3 = FormatTanggal(Now()) & " " & FormatWaktuSekarang
Dim CekFolderFileLog As String
Dim CekFileLog As String
CekFolderFileLog = App.Path
If Right$(CekFolderFileLog, 1) <> "\" Then CekFolderFileLog = CekFolderFileLog & "\Log"
If Not FileExist(CekFolderFileLog) Then
fsoLog.CreateFolder "Log"
End If
CekFolderFileLog = CekFolderFileLog & "\" & "PC-BLKM.Arman"
If Not FileExist(CekFolderFileLog) Then
Set oTS = fsoLog.OpenTextFile(CekFolderFileLog, ForWriting, True)
oTS.WriteLine "#######################################"
oTS.WriteLine "NAMA FILE : PC-BLKM.Arman "
oTS.WriteLine "Dibuat Otomatis saat PC-BLKM diakses "
oTS.WriteLine ""
oTS.WriteLine "Nama User merujuk pada login user pada Windows"
oTS.WriteLine "ID Komputer : Mengacu pada ID System "
oTS.WriteLine "Diprogram oleh : armansyah@gmail.com "
oTS.WriteLine ""
oTS.WriteLine "#######################################"
oTS.WriteLine ""
oTS.Write "Waktu Login : "
oTS.WriteLine Teksnya3
oTS.Write "Nama User yang login : "
oTS.Write Teksnya
oTS.WriteLine ""
oTS.Write "Id Komputer : "
oTS.Write Teksnya2
oTS.WriteLine ""
oTS.Write "Total PC-BLKM dijalankan : "
oTS.WriteLine Format$(RunTimes) & " Kali"
oTS.WriteLine "-------------------------------------------"
oTS.Close
Set oTS = Nothing
Else
Set oTS = fsoLog.OpenTextFile(CekFolderFileLog, ForAppending, True)
oTS.WriteLine ""
oTS.Write "Waktu Login : "
oTS.WriteLine Teksnya3
oTS.Write "Nama User yang login : "
oTS.Write Teksnya
oTS.WriteLine ""
oTS.Write "Id Komputer : "
oTS.Write Teksnya2
oTS.WriteLine ""
oTS.Write "Total PC-BLKM dijalankan : "
oTS.WriteLine Format$(RunTimes) & " Kali"
oTS.WriteLine "-------------------------------------------"
oTS.Close
Set oTS = Nothing
End If
Batasan Input Password
Private Sub Command1_Click()
Dim flag As Boolean
Dim xText
Dim myconn As ADODB.Connection
Dim myrs As ADODB.Recordset
Dim mydb_file As String
Dim mysqlnya As String
' Get the data.
mydb_file = App.path
If Right$(mydb_file, 1) <> "\" Then mydb_file = mydb_file & "\Database\"
mydb_file = mydb_file & "db_login.mdb"
' Open a connection.
Set myconn = New ADODB.Connection
myconn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & mydb_file & ";" & _
"Persist Security Info=False"
myconn.Open
mysqlnya = "SELECT * FROM Tabel_Armansyah"
Set myrs = myconn.Execute(mysqlnya, , adCmdText)
flag = False
If txtPassword.Text = "" Then
MsgBox "Password tidak boleh kosong !!", vbOKOnly + vbCritical, _
"Peringatan : Anda belum memasukkan password "
txtPassword.SetFocus
flag = True
End If
Dim EnPas As String
EnPas = Encrypt(txtPassword.Text)
If Combo1.ListIndex = 0 Then
If Combo1 = myrs![UserName] And EnPas = myrs![Password] Then
Unload Me
flag = True
gblnPriv = True
'MDIForm1.Show
frmprogressbar.Show
End If
Else
myrs.MoveNext
If Combo1 = myrs![UserName] And EnPas = myrs![Password] Then
Unload Me
flag = True
gblnPriv = False
frmprogressbar.Show
End If
myrs.MoveFirst
End If
If flag = False Then
hitungan = hitungan + 1
If hitungan = 4 Then
End
Else
xText = "Sisa kesempatan anda hanya " + Str(4 - hitungan) + " x lagi"
If hitungan = 3 Then
xText = "Sekali ini merupakan kesempatan anda yang terakhir !!"
End If
MsgBox " Password Salah ... Akses ditolak!!" & vbCrLf & _
xText, vbOKOnly + vbCritical, "Peringatan : Terjadi kesalahan"
txtPassword.Text = ""
End If
End If
End Sub
RTF di VB6
Memanggil file rtf dari VB6 :
Private Sub Form_Load()
RichTextBox1.LoadFile "Armansyah.rtf"
End Sub
Memeriksa Kapasitas file di VB6
Memeriksa ukuran/kapasitas sebuah file :
Dim lSize As Long
Dim lSizeOnDisk As Long
Dim sPath As String
sPath = App.Path & "\Arman.exe"
lSize = GetFileSize(sPath)
lSizeOnDisk = GetSizeOnDisk(sPath)
labelku.Caption = sPath
If lSize <> 2008 Then
Dim Jawablah As Integer
Jawablah = MsgBox("Arman.exe rusak/hilang/berubah ! program tidak bisa dilanjutkan ...", _
vbQuestion + vbYes, "Error!")
Unload Me
End If
Tambah-tambahan di VB6
Private Sub Command1_Click()
Dim a, b, c, d, e As Double
a = Val(Text1.Text)
b = Val(Text2.Text)
c = Val(Text2.Text)
d = (a + b + c) * 100
e = (a + b + c)
Text5.Text = e
Text4.Text = d
End Sub
Tebak-tebakan di Pascal
program tebak;
uses crt;
var
acak,jawaban:integer;
tombol:char;
begin
repeat
clrscr;
writeln('Permainan menebak Angka');
writeln('Saya akan membangkitkan bilangan acak');
writeln('Antara 1 sampai dengan 4');
repeat
acak:=random(5);
until acak<>0;
writeln('Sekarang cobalah untuk menebak');
write('Angka berapa? ');
readln(jawaban);
if acak=jawaban then writeln('Selamat ! Jawaban Anda benar')
else
writeln('Belum benar tuh jawabannya = ',acak);
writeln;
writeln('tekan t untuk mengakhiri');
writeln('Atau tombol lain untuk mengulangi');
Tombol:=readkey;
until(tombol='T') or (tombol='t')
end.
Cari Data di Pascal
Program CariData;
{Contoh Pencarian data pada Array}
Uses crt;
Type
String15=string[15];
Const
Jum_Elemen=10;
NamaKota:Array[1..Jum_Elemen] Of String15
=('PALEMBANG','MEDAN','PADANG','JAMBI','JAKARTA',
'SURABAYA','SEMARANG','YOGYAKARTA','BANDUNG',
'SOLO','KALIMANTAN','SULAWESI');
Merekam Data di Pascal
Program fteks2;
{Contoh merekam sejumlah karakter ke file teks}
Uses crt;
Var
Fhuruf:text;
Begin
clrscr;
Writeln('Merekam ke file teks');
Assign(fhuruf,'HURUF2.TXT');
Rewrite(fhuruf); {Menciptakan File}
Writeln(fhuruf,'A');
Writeln(fhuruf,'B');
Writeln(fhuruf,'C');
Close(fhuruf);
write('Selesai. Tekan enter.');
Readln;
End.
Cari Bulan dalam Pascal
Program Bulan;
Var
KodeBulan:Integer;
Begin
write('Kode Bulan [1 s/d 12]=');
readln(kodebulan);
case kodebulan of
1,3,5,7,8,10,12: writeln('Jumlah Hari = 31');
4,6,9,11: writeln('Jumlah Hari =30');
2: writeln('Jumlah hari =28 atau 29');
else
writeln('Salah Memasukkan Kode Bulan');
end;readln;
end.
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.
*---------
Subscribe to:
Posts (Atom)
