Artikel ini menyediakan serangkaian fungsi pengumpulan ASP lengkap, termasuk mengekstraksi karakter asli alamat, menyimpan file jarak jauh ke login simulasi lokal, mendapatkan kode sumber halaman web, dan fungsi fungsional lainnya . Salin kode sebagai berikut:
' ===== = =
'Nama fungsi: GetHttpPage
'Fungsi: Mendapatkan kode sumber halaman web
'Parameter: HttpUrl ------Alamat halaman web
' ===== = =
Fungsi DapatkanHttpPage(HttpUrl)
Jika IsNull(HttpUrl)=Benar Atau Len(HttpUrl)<18 Atau HttpUrl=$False$ Maka
GetHttpPage=$Salah$
Fungsi Keluar
Akhiri Jika
Redupkan Http
Setel Http=server.createobject(MSX & ML2.XM & LHT & TP)
Http.buka GET,HttpUrl,False
Http.Kirim()
Jika Http.Readystate<>4 maka
Setel Http=Tidak Ada
GetHttpPage=$Salah$
Fungsi keluar
Berakhir jika
DapatkanHTTPPage=bytesToBSTR(Http.responseBody,GB2312)
GetHTTPPage=ganti(ganti(GetHTTPPage , vbCr,),vbLf,)
Setel Http=Tidak Ada
Jika Err.number<>0 maka
Err. Jelas
Akhiri Jika
Fungsi Akhir
' ===== = =
'Nama fungsi: BytesToBstr
'Fungsi: Mengubah kode sumber yang diperoleh ke dalam bahasa Mandarin
'Parameter: Isi ------Variabel yang akan dikonversi
'Parameter: Cset ------ketik yang akan dikonversi
' ===== = =
Fungsi BytesToBstr(Badan,Cset)
Redupkan Objstream
Setel Objstream = Server.CreateObject(iklan & odb.str & eam)
objstream.Jenis = 1
objstream.Mode =3
objstream.Buka
objstream.Tulis isi
objstream.Posisi = 0
objstream.Jenis = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Tutup
setel objstream = tidak ada
Fungsi Akhir
' ===== = =
'Nama fungsi: PostHttpPage
'Fungsi: masuk
' ===== = =
Fungsi PostHttpPage(RefererUrl,PostUrl,PostData)
DimxmlHttp
RedupRetStr
Setel xmlHttp = CreateObject(Msx & ml2.XM & LHT & TP)
xmlHttp.Buka POST, PostUrl, Salah
XmlHTTP.setRequestHeader Panjang Konten, Len (PostData)
xmlHttp.setRequestHeader Tipe Konten, aplikasi/x-www-form-urlencoded
xmlHttp.setRequestHeader Referer, RefererUrl
xmlHttp.Kirim PostData
Jika Err.Number <> 0 Lalu
Setel xmlHttp=Tidak Ada
PostHttpPage = $Salah$
Fungsi Keluar
Akhiri Jika
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,GB2312)
Setel xmlHttp = tidak ada
Fungsi Akhir
' ===== = =
'Nama fungsi: UrlEncoding
'Fungsi: Mengonversi pengkodean
' ===== = =
Fungsi Pengkodean Url(DataStr)
Redupkan StrReturn,Si,ThisChr,InnerCode,Hight8,Low8
StrKembali =
Untuk Si = 1 Ke Len(DataStr)
ThisChr = Tengah(DataStr,Si,1)
Jika Abs(Asc(ThisChr)) < &HFF Lalu
StrReturn = StrReturn & IniChr
Kalau tidak
Kode Dalam = Asc(ThisChr)
Jika InnerCode < 0 Maka
Kode Dalam = Kode Dalam + &H10000
Akhiri Jika
Hight8 = (Kode Dalam Dan &HFF00)/ &HFF
Low8 = Kode Dalam Dan &HFF
StrReturn = StrReturn & % & Hex(Tinggi8) & % & Hex(Rendah8)
Akhiri Jika
Berikutnya
UrlEncoding = StrReturn
Fungsi Akhir
' ===== = =
'Nama fungsi: GetBody
'Fungsi: mencegat string
'Parameter: ConStr ------ String yang akan dicegat
'Parameter: StartStr ------ string awal
'Parameter: OverStr ------ String akhir
'Parameter: IncluL ------ Apakah StartStr disertakan
'Parameter:IncluR ------apakah akan menyertakan OverStr
' ===== = =
Fungsi GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
Jika ConStr=$False$ atau ConStr= atau IsNull(ConStr)=True Atau StartStr= atau IsNull(StartStr)=True Atau OverStr= atau IsNull(OverStr)=True Maka
DapatkanBody=$Salah$
Fungsi Keluar
Akhiri Jika
DimConStrTemp
Redupkan Mulai, Selesai
ConStrTemp=Lcase(ConStr)
MulaiStr=Lkasus(MulaiStr)
OverStr=Lkasus(OverStr)
Mulai = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
Jika Mulai<=0 maka
DapatkanBody=$Salah$
Fungsi Keluar
Kalau tidak
Jika Termasuk=Salah Maka
Mulai=Mulai+LenB(MulaiStr)
Akhiri Jika
Akhiri Jika
Over=InStrB(Mulai,ConStrTemp,OverStr,vbBinaryCompare)
Jika Lebih<=0 Atau Lebih<=Mulai maka
DapatkanBody=$Salah$
Fungsi Keluar
Kalau tidak
Jika InclR=Benar Maka
Atas=Atas+LenB(AtasStr)
Akhiri Jika
Akhiri Jika
GetBody=MidB(ConStr,Mulai,Awal-Awal)
Fungsi Akhir
' ===== = =
'Nama fungsi: GetArray
'Fungsi: Ekstrak alamat tautan, dipisahkan dengan $Array$
'Parameter: ConStr ------Ekstrak karakter asli alamat
'Parameter: StartStr ------ string awal
'Parameter: OverStr ------ String akhir
'Parameter: IncluL ------ Apakah StartStr disertakan
'Parameter:IncluR ------apakah akan menyertakan OverStr
' ===== = =
Fungsi GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
Jika ConStr=$False$ atau ConStr= Atau IsNull(ConStr)=True atau StartStr= Atau OverStr= atau IsNull(StartStr)=True Atau IsNull(OverStr)=True Maka
DapatkanArray=$Salah$
Fungsi Keluar
Akhiri Jika
Redupkan TempStr,TempStr2,objRegExp,Cocok,Cocok
SuhuStr=
Setel objRegExp = Regexp Baru
objRegExp.IgnoreCase = Benar
objRegExp.Global = Benar
objRegExp.Pattern = (&StartStr&).+?(&OverStr&)
Tetapkan Kecocokan =objRegExp.Execute(ConStr)
Untuk Setiap Pertandingan dalam Pertandingan
TempStr=TempStr & $Array$ & Cocok.Nilai
Berikutnya
Tetapkan Kecocokan=tidak ada
Jika TempStr = Maka
DapatkanArray=$Salah$
Fungsi Keluar
Akhiri Jika
TempStr=Kanan(TempStr,Len(TempStr)-7)
Jika IncluL=False maka
objRegExp.Pattern =StartStr
TempStr=objRegExp.Ganti(TempStr,)
Berakhir jika
Jika InclR=False maka
objRegExp.Pattern =OverStr
TempStr=objRegExp.Ganti(TempStr,)
Berakhir jika
Setel objRegExp=tidak ada
Tetapkan Kecocokan=tidak ada
TempStr=Ganti(TempStr,,)
TempStr=Ganti(TempStr,',)
TempStr=Ganti(TempStr, ,)
TempStr=Ganti(TempStr,(,)
TempStr=Ganti(TempStr,),)
Jika TempStr= maka
DapatkanArray=$Salah$
Kalau tidak
DapatkanArray=TempStr
Berakhir jika
Fungsi Akhir
' ===== = =
'Nama fungsi: DefiniteUrl
'Fungsi: Mengubah alamat relatif menjadi alamat absolut
'Parameter: PrimitiveUrl ------ alamat relatif yang akan dikonversi
'Parameter: ConsultUrl ------Alamat halaman web saat ini
' ===== = =
Fungsi DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Redupkan ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
Jika PrimitiveUrl= atau ConsultUrl= atau PrimitiveUrl=$False$ atau ConsultUrl=$False$ Lalu
Url Pasti=$Salah$
Fungsi Keluar
Akhiri Jika
Jika Kiri(Lcase(ConsultUrl),7)<>http:// Lalu
KonsultasikanUrl= http:// & KonsultasikanUrl
Akhiri Jika
ConsultUrl=Ganti(KonsultasikanUrl,/,/)
ConsultUrl=Ganti(KonsultasikanUrl,://,://)
PrimitiveUrl=Ganti(PrimitiveUrl,/,/)
Jika Benar(KonsultasikanUrl,1)<>/ Lalu
Jika Instr(ConsultUrl,/)>0 Lalu
Jika Instr(Kanan(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,/)),.)>0 maka
Kalau tidak
ConsultUrl=KonsultasikanUrl & /
Akhiri Jika
Kalau tidak
ConsultUrl=KonsultasikanUrl & /
Akhiri Jika
Akhiri Jika
ConArray=Split(KonsultasikanUrl,/)
Jika Kiri(LCase(PrimitiveUrl),7) = http:// maka
DefiniteUrl=Ganti(Url Primitif,://,://)
ElseIf Left(PrimitiveUrl,1) = / Lalu
DefiniteUrl=ConArray(0) & PrimitiveUrl
ElseIf Left(PrimitiveUrl,2)=./ Kemudian
PrimitiveUrl=Kanan(PrimitiveUrl,Len(PrimitiveUrl)-2)
Jika Benar(KonsultasikanUrl,1)=/ Lalu
DefiniteUrl=KonsultasikanUrl & PrimitiveUrl
Kalau tidak
DefiniteUrl=Kiri(ConsultUrl,InstrRev(ConsultUrl,/)) & PrimitiveUrl
Akhiri Jika
ElseIf Left(PrimitiveUrl,3)=../ lalu
Lakukan Sementara Kiri(PrimitiveUrl,3)=../
PrimitiveUrl=Kanan(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Lingkaran
Untuk Ci=0 hingga (Ubound(ConArray)-1-Pi)
Jika DefiniteUrl<> Lalu
DefiniteUrl=DefiniteUrl & / & ConArray(Ci)
Kalau tidak
Url Pasti=ConArray(Ci)
Akhiri Jika
Berikutnya
DefiniteUrl=DefiniteUrl & / & PrimitiveUrl
Kalau tidak
Jika Instr(PrimitiveUrl,/)>0 Lalu
PriArray=Pisahkan(Url Primitif,/)
Jika Instr(PriArray(0),.)>0 Lalu
Jika Benar(PrimitiveUrl,1)=/ Kemudian
DefiniteUrl=http:// & PrimitiveUrl
Kalau tidak
Jika Instr(PriArray(Ubound(PriArray)-1),.)>0 Lalu
DefiniteUrl=http:// & PrimitiveUrl
Kalau tidak
Url Pasti=http:// & Url Primitif & /
Akhiri Jika
Akhiri Jika
Kalau tidak
Jika Benar(KonsultasikanUrl,1)=/ Lalu
DefiniteUrl=KonsultasikanUrl & PrimitiveUrl
Kalau tidak
DefiniteUrl=Kiri(ConsultUrl,InstrRev(ConsultUrl,/)) & PrimitiveUrl
Akhiri Jika
Akhiri Jika
Kalau tidak
Jika Instr(PrimitiveUrl,.)>0 Lalu
Jika Benar(KonsultasikanUrl,1)=/ Lalu
Jika benar(LCase(PrimitiveUrl),3)=.cn atau kanan(LCase(PrimitiveUrl),3)=com atau kanan(LCase(PrimitiveUrl),3)=net atau kanan(LCase(PrimitiveUrl),3)=org Kemudian
Url Pasti=http:// & Url Primitif & /
Kalau tidak
DefiniteUrl=KonsultasikanUrl & PrimitiveUrl
Akhiri Jika
Kalau tidak
Jika benar(LCase(PrimitiveUrl),3)=.cn atau kanan(LCase(PrimitiveUrl),3)=com atau kanan(LCase(PrimitiveUrl),3)=net atau kanan(LCase(PrimitiveUrl),3)=org Kemudian
Url Pasti=http:// & Url Primitif & /
Kalau tidak
DefiniteUrl=Kiri(ConsultUrl,InstrRev(ConsultUrl,/)) & / & PrimitiveUrl
Akhiri Jika
Akhiri Jika
Kalau tidak
Jika Benar(KonsultasikanUrl,1)=/ Lalu
DefiniteUrl=KonsultasikanUrl & PrimitiveUrl & /
Kalau tidak
DefiniteUrl=Kiri(ConsultUrl,InstrRev(ConsultUrl,/)) & / & PrimitiveUrl & /
Akhiri Jika
Akhiri Jika
Akhiri Jika
Akhiri Jika
Jika Kiri(DefiniteUrl,1)=/ maka
DefiniteUrl=Kanan(DefiniteUrl,Len(DefiniteUrl)-1)
Berakhir jika
Jika DefiniteUrl<> Lalu
DefiniteUrl=Ganti(DefiniteUrl,//,/)
DefiniteUrl=Ganti(DefiniteUrl,://,://)
Kalau tidak
Url Pasti=$Salah$
Akhiri Jika
Fungsi Akhir
' ===== = =
'Nama fungsi: GantiSimpanRemoteFile
'Fungsi: mengganti dan menyimpan gambar jarak jauh
'Parameter: ConStr ------ string yang akan diganti
'Parameter: SaveTf ------ Apakah akan menyimpan file, False tidak menyimpan, True menyimpan
'Parameter: TistUrl------ alamat halaman web saat ini
' ===== = =
Fungsi GantiSimpanRemoteFile(ConStr,InstallPath,strChannelDir,SaveTf,TistUrl)
Jika ConStr=$False$ atau ConStr= atau InstallPath= atau strChannelDir= Lalu
GantiSimpanRemoteFile=ConStr
Fungsi Keluar
Akhiri Jika
Redupkan TempStr,TempStr2,TempStr3,Re,Cocok,Cocok,Tempi,TempArray,TempArray2
Setel Re = Regexp Baru
Re.IgnoreCase = Benar
Re.Global = Benar
Re.Pattern =<img.+?>
Tetapkan Kecocokan =Re.Execute(ConStr)
Untuk Setiap Pertandingan dalam Pertandingan
Jika TempStr<> maka
TempStr=TempStr & $Array$ & Cocok.Nilai
Kalau tidak
TempStr=Cocok.Nilai
Berakhir jika
Berikutnya
Jika TempStr<> Lalu
TempArray=Pisahkan(TempStr,$Array$)
SuhuStr=
Untuk Tempi=0 Ke Ubound(TempArray)
Re.Pattern =src/s*=/s*.+?/.(gifjpgbmpjpegpsdpngsvgdxfwmftiff)
Tetapkan Kecocokan =Re.Execute(TempArray(Tempi))
Untuk Setiap Pertandingan dalam Pertandingan
Jika TempStr<> maka
TempStr=TempStr & $Array$ & Cocok.Nilai
Kalau tidak
TempStr=Cocok.Nilai
Berakhir jika
Berikutnya
Berikutnya
Berakhir jika
Jika TempStr<> Lalu
Re.Pola =src/s*=/s*
TempStr=Re.Ganti(TempStr,)
Akhiri Jika
Tetapkan Kecocokan=tidak ada
Tetapkan Re=tidak ada
Jika TempStr= atau IsNull(TempStr)=Benar Maka
GantiSimpanRemoteFile=ConStr
Fungsi keluar
Berakhir jika
TempStr=Ganti(TempStr,,)
TempStr=Ganti(TempStr,',)
TempStr=Ganti(TempStr, ,)
Redupkan RemoteFileurl,SavePath,PathTemp,DtNow,strFileName,strFileType,ArrSaveFileName,RanNum,Arr_Path
DtSekarang=Sekarang()
'************************************
Jika SaveTf=Benar maka
SavePath=InstallPath&strChannelDir
Jika CheckDir(InstallPath & strChannelDir)=False Maka
Jika Tidak CreateMultiFolder(InstallPath & strChannelDir) Lalu
respon.Tulis InstallPath & strChannelDir& Pembuatan direktori gagal
SaveTf=Salah
Akhiri Jika
Akhiri Jika
Akhiri Jika
'Mulailah dengan menghapus gambar duplikat
TempArray=Pisahkan(TempStr,$Array$)
SuhuStr=
Untuk Tempi=0 Ke Ubound(TempArray)
Jika Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Maka
TempStr=TempStr & $Array$ & TempArray(Tempi)
Akhiri Jika
Berikutnya
TempStr=Kanan(TempStr,Len(TempStr)-7)
TempArray=Pisahkan(TempStr,$Array$)
'Hapus gambar duplikat dan akhiri
respon.Tulis <br>Gambar ditemukan:<br>&Replace(TempStr,$Array$,<br>)
'Mulai mengonversi alamat gambar relatif
SuhuStr=
Untuk Tempi=0 Ke Ubound(TempArray)
TempStr=TempStr & $Array$ & DefiniteUrl(TempArray(Tempi),TistUrl)
Berikutnya
TempStr=Kanan(TempStr,Len(TempStr)-7)
TempStr=Ganti(TempStr,Chr(0),)
TempArray2=Pisahkan(TempStr,$Array$)
SuhuStr=
'Akhir dari konversi alamat gambar relatif
'Penggantian/simpan gambar
Setel Re = Regexp Baru
Re.IgnoreCase = Benar
Re.Global = Benar
Untuk Tempi=0 Ke Ubound(TempArray2)
'***************************************
RemoteFileUrl=TempArray2(Tempi)
Jika RemoteFileUrl<>$False$ Dan SaveTf=True Maka Simpan gambarnya
ArrSaveFileName = Pisahkan(RemoteFileurl,.)
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'Jenis file
Jika strFileType=asp atau strFileType=asa atau strFileType=aspx atau strFileType=cer atau strFileType=cdx atau strFileType=exe atau strFileType=rar atau strFileType=zip maka
Unggah File=
GantiSimpanRemoteFile=ConStr
Fungsi Keluar
Akhiri Jika
Acak
RanNum=Int(900*Rnd)+100
strFileName = tahun(DtNow) & kanan(0 & bulan(DtNow),2) & kanan(0 & hari(DtNow),2) & kanan(0 & jam(DtNow),2) & kanan(0 & menit(DtNow) ) ),2) & kanan(0 & detik(DtNow),2) & ranNum &
Re.Pola =TempArray(Tempi)
respon.Tulis <br>Simpan ke alamat lokal:&InstallPath & strChannelDir & strFileName
Jika SaveRemoteFile(InstallPath & strChannelDir & strFileName,RemoteFileUrl,RemoteFileUrl)=Benar Maka
respon.Tulis <font color=blue>sukses</font><br>
PathTemp=InstallPath & strChannelDir & strFileName
ConStr=Re.Ganti(ConStr,PathTemp)
Re.Pattern=InstallPath&strChannelDir
UploadFiles=UploadFiles & & InstallPath & strChannelDir & strFileName
Kalau tidak
PathTemp=RemoteFileUrl
ConStr=Re.Ganti(ConStr,PathTemp)
Akhiri Jika
ElseIf RemoteFileurl<>$False$ dan SaveTf=False Maka'Jangan simpan gambar
Re.Pola =TempArray(Tempi)
ConStr=Re.Ganti(ConStr,RemoteFileUrl)
Akhiri Jika
'***************************************
Berikutnya
Tetapkan Re=tidak ada
GantiSimpanRemoteFile=ConStr
Fungsi akhir
' ===== = =
'Nama fungsi: GantiSwfFile
'Fungsi: mengurai jalur animasi
'Parameter: ConStr ------ string yang akan diganti
'Parameter: TistUrl------ alamat halaman web saat ini
' ===== = =
Fungsi GantiSwfFile(ConStr,TistUrl)
Jika ConStr=$False$ atau ConStr= atau TistUrl= atau TistUrl=$False$ Maka
GantiSwfFile=ConStr
Fungsi Keluar
Akhiri Jika
Redupkan TempStr,TempStr2,TempStr3,Re,Cocok,Cocok,Tempi,TempArray,TempArray2
Setel Re = Regexp Baru
Re.IgnoreCase = Benar
Re.Global = Benar
Re.Pattern =<object.+?[^/>]>
Tetapkan Kecocokan =Re.Execute(ConStr)
Untuk Setiap Pertandingan dalam Pertandingan
Jika TempStr<> maka
TempStr=TempStr & $Array$ & Cocok.Nilai
Kalau tidak
TempStr=Cocok.Nilai
Berakhir jika
Berikutnya
Jika TempStr<> Lalu
TempArray=Pisahkan(TempStr,$Array$)
SuhuStr=
Untuk Tempi=0 Ke Ubound(TempArray)
Re.Pattern =nilai/s*=/s*.+?/.swf
Tetapkan Kecocokan =Re.Execute(TempArray(Tempi))
Untuk Setiap Pertandingan dalam Pertandingan
Jika TempStr<> maka
TempStr=TempStr & $Array$ & Cocok.Nilai
Kalau tidak
TempStr=Cocok.Nilai
Berakhir jika
Berikutnya
Berikutnya
Berakhir jika
Jika TempStr<> Lalu
Re.Pola =nilai/s*=/s*
TempStr=Re.Ganti(TempStr,)
Akhiri Jika
Jika TempStr= atau IsNull(TempStr)=Benar Maka
GantiSwfFile=ConStr
Fungsi keluar
Berakhir jika
TempStr=Ganti(TempStr,,)
TempStr=Ganti(TempStr,',)
TempStr=Ganti(TempStr, ,)
Tetapkan Kecocokan=tidak ada
Tetapkan Re=tidak ada
'Mulailah dengan menghapus file duplikat
TempArray=Pisahkan(TempStr,$Array$)
SuhuStr=
Untuk Tempi=0 Ke Ubound(TempArray)
Jika Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Maka
TempStr=TempStr & $Array$ & TempArray(Tempi)
Akhiri Jika
Berikutnya
TempStr=Kanan(TempStr,Len(TempStr)-7)
TempArray=Pisahkan(TempStr,$Array$)
'Hapus file duplikat dan akhiri
'Mulai konversi alamat relatif
SuhuStr=
Untuk Tempi=0 Ke Ubound(TempArray)
TempStr=TempStr & $Array$ & DefiniteUrl(TempArray(Tempi),TistUrl)
Berikutnya
TempStr=Kanan(TempStr,Len(TempStr)-7)
TempStr=Ganti(TempStr,Chr(0),)
TempArray2=Pisahkan(TempStr,$Array$)
SuhuStr=
'Akhir dari konversi alamat relatif
'mengganti
Setel Re = Regexp Baru
Re.IgnoreCase = Benar
Re.Global = Benar
Untuk Tempi=0 Ke Ubound(TempArray2)
RemoteFileUrl=TempArray2(Tempi)
Re.Pola =TempArray(Tempi)
ConStr=Re.Ganti(ConStr,RemoteFileUrl)
Berikutnya
Tetapkan Re=tidak ada
GantiSwfFile=ConStr
Fungsi akhir
' ===== = =
'Nama proses: SaveRemoteFile
'Fungsi: menyimpan file jarak jauh ke lokal
'Parameter: LocalFileName ------ nama file lokal
'Parameter: RemoteFileUrl ------ URL file jarak jauh
'Parameter: Referer ------ File panggilan jarak jauh (untuk anti-koleksi, gunakan alamat halaman konten, biarkan kosong jika tidak ada anti-koleksi)
' ===== = =
Fungsi SaveRemoteFile(LocalFileName,RemoteFileUrl,Referer)
SaveRemoteFile=Benar
redupkan Iklan, Pengambilan, GetRemoteData
Setel Pengambilan = Server.CreateObject(Microsoft.XMLHTTP)
Dengan Pengambilan
.Buka Dapatkan, RemoteFileUrl, Salah,,
jika Referer<> maka .setRequestHeader Referer,Referer
.Mengirim
Jika .Readystate<>4 maka
SaveRemoteFile=Salah
Fungsi Keluar
Akhiri Jika
GetRemoteData = .ResponseBody
Akhiri Dengan
Atur Pengambilan = Tidak Ada
Setel Iklan = Server.CreateObject(Adodb.Stream)
Dengan Iklan
.Jenis = 1
.Membuka
.Tulis GetRemoteData
Server .SaveToFile.MapPath(NamaFile Lokal),2
.Membatalkan()
.Menutup()
Akhiri Dengan
Setel Iklan=tidak ada
fungsi akhir
' ===== = =
'Nama fungsi: GetPaing
'Fungsi: Dapatkan penomoran halaman
' ===== = =
Fungsi GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
Jika ConStr=$False$ atau ConStr= Atau StartStr= Atau OverStr= atau IsNull(ConStr)=True atau IsNull(StartStr)=True Atau IsNull(OverStr)=True Maka
DapatkanPaing=$Salah$
Fungsi Keluar
Akhiri Jika
Redupkan Mulai, Selesai, ConTemp, TempStr
SuhuStr=LCase(ConStr)
MulaiStr=LCase(MulaiStr)
OverStr=LCase(OverStr)
Atas=Instr(1,TempStr,OverStr)
Jika Lebih<=0 Lalu
DapatkanPaing=$Salah$
Fungsi Keluar
Kalau tidak
Jika InclR=Benar Maka
Atas=Atas+Len(AtasStr)
Akhiri Jika
Akhiri Jika
TempStr=Tengah(TempStr,1,Atas)
Mulai=InstrRev(TempStr,StartStr)
Jika Termasuk=Salah Maka
Mulai=Mulai+Len(StartStr)
Akhiri Jika
Jika Mulai<=0 Atau Mulai>=Selesai Kemudian
DapatkanPaing=$Salah$
Fungsi Keluar
Akhiri Jika
ConTemp=Mid(ConStr,Start,Over-Start)
ConTemp=Trim(ConTemp)
'ConTemp=Ganti(ConTemp, ,)
ConTemp=Ganti(ConTemp,,,)
ConTemp=Ganti(ConTemp,',)
ConTemp=Ganti(ConTemp,,)
ConTemp=Ganti(ConTemp,>,)
ConTemp=Ganti(ConTemp,<,)
ConTemp=Ganti(ConTemp, ;,)
GetPaing=ConTemp
Fungsi Akhir
'***************************************************
'Nama fungsi: gotTopic
'Fungsi: memotong string, setiap karakter Cina dihitung sebagai dua karakter, dan karakter Inggris dihitung sebagai satu karakter
'Parameter: str ---- string asli
' strlen ---- panjang intersep
'Nilai kembalian: string yang dicegat
'***************************************************
fungsi gotTopic(str,strlen)
jika str= maka
mendapat Topik=
fungsi keluar
berakhir jika
redup l,t,c,i
str=ganti(ganti(ganti(ganti(str, , ),,chr(34)),>,>),<,<)
aku=len(str)
t=0
untuk i=1 sampai l
c=Abs(Asc(Tengah(str,i,1)))
jika c>255 maka
t=t+2
kalau tidak
t=t+1
berakhir jika
jika t>=strlen maka
gotTopic=kiri(str,i) & …
keluar untuk
kalau tidak
mendapatTopik=str
berakhir jika
Berikutnya
gotTopic=ganti(ganti(ganti(ganti(gotTopic, , ),chr(34),),>,>),<,<;)
fungsi akhir
'***************************************************
'Nama fungsi: JoinChar
'Fungsi: Tambahkan ? atau & ke alamat
'Parameter: strUrl ---- URL
'Nilai pengembalian: URL dengan ? atau & ditambahkan
'***************************************************
fungsi GabungChar(strUrl)
jika strUrl= maka
GabungChar=
fungsi keluar
berakhir jika
jika InStr(strUrl,?)<len(strUrl) lalu
jika InStr(strUrl,?)>1 maka
jika InStr(strUrl,&)<len(strUrl) maka
GabungChar=strUrl & &
kalau tidak
GabungChar=strUrl
berakhir jika
kalau tidak
GabungChar=strUrl & ?
berakhir jika
kalau tidak
GabungChar=strUrl
berakhir jika
fungsi akhir
'*******************************************************
'Nama fungsi: CreateKeyWord
'Fungsi: Menghasilkan kata kunci dari string yang diberikan
'Parameter: Constr---string asli untuk menghasilkan kata kunci
'Nilai pengembalian: kata kunci yang dihasilkan
'*******************************************************
Fungsi CreateKeyWord(byval Constr,Num)
Jika Constr= atau IsNull(Constr)=Benar atau Constr=$False$ Maka
BuatKeyWord=$Salah$
Fungsi Keluar
Akhiri Jika
Jika Bil= atau IsNumeric(Num)=False Maka
Jumlah = 2
Akhiri Jika
Constr=Ganti(Constr,CHR(32),)
Constr=Ganti(Constr,CHR(9),)
Constr=Ganti(Constr, ,)
Constr=Ganti(Constr, ,)
Constr=Ganti(Constr,(,)
Constr=Ganti(Constr,),)
Constr=Ganti(Constr,<,)
Constr=Ganti(Constr,>,)
Constr=Ganti(Constr,,)
Constr=Ganti(Constr,?,)
Constr=Ganti(Constr,*,)
Constr=Ganti(Constr,,)
Constr=Ganti(Constr,,,)
Constr=Ganti(Constr,.,)
Constr=Ganti(Constr,/,)
Constr=Ganti(Constr,/,)
Constr=Ganti(Constr,-,)
Constr=Ganti(Constr,@,)
Constr=Ganti(Constr,#,)
Constr=Ganti(Constr,$,)
Constr=Ganti(Constr,%,)
Constr=Ganti(Constr,&,)
Konstr=Ganti(Konstr,+,)
Constr=Ganti(Constr,:,)
Constr=Ganti(Constr,：,)
Constr=Ganti(Constr,',)
Constr=Ganti(Constr,,)
Constr=Ganti(Constr,,)
Redupkan saya,ConstrTemp
Untuk i=1 Ke Len(Konstr)
ConstrTemp=ConstrTemp & & Mid(Konstr,i,Bilangan)
Berikutnya
Jika Len(ConstrTemp)<254 Lalu
ConstrTemp=ConstrTemp &
Kalau tidak
ConstrTemp=Kiri(ConstrTemp,254) &
Akhiri Jika
CreateKeyWord=ConstrTemp
Fungsi Akhir
' ===== = =
'Nama fungsi: CheckUrl
'Fungsi: Periksa Url
'Parameter: strUrl ------ Untuk memeriksa Url
' ===== = =
Fungsi CheckUrl(strUrl)
Redupkan Ulang
Setel Re=RegExp baru
Re.IgnoreCase=benar
Re.Global=Benar
Re.Pattern=http://([/w-]+/.)+[/w-]+(/[/w-./?%&=]*)?
Jika Re.test(strUrl)=Benar Maka
PeriksaUrl=strUrl
Kalau tidak
PeriksaUrl=$Salah$
Akhiri Jika
Tetapkan Rs=Tidak Ada
Fungsi Akhir
' ===== = =
'Nama fungsi: ScriptHtml
'Fungsi: memfilter tag html
'Parameter: ConStr ------ String yang akan difilter
' ===== = =
Fungsi ScriptHtml(Byval ConStr,TagName,FType)
Redupkan Ulang
Setel Re=RegExp baru
Re.IgnoreCase=benar
Re.Global=Benar
Pilih Kasus FType
Kasus 1
Re.Pattern=< & TagName & ([^>])*>
ConStr=Re.Ganti(ConStr,)
Kasus 2
Re.Pattern=< & Nama Tag & ([^>])*>.*?</ & Nama Tag & ([^>])*>
ConStr=Re.Ganti(ConStr,)
Kasus 3
Re.Pattern=< & TagName & ([^>])*>
ConStr=Re.Ganti(ConStr,)
Re.Pattern=</ & TagName & ([^>])*>
ConStr=Re.Ganti(ConStr,)
Pilihan Akhir
ScriptHtml=KontraStr
Tetapkan Re=Tidak Ada
Fungsi Akhir
' ===== = =
'Nama fungsi: HapusHTML
'Fungsi: Hapus tag html sepenuhnya
'Parameter: strHTML ------ String yang akan difilter
' ===== = =
Fungsi HapusHTML(strHTML)
Redupkan objRegExp, Cocok, Cocok
Setel objRegExp = Regexp Baru
objRegExp.IgnoreCase = Benar
objRegExp.Global = Benar
'Tutup <>
objRegExp.Pattern = <.+?>
'Cocok
Setel Kecocokan = objRegExp.Execute(strHTML)
' Lintasi set yang cocok dan ganti item yang cocok
Untuk Setiap Pertandingan dalam Pertandingan
strHtml=Ganti(strHTML,Match.Nilai,)
Berikutnya
HapusHTML=strHTML
Setel objRegExp = Tidak Ada
Fungsi Akhir
' ===== = =
'Nama fungsi: CheckDir
'Fungsi: Periksa apakah folder tersebut ada
'Parameter: FolderPath ------ jalur folder
' ===== = =
Fungsi CheckDir (byval FolderPath)
redupkan
Setel fso = Server.CreateObject(Scripting.FileSystemObject)
Jika fso.FolderExists(Server.MapPath(folderpath)) maka
'ada
CheckDir = Benar
Kalau tidak
'tidak ada
CheckDir = Salah
Berakhir jika
Tetapkan fso = tidak ada
Fungsi Akhir
' ===== = =
'Nama fungsi: MakeNewsDir
'Fungsi: Membuat folder
'Parameter: nama folder ------ nama folder
' ===== = =
Fungsi MakeNewsDir (nama folder byval)
redupkan
Setel fso = Server.CreateObject(Scri & pti & ng.Fil & eSyst & emOb & ject)
fso.CreateFolder(Server.MapPath(nama folder))
Jika fso.FolderExists(Server.MapPath(nama folder)) Lalu
MakeNewsDir = Benar
Kalau tidak
MakeNewsDir = Salah
Akhiri Jika
Tetapkan fso = tidak ada
Fungsi Akhir
' ===== = =
'Nama fungsi: DelDir
'Fungsi: Membuat folder
'Parameter: nama folder ------ nama folder
' ===== = =
Fungsi DelDir (nama folder byval)
redupkan
Setel fso = Server.CreateObject(Scri & pti & ng.Fil & eSyst & emOb & ject)
Jika fso.FolderExists(Server.MapPath(nama folder)) Lalu 'Tentukan apakah folder tersebut ada
fso.DeleteFolder (Server.MapPath(nama folder)) 'Hapus folder
Akhiri Jika
Tetapkan fso = tidak ada
Fungsi Akhir
'*******************************************************
'Nama fungsi: IsObjInstalled
'Fungsi : Mengecek apakah komponen sudah terpasang
'Parameter: strClassString ---- nama komponen
'Nilai pengembalian: Benar ---- Sudah diinstal
' Salah ---- tidak diinstal
'*******************************************************
Fungsi IsObjInstalled(strClassString)
IsObjInstalled = Salah
Salah = 0
DimxTestObj
Setel xTestObj = Server.CreateObject(strClassString)
Jika 0 = Err Maka IsObjInstalled = Benar
Setel xTestObj = Tidak Ada
Salah = 0
Fungsi Akhir
'*******************************************************
'Nama fungsi: strLength
'Fungsi: Menemukan panjang string. Karakter Cina dihitung sebagai dua karakter, dan karakter Inggris dihitung sebagai satu karakter.
'Parameter: str ---- String dengan panjang yang dibutuhkan
'Nilai kembalian: panjang string
'*******************************************************
fungsi strPanjang(str)
PADA EROR RESUME BERIKUTNYA
redupkan WINNT_CHINESE
WINNT_CHINESE = (len(Tiongkok)=2)
jika WINNT_CHINESE maka
redup l,t,c
redupkan aku
aku=len(str)
t=aku
untuk i=1 sampai l
c=asc(tengah(str,i,1))
jika c<0 maka c=c+65536
jika c>255 maka
t=t+1
berakhir jika
Berikutnya
strPanjang=t
kalau tidak
strPanjang=len(str)
berakhir jika
jika err.number<>0 maka err.clear
fungsi akhir
'******************************************************* **
'Nama fungsi: Buat MultiFolder
'Fungsi: Membuat direktori multi-level, Anda dapat membuat direktori root yang tidak ada
'Parameter: nama direktori yang akan dibuat, bisa bertingkat
'Kembalikan nilai logis: Benar jika berhasil, Salah jika gagal
'Buat direktori root dari direktori mulai dari direktori saat ini
'******************************************************* **
Fungsi BuatMultiFolder(ByVal CFolder)
Redupkan objFSO,PhCreateFolder,CreateFolderArray,CreateFolder
Redupkan i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo
BlInfo=Salah
BuatFolder = CFolder
Pada Kesalahan Lanjutkan Berikutnya
Setel objFSO = Server.CreateObject(Scri & pti & ng.Fil & eSyst & emOb & ject)
Jika Salah Lalu
Err.Hapus()
Fungsi Keluar
Akhiri Jika
CreateFolder = Ganti(CreateFolder,/,/)
Jika Kiri(BuatFolder,1)=/ Lalu
'BuatFolder = Kanan(BuatFolder,Len(BuatFolder)-1)
Akhiri Jika
Jika Benar(BuatFolder,1)=/ Lalu
CreateFolder = Kiri(CreateFolder,Len(CreateFolder)-1)
Akhiri Jika
CreateFolderArray = Pisahkan(BuatFolder,/)
Untuk i = 0 hingga UBound(CreateFolderArray)
BuatFolderSub =
Untuk ii = 0 sampai i
CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & /
Berikutnya
PhCreateFolderSub = Server.MapPath(CreateFolderSub)
'response.Tulis PhCreateFolderSub&<br>
Jika Bukan objFSO.FolderExists(PhCreateFolderSub) Lalu
objFSO.CreateFolder(PhCreateFolderSub)
Akhiri Jika
Berikutnya
Jika Salah Lalu
Err.Hapus()
Kalau tidak
BlInfo=Benar
Akhiri Jika
Setel objFSO=tidak ada
BuatMultiFolder = BlInfo
Fungsi Akhir
'*******************************************************
'Nama fungsi: FSOFileRead
'Fungsi: Gunakan FSO untuk membaca fungsi konten file
'Parameter: nama file ---- nama file
'Nilai pengembalian: konten file
'*******************************************************
fungsi FSOFileRead (nama file)
Redupkan objFSO,objCountFile,FiletempData
Setel objFSO = Server.CreateObject(Scripting.FileSystemObject)
Setel objCountFile = objFSO.OpenTextFile(Server.MapPath(nama file),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Tutup
Setel objCountFile=Tidak Ada
Setel objFSO = Tidak Ada
Fungsi Akhir
'*******************************************************
'Nama fungsi: FSOlineedit
'Fungsi: Gunakan FSO untuk membaca baris tertentu dari fungsi file
'Parameter: nama file ---- nama file
' lineNum ---- nomor baris
'Nilai kembalian: isi baris dalam file
'*******************************************************
fungsi FSOlineedit(nama file,Nomor baris)
jika linenum <1 maka keluar dari fungsi
redupkan fso,f,temparray,tempcnt
set fso = server.CreateObject(scripting.filesystemobject)
jika tidak fso.fileExists(server.mappath(nama file)) maka keluar dari fungsi
set f = fso.opentextfile(server.mappath(nama file),1)
jika bukan f.AtEndofStream maka
tempcnt = f.baca semua
f.tutup
atur f = tidak ada
temparray = split(tempcnt,chr(13)&chr(10))
jika lineNum>ubound(temparray)+1 maka
fungsi keluar
kalau tidak
FSOlineedit = temparray(barisNum-1)
berakhir jika
berakhir jika
fungsi akhir
'*******************************************************
'Nama fungsi: FSOlinewrite
'Fungsi: Gunakan FSO untuk menulis baris tertentu dari fungsi file
'Parameter: nama file ---- nama file
' lineNum ---- nomor baris
' Konten baris ---- konten
'Nilai pengembalian: Tidak ada
'*******************************************************
fungsi FSOlinewrite (nama file, LineNum, Linecontent)
jika linenum <1 maka keluar dari fungsi
redupkan fso,f,temparray,tempCnt
set fso = server.CreateObject(scripting.filesystemobject)
jika tidak fso.fileExists(server.mappath(nama file)) maka keluar dari fungsi
set f = fso.opentextfile(server.mappath(nama file),1)
jika bukan f.AtEndofStream maka
tempcnt = f.baca semua
f.tutup
temparray = split(tempcnt,chr(13)&chr(10))
jika lineNum>ubound(temparray)+1 maka
fungsi keluar
kalau tidak
temparray(lineNum-1) = konten baris
berakhir jika
tempcnt = gabung(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(nama file),true)
f.writetempcnt
berakhir jika
f.tutup
atur f = tidak ada
fungsi akhir
'*******************************************************
'Nama fungsi: Htmlmake
'Fungsi: Gunakan FSO untuk membuat file
'Parameter: HtmlFolder ---- jalur
' HtmlNama File ---- nama file
'HtmlKonten ---- Konten
'*******************************************************
fungsi Htmlmake(HtmlFolder,HtmlFilename,HtmlContent)
Pada Kesalahan Lanjutkan Berikutnya
jalur file redup, fso, fout
jalur file = HtmlFolder&/&HtmlNamaFile
Setel fso = Server.CreateObject(Scripting.FileSystemObject)
Jika fso.FolderExists(HtmlFolder) Lalu
Kalau tidak
Buat MultiFolder (HtmlFolder)
&, ;nbs, p; Berakhir Jika
Setel fout = fso.Createtextfile(server.mappath(filepath),true)
fout.writeline HtmlContent
fut.close
atur fso=tidak ada
Setel fso = Server.CreateObject(Scripting.FileSystemObject)
Jika fso.fileexists(Server.MapPath(filepath)) Lalu
Response.Tulis file<font color=red>&HtmlFilename&</font>telah dibuat!<br>
Kalau tidak
'Respon.Tulis Server.MapPath(jalur file)
File Response.Write<font color=red>&HtmlFilename&</font> tidak dibuat!<br>
Akhiri Jika
Tetapkan fso = tidak ada
Fungsi akhir
'*******************************************************
'Nama fungsi: Htmldel
'Fungsi: Gunakan FSO untuk menghapus file
'Parameter: HtmlFolder ---- jalur
' HtmlNama File ---- nama file
'*******************************************************
Sub Htmldel(HtmlFolder,HtmlNamaFile)
jalur file redup, jika tidak
jalur file = HtmlFolder&/&HtmlNamaFile
Setel fso = CreateObject(Scripting.FileSystemObject)
fso.DeleteFile(Server.mappath(jalur file))
Tetapkan fso = tidak ada
Setel fso = Server.CreateObject(Scripting.FileSystemObject)
Jika fso.fileexists(Server.MapPath(filepath)) Lalu
File Response.Write<font color=red>&HtmlFilename&</font>tidak dihapus!<br>
Kalau tidak
'Respon.Tulis Server.MapPath(jalur file)
Response.Write file<font color=red>&HtmlFilename&</font> telah dihapus!<br>
Akhiri Jika
Tetapkan fso = tidak ada
Akhiri Sub
' ===== =
'Nama proses: HTMLEncode
'Fungsi: memfilter format HTML
'Parameter: fString ---- Konten konversi
' ===== =
fungsi HTMLEncode(ByVal fString)
Jika IsNull(fString)=False atau fString<> atau fString<>$False$ Lalu
fString = Ganti(fString, >, >)
fString = Ganti(fString, <, <)
fString = Ganti(fString, Chr(32), )
fString = Ganti(fString, Chr(9), )
fString = Ganti(fString, Chr(34), )
fString = Ganti(fString, Chr(39), ')
fString = Ganti(fString, Chr(13), )
fString = Ganti(fString, , )
fString = Ganti(fString, CHR(10) & CHR(10), </P><P>)
fString = Ganti(fString, Chr(10), <br /> )
HTMLEncode = fString
kalau tidak
HTMLEncode = $Salah$
berakhir jika
fungsi akhir
' ===== =
'Nama proses: unHTMLEncode
'Fungsi: mengembalikan format HTML
'Parameter: fString ---- Konten konversi
' ===== =
fungsi unHTMLEncode(ByVal fString)
Jika IsNull(fString)=False atau fString<> atau fString<>$False$ Lalu
fString = Ganti(fString, >, >)
fString = Ganti(fString, <, <)
fString = Ganti(fString, , Chr(32))
fString = Ganti(fString, , Chr(34))
fString = Ganti(fString, ', Chr(39))
fString = Ganti(fString, , Chr(13))
fString = Ganti(fString, , )
fString = Ganti(fString, </P><P> , CHR(10) & CHR(10))
fString = Ganti(fString, <br> , Chr(10))
unHTMLEncode = fString
kalau tidak
unHTMLEncode = $Salah$
berakhir jika
fungsi akhir
fungsi unhtmllist(konten)
unhtmldaftar=konten
jika konten <> maka
unhtmldaftar=ganti(unhtmldaftar,',;)
unhtmldaftar=ganti(unhtmldaftar,chr(10),)
unHtmllist=ganti(unHtmllist,chr(13),<br>)
berakhir jika
fungsi akhir
fungsi unhtmldaftar(konten)
unhtmldaftar=konten
jika konten <> maka
unhtmldaftar=ganti(unhtmldaftar,,)
unhtmldaftar=ganti(unhtmldaftar,',)
unhtmldaftar=ganti(unhtmldaftar,chr(10),)
unHtmllists=ganti(unHtmllists,chr(13),<br>)
berakhir jika
fungsi akhir
fungsi daftar html (konten)
htmldaftar=konten
jika konten <> maka
htmldaftar=ganti(htmldaftar,'',)
htmldaftar=ganti(htmldaftar,,')
htmldaftar=ganti(htmldaftar,<br>,chr(13)&chr(10))
berakhir jika
fungsi akhir
fungsi daftar uhtml(konten)
uhtmldaftar=konten
jika konten <> maka
uhtlists=ganti(uhtlists,,'')
uhtlists=ganti(uhtlists,',;)
uhtlists=ganti(uhtlists,chr(10),)
uHtmllists=ganti(uHtmllists,chr(13),<br>)
berakhir jika
fungsi akhir
' ===== =
'Proses: Tidur
'Fungsi: Program berhenti di sini selama beberapa detik
'Parameter: iSeconds Jumlah detik untuk jeda
' ===== =
Sub Tidur (iSeconds)
respon.Tulis <font color=blue>Mulai jeda selama &iSeconds& detik</font><br>
Redupkan t:t=Timer()
While(Timer()<t+iSeconds)
'Jangan lakukan apa pun
Pergi ke
respon.Tulis <font color=blue>Jeda&iSeconds& detik berakhir</font><br>
Akhiri Sub
' ===== = =
'Nama fungsi: MyArray
'Fungsi: mengekstrak tag untuk dipisahkan
'Parameter: ConStr ------Ekstrak karakter asli alamat
' ===== = =
Fungsi MyArray(ByvalConStr)
Setel objRegExp = Regexp Baru
objRegExp.IgnoreCase = Benar
objRegExp.Global = Benar
objRegExp.Pattern = ({).+?(})
Tetapkan Kecocokan =objRegExp.Execute(ConStr)
Untuk Setiap Pertandingan dalam Pertandingan
TempStr=TempStr & & Cocok.Nilai
Berikutnya
Tetapkan Kecocokan=tidak ada
TempStr=Kanan(TempStr,Len(TempStr)-1)
objRegExp.Pola ={
TempStr=objRegExp.Ganti(TempStr,)
objRegExp.Pattern =}
TempStr=objRegExp.Ganti(TempStr,)
Setel objRegExp=tidak ada
Tetapkan Kecocokan=tidak ada
TempStr=Ganti(TempStr,$,)
Jika TempStr= maka
MyArray=Tidak ada yang perlu diekstrak dalam kode
Kalau tidak
Array Saya=TempStr
Berakhir jika
Fungsi Akhir
' ===== = =
'Nama fungsi: acak
'Fungsi: Menghasilkan angka acak 6 digit
' ===== = =
Fungsi acak
mengacak
acak=Int((900000*rnd)+100000)
Fungsi Akhir
%>