kode program
<%
'******************************
'Nama kelas:
'Nama: perpustakaan umum
'Tanggal: 28/10/2008
'Penulis: oleh xilou
'Situs Web: http://www.chinacms.org
'Deskripsi: Perpustakaan Umum
'Hak Cipta: Harap sebutkan sumber dan penulisnya saat mencetak ulang
'******************************
'Terakhir diubah: 20090108
'Jumlah modifikasi: 2
'Deskripsi modifikasi:
'20090108 Tambahkan fungsi berikut:
' A2U(),U2A(),UrlEncode(),UrlDecode(),GBToUTF8(),Bytes2Str(),Str2Bytes()
'20090108 Tambahkan fungsi berikut:
'AryToVbsString(arr)
'Versi saat ini:
'******************************/
'Keluaran
Sub Gema(str)
Respon.Tulis str
Akhir Sub
'Breakpoint
Sub Berhenti()
Respon.Akhir()
Akhiri Sub
'Output dan bungkus
SubBr(str)
Gema str & "<br />" & vbcrlf
Akhiri Sub
'Sederhanakan Permintaan.Formulir()
'f : nama formulir
Fungsi P(f)
P = Ganti(Permintaan.Formulir(f), Chr(0), "")
Fungsi Akhir
'Terima formulir dan ganti tanda kutip tunggal
Fungsi Pr(f)
Pr = Ganti(Permintaan.Formulir(f), Chr(0), "")
Pr = Ganti(Pr, "'", "''")
Fungsi Akhir
'Sederhanakan Permintaan.Querystring()
'f : nama formulir
FungsiG(f)
G = Ganti(Permintaan.QueryString(f), Chr(0), "")
Fungsi Akhir
'Terima parameter url dan ganti tanda kutip tunggal
FungsiGr(f)
Gr = Ganti(Permintaan.QueryString(f), Chr(0), "")
Gr = Ganti(Gr, "'", "''")
Fungsi Akhir
'//Construction()?:Operasi ternary oleh xilou www.chinacms.org
'ifThen mengembalikan s1 untuk benar dan s2 untuk salah
Fungsi IfThen (jika Benar, s1, s2)
Redupkan
Jika jika Benar Maka
t = s1
Kalau tidak
t = s2
Akhiri Jika
JikaKemudian = t
Fungsi Akhir
'Menampilkan ya dan tidak dalam warna berbeda
Fungsi IfThenFont(ifTrue, s1, s2)
Dimtr
Jika jika Benar Maka
str = "<font color=""#006600"">" & s1 & "</font>"
Kalau tidak
str = "<font color=""#FF0000"">" & s2 & "</font>"
Akhiri Jika
IfThenFont = str
Fungsi Akhir
'Buat objek Kamus
Fungsi NewHashTable()
Setel NewHashTable = Server.CreateObj("Scripting.Dictionary")
NewHashTable.CompareMode = 1 'Nilai kunci tidak peka huruf besar-kecil
Fungsi Akhir
'Buat XmlHttp
Fungsi NewXmlHttp()
Setel NewXmlHttp = Server.createobject("MSXML2.XMLHTTP")
Fungsi Akhir
'Buat XmlDom
Fungsi NewXmlDom()
Fungsi Akhir
'Buat AdoStream
Fungsi NewAdoStream()
Setel NewAdoStream = Server.CreateObject("Adodb.Stream")
Fungsi Akhir
'Membuat array 1 dimensi
'Kembalikan array kosong yang terdiri dari n elemen
'n: jumlah elemen
FungsiArray Baru(n)
Redupkan ary : ary = array()
ReDim ary(n-1)
Array Baru = ary
Fungsi Akhir
'Bangun Coba..Tangkap
SubCoba()
Pada Kesalahan Lanjutkan Berikutnya
Akhiri Sub
'Bangun Coba..Tangkap
'pesan: Pesan kesalahan dilempar, jika kosong, Err.Deskripsi dilempar
Sub Tangkapan (pesan)
Redupkan html
html = "<ul><li>$1</li></ul>"
Jika Salah Lalu
Jika pesan <> "" Lalu
echo Ganti(html, "$1", pesan)
Berhenti
Kalau tidak
echo Ganti(html, "$1", Err.Deskripsi)
Berhenti
Akhiri Jika
Err. Jelas
Respon.Akhir()
Akhiri Jika
Akhir Sub
'-------------------------------- Operasi array dimulai
'Tentukan apakah ada nilai tertentu dalam array
Fungsi InArray(arr, s)
Jika Bukan IsArray(arr) Maka InArray = False : Keluar dari Fungsi
Redupkan saya
Untuk i = LBound(arr) Ke UBound(arr)
Jika s = arr(i) Maka InArray = True : Keluar dari Fungsi
Berikutnya
DalamArray = Salah
Fungsi Akhir
'Ganti placeholder di str dengan nilai dalam array ary.
'Kembalikan string yang diganti
'str: String yang akan diganti, placeholdernya adalah $0, $1, $2...
'ary: Array digunakan untuk penggantian, setiap nilai sesuai dengan $0, $1, $2... di placeholder.
'Misalnya: GantiByAry("$0-$1-$2 $3:$4:$5",Array(y,m,d,h,i,s))
Fungsi GantiOlehAry(str,ary)
Redupkan i, j, L1, L2 : j = 0
Jika IsArray(ary) Lalu
L1 = LBound(ary) : L2 = UBound(ary)
Untuk i = L1 Sampai L2
str = Ganti(str, "$"&j, ary(i))
j = j+1
Berikutnya
Akhiri Jika
GantiOlehAry = str
Fungsi Akhir
'--------------operasi array berakhir
'------------- --- ---------------Operasi bilangan acak dimulai
'Dapatkan nomor acak
'mn nomor acak
Fungsi RndNumber(m,n)
Acak
Nomor Rnd = Int((n - m + 1) * Rnd + m)
Fungsi Akhir
'Dapatkan string acak
'n : panjang yang dihasilkan
Fungsi RndTeks(n)
Redupkan str1, str2, i, x, L
str1 = "NOPQRSTUVWXYZ012ABCDEFGHIJKLM3456abcdefghijklm789nopqrstuvwxyz"
L = Len(str1)
Acak
Untuk i = 1 Sampai n
x = Int((L - 1 + 1) * Jalan + 1)
str2 = str2 & Tengah(str1,x,1)
Berikutnya
RndTeks = str2
Fungsi Akhir
'Hasilkan m hingga n string acak dari string str
'Jika str kosong, string acak akan dihasilkan dari angka dan huruf secara default
'str : Untuk menghasilkan string acak dari string ini
'm,n: menghasilkan n hingga m bit
Fungsi RndByText(str, m, n)
Redupkan i, k, str2, L, x
Jika str = "" Maka str = "NOPQRSTUVWXYZ012ABCDEFGHIJKLM3456abcdefghijklm789nopqrstuvwxyz"
L = Len(str)
Jika n = m Maka
k = n
Kalau tidak
Acak
k = Int((n - m + 1) * Jalan + m)
Akhiri Jika
Acak
Untuk i = 1 Ke k
x = Int((L - 1 + 1) * Jalan + 1)
str2 = str2 & Tengah(str, x, 1)
Berikutnya
RndByText = str2
Fungsi Akhir
'Tanggal dan waktu membentuk angka acak
'Kembalikan kombinasi angka waktu saat ini
Fungsi RndByDateTime()
Redupkan dt : dt = Sekarang()
RndByDateTime = Tahun(dt) & Bulan(dt) & Hari(dt) & Jam(dt) & Menit(dt) & Detik(dt)
Fungsi Akhir
'--------------Operasi bilangan acak berakhir
'--------------- ------ --------------------Operasi string dimulai
'Tentukan berapa kali string str2 muncul di string str1 lainnya
'Kembalikan berapa kali, jika tidak, kembalikan 0
'str1: ekspresi string yang menerima pencarian
'str2: Ekspresi string yang akan dicari
'start: Posisi awal yang akan dicari. Jika kosong, berarti dimulai dari 1 secara default.
Fungsi InStrTimes(str1, str2, mulai)
Redupkan a,c
Jika mulai = "" Maka mulai = 1
c = 0
a = InStr(mulai, str1, str2)
Lakukan Sementara > 0
c = c + 1
a = InStr(a+1, str1, str2)
Lingkaran
InStrTimes = c
Fungsi Akhir
'Penggabungan string
'Tidak bisa kembali
'strResult: Karakter disimpan setelah koneksi
'str : karakter yang akan digabungkan
'partisi: simbol pemisah antar karakter penghubung
Sub JoinStr(byref strResult,str,partisi)
Jika strResult <> "" Lalu
strResult = strResult & partisi & str
Kalau tidak
strHasil = str
Akhiri Jika
End Sub
'Hitung panjang byte string, satu karakter Cina = 2 byte
FungsiStrLen(str)
Jika isNull(str) atau Str = "" Lalu
StrLen = 0
Fungsi Keluar
Akhiri Jika
Redupkan WINNT_CHINESE
WINNT_CHINESE = (len("contoh")=2)
Jika WINNT_CHINESE Lalu
Redupkan l,t,c
Redupkan saya
aku = len(str)
t = aku
Untuk saya = 1 Ke l
c = asc(tengah(str,i,1))
Jika c<0 Maka c = c + 65536
Jika c>255 Maka t = t + 1
Berikutnya
StrLen = t
Kalau tidak
StrLen = len(str)
Akhiri Jika
Fungsi Akhir
'Mencegat string
'str: string yang akan dicegat
'strlen: panjang yang akan dicegat
' addStr: Gunakan ini jika panjangnya melebihi, seperti:...
Fungsi CutStr(str, strlen, addStr)
Redupkan aku,l,t,c
Jika Is_Empty(str) Kemudian CutStr = "" : Keluar dari Fungsi
aku = len(str) : t = 0
Untuk saya = 1 Ke l
c = Abs(Asc(Tengah(str,i,1)))
Jika c > 255 Maka
t=t+2
Kalau tidak
t=t+1
Akhiri Jika
Jika t > strlen Maka
CutStr = kiri(str, i) & tambahkanStr
Keluar Untuk
Kalau tidak
PotongStr = str
Akhiri Jika
Berikutnya
Fungsi Akhir
'Mengonversi lebar penuh menjadi setengah lebar
Fungsi SBCcaseConvert(str)
Redupkan b, c, i
b = "1,2,3,4,5,6,7,8,9,0," _
&"A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X, Ｙ,Ｚ"
c = "1,2,3,4,5,6,7,8,9,0," _
&"A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X, Y,Z"
b = membagi(b,",")
c = membagi(c,",")
Untuk i = 0 Ke Ubound(b)
Jika instr(str,b(i)) > 0 Maka
str = Ganti(str, b(i), c(i))
Akhiri Jika
Berikutnya
SBCcaseConvert = str
End Function
'setara dengan escape() dalam javascript
Fungsi VbsEscape(str)
dimi,s,c,a
s = ""
Untuk i=1 sampai Len(str)
c = Tengah(str,i,1)
a = ASCW(c)
Jika (a>=48 dan a<=57) atau (a>=65 dan a<=90) atau (a>=97 dan a<=122) Maka
s = s&c
ElseIf InStr("@*_+-./",c) > 0 Lalu
s = s&c
LainJika a>0 dan a<16 Maka
s = s & "%0" & Heksa(a)
LainJika a>=16 dan a<256 Maka
s = s & "%" & Heksa(a)
Kalau tidak
s = s & "%u" & Hex(a)
Akhiri Jika
Berikutnya
VbsEscape=s
Fungsi Akhir
'Dekode data yang dikodekan menggunakan escape() dalam javascript, digunakan saat memanggil ajax
Fungsi VbsUnEscape(str)
Redupkan x
x = InStr(str,"%")
Lakukan Sementara x > 0
VbsUnEscape = VbsUnEscape & Tengah(str,1,x-1)
Jika LCase(Mid(str,x+1,1)) = "u" Maka
VbsUnEscape = VbsUnEscape & ChrW(CLng("&H"&Mid(str,x+2,4)))
str = Tengah(str,x+6)
Kalau tidak
VbsUnEscape = VbsUnEscape & Chr(CLng("&H"&Mid(str,x+1,2)))
str = Tengah(str,x+3)
Akhiri Jika
x = InStr(str,"%")
Lingkaran
VbsUnEscape = VbsUnEscape & str
Fungsi Akhir
'Konversi karakter ascii ke bentuk pengkodean unicode
Fungsi A2U(str)
Redupkan i,L,uTeks
L = Len(str)
Untuk i = 1 Ke L
uTeks = uTeks & "&#" & AscW(Pertengahan(str,i,1)) & ";"
Berikutnya
A2U = uTeks
Fungsi Akhir
'Konversi pengkodean unicode ke ascii
'str: String yang akan ditranskode semuanya harus berupa karakter unicode, jika tidak, kesalahan akan terjadi
Fungsi U2A(str)
Dim ary,i,L,newStr
ary = Pisahkan(str,";")
L = UBound(ary)
Untuk i = 0 Ke L - 1
newStr = newStr & ChrW(Ganti(ary(i),"&#",""))
Berikutnya
U2A = Str baru
Fungsi Akhir
'pengkodean url
Fungsi UrlEncode(str)
UrlEncode = Server.UrlEncode(str)
Fungsi Akhir
'penguraian url
FungsiUrlDecode(str)
Redupkan newstr, havechar, lastchar, i, char_c, next_1_c, next_1_Num
beritatr = ""
haschar = salah
karakter terakhir = ""
Untuk i = 1 Ke Len(str)
char_c = Tengah(str,i,1)
Jika char_c = "+" Maka
newstr = beritatr & " "
ElseIf char_c = "%" Lalu
next_1_c = Pertengahan(str, i+1, 2)
next_1_num = Cint("&H" & next_1_c)
Jika ada char maka
haschar = salah
newstr = newstr & Chr(CInt("&H" & karakter terakhir & next_1_c))
Kalau tidak
Jika Abs(angka_1_berikutnya) <= 127 Maka
newstr = beritatr & Chr(next_1_num)
Kalau tidak
haschar = benar
karakter terakhir = next_1_c
Akhiri Jika
Akhiri Jika
saya = saya + 2
Kalau tidak
newstr = beritatr & char_c
Akhiri Jika
Berikutnya
UrlDecode = newtr
Fungsi Akhir
'GB ke UTF8--Mengonversi teks berkode GB menjadi teks berkode UTF8
Fungsi GBToUTF8(gbStr)
Redupkan wch,uch,szRet,szInput
Redupkan x
Redupkan nAsc, nAsc2, nAsc3
szInput = gbStr
'Jika parameter input kosong, keluar dari fungsinya
Jika szInput = "" Lalu
keUTF8 = szInput
Fungsi Keluar
Akhiri Jika
'Mulai konversi
Untuk x = 1 Ke Len(szInput)
'Gunakan fungsi tengah untuk membagi teks yang disandikan GB
wch = Tengah(szInput, x, 1)
'Gunakan fungsi ascW untuk mengembalikan kode karakter Unicode dari setiap teks yang dikodekan GB
'Catatan: fungsi asc mengembalikan kode karakter ANSI, perhatikan perbedaannya
nAsc = AscW(wch)
Jika nAsc < 0 Maka nAsc = nAsc + 65536
Jika (nAsc Dan &HFF80) = 0 Maka
szRet = szRet & wch
Kalau tidak
Jika (nAsc Dan &HF000) = 0 Maka
uch = "%" & Hex(((nAsc 2 ^ 6)) atau &HC0) & Hex(nAsc Dan &H3F atau &H80)
szRet = szRet&uch
Kalau tidak
'Kode karakter Unicode dari teks yang dikodekan GB mengadopsi templat tiga byte antara 0800 - FFFF
uch = "%" & Hex((nAsc 2 ^ 12) atau &HE0) & "%" & _
Hex((nAsc 2 ^ 6) Dan &H3F atau &H80) & "%" & _
Hex(nAsc Dan &H3F atau &H80)
szRet = szRet&uch
Akhiri Jika
Akhiri Jika
Berikutnya
GBToUTF8 = szRet
Fungsi Akhir
'Konversi dari aliran Byte ke aliran Char
Fungsi Bytes2Str(vin,rangkaian karakter)
Redupkan ms, strRet
Setel ms = Server.CreateObject("ADODB.Stream") 'Buat objek aliran
ms.Type = 1 'Biner
ms.Buka
ms.Write vin 'Tulis vin ke dalam objek aliran
ms.Position = 0 'Atur posisi awal objek aliran ke 0 untuk mengatur properti Charset
ms.Type = 2 'Teks
ms.Charset = charset 'Atur mode pengkodean objek aliran ke charset
strRet = ms.ReadText 'Dapatkan aliran karakter
ms.close 'Tutup objek aliran
Setel ms = tidak ada
Bytes2Str = strRet
Fungsi Akhir
'Konversi aliran Char ke aliran Byte
Fungsi Str2Bytes(str,rangkaian karakter)
Redupkan ms, strRet
Setel ms = CreateObject("ADODB.Stream") 'Buat objek aliran
ms.Type = 2 'Teks
ms.Charset = charset 'Setel mode pengkodean objek aliran ke charset
ms.Buka
ms.WriteText str 'Tulis str ke objek aliran
ms.Position = 0 'Atur posisi awal objek aliran ke 0 untuk mengatur properti Charset
ms.Type = 1 'Binary
vout = ms.Read(ms.Size) 'Dapatkan aliran karakter
ms.close 'Tutup objek aliran
Setel ms = tidak ada
Str2Bytes = vout
Fungsi Akhir
'--------------------------------Operasi string berakhir
'---------------------------- -------- -------------------- Operasi waktu dan tanggal dimulai
'Dapatkan jumlah hari yang sesuai dalam sebulan berdasarkan tahun dan bulan
'Kembalikan jumlah hari
'y: tahun, misalnya: 2008
'm: bulan, seperti: 3
Fungsi GetDayCount(y,m)
Redup c
Pilih Kasus m
Kasus 1, 3, 5, 7, 8, 10, 12
c=31
Kasus 2
Jika IsDate(y&"-"&m&"-"&"29") Lalu
c=29
Kalau tidak
c=28
Akhiri Jika
Kasus Lain
c=30
Pilihan Akhir
DapatkanDayCount = c
Fungsi Akhir
'Menentukan apakah suatu tanggal dan waktu berada di antara periode waktu tertentu, termasuk waktu di kedua ujung perbandingan
Fungsi IsBetweenTime(dariWaktu,keWaktu,strWaktu)
Jika DateDiff("s",fromTime,strTime) >= 0 Dan DateDiff("s",toTime,strTime) <= 0 Maka
IsBetweenTime = Benar
Kalau tidak
IsBetweenTime = Salah
Akhiri Jika
Fungsi Akhir
'--------------------------------Operasi waktu dan tanggal berakhir
'----------- ------------------------- --------------------Operasi terkait enkripsi keamanan dimulai
'--------------Operasi terkait enkripsi keamanan berakhir
' ---------- ---- -----------------Operasi verifikasi legalitas data dimulai
'Deteksi string melalui ekspresi reguler dan kembalikan true|false
Fungsi RegExpTest(strPatrn,strTeks)
Redupkan objRegExp, cocok
Setel objRegExp = RegExp Baru
objRegExp.Pattern = strPatrn
objRegExp.IgnoreCase = Salah
objRegExp.Global = Benar
RegExpTest = objRegExp.Test(strTeks)
'Atur kecocokan = objRegExp.Execute(strText)
Setel objRegExp = tidak ada
Fungsi Akhir
'Apakah bilangan bulat positif?
FungsiIsPint(str)
IsPint = RegExpTest("^[1-9]{1}d*$", str)
Fungsi Akhir
'Apakah itu 0 atau bilangan bulat positif
FungsiIsInt(str)
IsInt = RegExpTest("^0|([1-9]{1}d*)$", str)
Fungsi Akhir
'E-mail
Fungsi AdalahEmail(str)
Pola redup
pola = "^w+((-w+)|(.w+))*@[A-Za-z0-9]+((.|-)[A-Za-z0-9]+ )*.[A-Za-z0-9]+$"
IsEmail = RegExpTest(pola,str)
Fungsi Akhir
'ponsel
FungsiIsMobile(str)
Pola redup
pola = "^(130|131|132|133|153|134|135|136|137|138|139|158|159){1}d{8}$"
IsMobile = RegExpTest(pola,str)
Fungsi Akhir
'QQ
Fungsi AdalahQQ(str)
Pola redup
pola = "^[1-9]d{4,8}$"
IsQQ = RegExpTest(pola,str)
Fungsi Akhir
'Kartu identitas
FungsiIsIdCard(e)
Redupkan arrVerifyCode,Wi,Checker
arrVerifyCode = Pisahkan("1,0,x,9,8,7,6,5,4,3,2", ",")
Wi = Pisah("7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2", ",")
Pemeriksa = Pisahkan("1,9,8,7,6,5,4,3,2,1,1", ",")
Jika Len(e) < 15 atau Len(e) = 16 atau Len(e) = 17 atau Len(e) > 18 Maka
IsIdCard = Salah
Fungsi Keluar
Akhiri Jika
Redupkan A
Jika Len(e) = 18 Maka
Ai = Pertengahan(e, 1, 17)
ElseIf Len(e) = 15 Maka
Ai=e
Ai = Kiri(Ai, 6) & "19" & Tengah(Ai, 7, 9)
Akhiri Jika
Jika Bukan IsNumerik(Ai) Maka
IsIdCard= Salah
Fungsi Keluar
Akhiri Jika
Redupkan strYear, strMonth, strDay, BirthDay
strTahun = CInt(Pertengahan(Ai, 7, 4))
strBulan = CInt(Pertengahan(Ai, 11, 2))
strHari = CInt(Pertengahan(Ai, 13, 2))
Hari Lahir = Potong(strTahun) + "-" + Potong(strBulan) + "-" + Potong(strHari)
Jika IsDate (Hari Ulang Tahun) Lalu
Jika DateDiff("yyyy",Sekarang,Tanggal Ulang Tahun)<-140 atau cdate(Tanggal Lahir)>tanggal() Lalu
IsIdCard= Salah
Fungsi Keluar
Akhiri Jika
Jika strMonth > 12 atau strDay > 31 Lalu
IsIdCard= Salah
Fungsi Keluar
Akhiri Jika
Kalau tidak
IsIdCard= Salah
Fungsi Keluar
Akhiri Jika
Redupkan aku,TotalmulAiWi
Untuk i = 0 Sampai 16
TotalmulAiWi = TotalmulAiWi + CInt(Tengah(Ai, i + 1, 1)) * Wi(i)
Berikutnya
Redupkan modValue
modValue = TotalmulAiWi Mod 11
Redupkan strVerifyCode
strVerifyCode = arrVerifyCode(modValue)
Ai = Ai & strVerifikasiKode
IsIdCard = Ai
Jika Len(e) = 18 Dan e <> Ai Maka
IsIdCard= Salah
Fungsi Keluar
Akhiri Jika
IsIdCard=Benar
Fungsi Akhir
'kode Pos
Fungsi IsZipCode(str)
Pola redup
pola = "^[1-9]d{2,5}$"
IsZipCode = RegExpTest(pola,str)
Fungsi Akhir
'Apakah kosong, termasuk fungsi IsEmpty(), IsNull(), ""
Fungsi Is_Empty(str)
Jika IsNull(str) atau IsEmpty(str) atau str="" Lalu
Is_Empty=Benar
Kalau tidak
Is_Empty=Salah
Akhiri Jika
Fungsi Akhir
'--------------------------------Operasi verifikasi validitas data berakhir
'--------- -- ---------------------Operasi file dimulai
'Dapatkan akhiran file, seperti jpg
Fungsi DapatkanFileExt(f)
GetFileExt = Lcase(Mid(f,InStrRev(f,".") + 1))
Fungsi Akhir
'Buat folder
'path: path ke folder yang akan dibuat, gunakan path relatif
SubCFolder (jalur)
Redupkan
Setel fso = Server.CreateObject("Scripting.FileSystemObject")
Jika Tidak fso.FolderExists(path) Lalu
fso.CreateFolder(jalur)
Akhiri Jika
Tetapkan fso = Tidak ada
Akhir Sub
'Hapus folder
'jalur: jalur folder, gunakan jalur relatif
SubDFolder(jalur)
Redupkan
Setel fso = Server.CreateObject("Scripting.FileSystemObject")
Jika fso.FolderExists(jalur) Lalu
jalur fso.DeleteFolder, benar
Kalau tidak
echo "Jalur tidak ada:" & jalur
Akhiri Jika
Tetapkan fso = Tidak ada
Akhiri Sub
'Hasilkan file
'path: Hasilkan jalur file, termasuk nama
'strText: konten file
Sub CFile(jalur,strTeks)
Redupkan f,fso
Setel fso = Server.CreateObject("Scripting.FileSystemObject")
Setel f = fso.CreateTextFile(jalur)
f.Tulis strTeks
Tetapkan f = Tidak ada
Tetapkan fso = Tidak ada
Akhir Sub
'Hapus file
'path: jalur file, termasuk nama
SubDFile(jalur)
Redupkan
Setel fso = Server.CreateObject("Scripting.FileSystemObject")
Jika fso.FileExists(jalur) Lalu
Fso.DeleteFile(jalur)
Akhiri Jika
Tetapkan fso = Tidak ada
Akhir Sub
'Kumpulkan
Fungsi DapatkanHTTPHalaman(url)
'Http.setTimeout 10.000,10000,10000,10000
'Pada Kesalahan Lanjutkan Berikutnya
Redupkan Http
Setel Http = Server.createobject("MSXML2.XMLHTTP")
Http.buka "GET", url, salah
Http.kirim()
Jika Http.Status <> 200 Lalu
Fungsi Keluar
Akhiri Jika
'Jika Err Lalu Respon.Tulis url : Response.End()
DapatkanHTTPPage = bytesToBSTR(Http.ResponseBody,"GB2312")
'Http.Tutup()
'jika err.number<>0 maka err.Clear
Fungsi Akhir
'Konversi pengkodean
Fungsi BytesToBstr(tubuh,Cset)
DimStreamObj
Setel StreamObj = Server.CreateObject("Adodb.Stream")
StreamObj.Jenis = 1
StreamObj.Mode = 3
StreamObj.Buka
StreamObj.Tulis badan
StreamObj.Posisi = 0
StreamObj.Jenis = 2
StreamObj.Charset = Cset
BytesToBstr = StreamObj.ReadText
StreamObj.Tutup
Fungsi Akhir
'--------------------------------Operasi file berakhir
'---------------------------- ----Operasi lainnya dimulai
'Tampilkan informasi
'pesan: pesan yang akan ditampilkan
'url: URL tujuan lompat
'typeNum: mode tampilan, 1 memunculkan informasi dan kembali ke halaman sebelumnya; 2 memunculkan informasi dan menuju ke url
Sub ShowMsg(pesan,url,typeNum)
pesan = ganti(pesan,"'",,"'")
Pilih Jenis KasusNum
Kasus 1
echo ("<bahasa skrip=javascript>peringatan('" & pesan & "');history.go(-1)</script>")
Kasus 2
echo ("<bahasa skrip=javascript>peringatan('" & pesan & "');lokasi='" & Url &"'</script>")
Pilihan Akhir
Akhiri Sub
'Tampilkan daftar opsi dan posisi, oleh xilou www.chinacms.org
'textArr: susunan teks
'valueArr: susunan nilai
'curValue: nilai yang dipilih saat ini
Fungsi ShowOpList(textArr, valueArr, curValue)
Redupkan str, gaya, i
style = "style=""warna latar:#FFCCCC"""
str = ""
Jika IsNull(curValue) Maka curValue = ""
Untuk I = LBound(textArr) Ke UBound(valueArr)
Jika Cstr(valueArr(I)) = Cstr(curValue) Maka
str = str&"<option value="""&valueArr(I)&""" dipilih=""dipilih"" "&style&" >"&textArr(I)&"</option>"&vbcrlf
Kalau tidak
str = str&"<option value="""&valueArr(I)&""" >"&textArr(I)&"</option>"&vbcrlf
Akhiri Jika
Berikutnya
TampilkanOpList = str
Fungsi Akhir
'Daftar pilihan ganda
'Catatan: Anda perlu menggunakan fungsi InArray()
'textArr: susunan teks
'valueArr: susunan nilai
'curValue: larik nilai yang dipilih saat ini
Fungsi ShowMultiOpList(textArr,valueArr,curValueArr)
Gaya redup, str, isCurr, I
style = "style=""warna latar:#FFCCCC"""
str = "" : isCurr = Salah
Jika IsNull(curValue) Maka curValue = ""
Untuk I = LBound(textArr) Ke UBound(valueArr)
Jika InArray(curValueArr, valueArr(I)) Lalu
str = str&"<option value="""&valueArr(I)&""" dipilih=""dipilih"" "&style&" >"&textArr(I)&"</option>"&vbcrlf
Kalau tidak
str = str&"<option value="""&valueArr(I)&""" >"&textArr(I)&"</option>"&vbcrlf
Akhiri Jika
Berikutnya
TampilkanMultiOpList = str
Fungsi Akhir
Fungsi DapatkanIP()
Redupkan strIPAddr,actforip
Jika Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" atau InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "tidak diketahui") > 0 Lalu
strIPAddr = Permintaan.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Kemudian
strIPAddr = Tengah(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Lalu
strIPAddr = Tengah(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Kalau tidak
strIPAddr = Permintaan.ServerVariables("HTTP_X_FORWARDED_FOR")
Akhiri Jika
DapatkanIP = strIPAddr
Fungsi Akhir
'Ubah array menjadi penyimpanan objek kamus
'hashObj: objek kamus
'ary: Array, formatnya harus salah satu dari dua berikut, yang pertama hanya dapat menyimpan nilai string
' : array("Id:12","UserName:xilou","Jenis Kelamin:1"), yaitu format array("key:value",...)
' : array(array("Id","12"),array("Nama Pengguna","xilou"),array("Jenis Kelamin","1"))
'Kembalikan objek kamus
'www.chinacms.org
Sub AryAddToHashTable(ByRef hashObj,ary)
Redupkan str,ht,i,k,v,pos
Untuk i = 0 Ke UBound(ary)
Jika IsArray(ary(i)) Lalu
Jika IsObject(ary(i)(0)) Lalu
Response.Write "Error:AryToHashTable(ary), nilai kunci tidak boleh berupa tipe objek,"
Response.Tulis "Jenis nilai ary("& i &")(0) saat ini adalah:" & TypeName(ary(i)(0))
Respon.Akhir()
Akhiri Jika
If IsObject(ary(i)(1)) Kemudian 'Jika nilainya adalah sebuah objek
Tetapkan hashObj(ary(i)(0)) = ary(i)(1)
Kalau tidak
hashObj(ary(i)(0)) = ary(i)(1)
Akhiri Jika
Kalau tidak
str = ary(i) & ""
pos = InStr(str,":")
'www.chinacms.org
Jika pos < 1 Maka
Response.Tulis "Kesalahan:AryToHashTable(ary),":""Tidak ada"
Response.Write ", Terjadi pada:" & ary(i)
Respon.Akhir()
Akhiri Jika
Jika pos = 1 Maka
Response.Tulis "Error:AryToHashTable(ary), nilai kunci tidak ada"
Response.Write ", Terjadi pada:" & ary(i)
Respon.Akhir()
Akhiri Jika
k = Kiri(str,pos-1)
v = Tengah(str,pos+1)
hashObj(k) = v
Akhiri Jika
Berikutnya
End Sub
'Ubah array menjadi penyimpanan objek kamus
'ary: Array, formatnya harus salah satu dari dua berikut, yang pertama hanya dapat menyimpan nilai string
' : array("Id:12","UserName:xilou","Jenis Kelamin:1"), yaitu format array("key:value",...)
' : array(array("Id","12"),array("Nama Pengguna","xilou"),array("Jenis Kelamin","1"))
'Kembalikan objek kamus
Fungsi AryToHashTable(ary)
Redupkan str,ht,i,k,v,pos
Setel ht = Server.CreateObject("Scripting.Dictionary")
ht.BandingkanMode = 1
AryAddToHashTable ht , ary
Atur AryToHashTable = ht
Fungsi Akhir
'Mengonversi array menjadi string, yang setara dengan serialisasi array. Satu-satunya format yang diperbolehkan adalah:
'array("p1:v1","p2:v2",array("p3",benar))
'string kembali
Fungsi AryToVbsString(arr)
Redupkan str,i,c
Jika Bukan IsArray(arr) Maka Respon.Tulis "Error: AryToString(arr) error, parameter arr bukan array"
c = UBound(arr)
Untuk i = 0 Ke c
Jika IsArray(arr(i)) Lalu
Pilih Kasus LCase(TypeName(arr(i)(1)))
Huruf "tanggal", "string", "kosong"
str = str & ",array(""" & arr(i)(0) & ""","""& arr(i)(1) &""")"
Huruf besar "integer", "panjang", "tunggal", "ganda", "mata uang", "desimal", "boolean"
str = str & ",array(""" & arr(i)(0) & ""","& arr(i)(1) &")"
Kasus "batal"
str = str & ",array(""" & arr(i)(0) & """,batal)"
Kasus Lain
Response.Write "Error: AryToVbsString(arr), parameter berisi data ilegal, indeks i="&i&", nilai kuncinya adalah: "&arr(i)(0)
Respon.Akhir()
Pilihan Akhir
Kalau tidak
str = str & ",""" & arr(i) & """"
Akhiri Jika
Berikutnya
Jika str <> "" Maka str = Tengah(str, 2, Len(str) - 1)
str = "array(" & str & ")"
AryToVbsString = str
Fungsi Akhir
'--------------------------------Operasi lainnya berakhir
%>