В этой статье представлен полный набор функций сбора данных ASP, включая такие функции, как извлечение исходных символов адреса, сохранение удаленных файлов в локальный имитируемый вход и получение исходного кода веб-страницы.
Скопируйте код кода следующим образом:
'============================================== = =
'Имя функции: GetHttpPage
'Функция: получить исходный код веб-страницы
'Параметр: HttpUrl ------ Адрес веб-страницы
'============================================== = =
Функция GetHttpPage(HttpUrl)
Если IsNull(HttpUrl)=True Или Len(HttpUrl)<18 Или HttpUrl="$False$" Тогда
GetHttpPage="$False$"
Выход из функции
Конец, если
Дим HTTP
Установите Http=server.createobject("MSX" & "ML2.XM" & "LHT" & "TP")
Http.open "GET", HttpUrl, False
HTTP.Отправить()
Если Http.Readystate<>4, то
Установить HTTP=Ничего
GetHttpPage="$False$"
Функция выхода
Конец, если
GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")
GetHTTPPage=replace(replace(GetHTTPPage , vbCr,""),vbLf,"")
Установить HTTP=Ничего
Если номер ошибки<>0, то
Ошиб.Очистить
Конец, если
Конечная функция
'============================================== = =
'Имя функции: BytesToBstr
'Функция: конвертировать полученный исходный код в китайский
'Параметр: Тело ------Переменная для преобразования
'Параметр: Cset ------тип для преобразования
'============================================== = =
Функция BytesToBstr(Body,Cset)
Дим Обжстрим
Set Objstream = Server.CreateObject("ad" & "odb.str" & "eam")
objstream.Type = 1
objstream.Mode =3
objstream.Открыть
objstream.Напишите тело
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
установить objstream = ничего
Конечная функция
'============================================== = =
'Имя функции: PostHttpPage
'Функция: вход
'============================================== = =
Функция PostHttpPage(RefererUrl,PostUrl,PostData)
DimxmlHttp
ДимРетСтр
Установите xmlHttp = CreateObject("Msx" & "ml2.XM" & "LHT" & "TP")
xmlHttp.Open «POST», PostUrl, False
XmlHTTP.setRequestHeader "Длина контента", Len(PostData)
xmlHttp.setRequestHeader «Тип контента», «application/x-www-form-urlencoded»
xmlHttp.setRequestHeader «Referer», RefererUrl
xmlHttp.Отправить данные сообщения
Если Номер ошибки <> 0 Тогда
Установить xmlHttp=Ничего
PostHttpPage = "$False$"
Выход из функции
Конец, если
PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")
Установить xmlHttp = ничего
Конечная функция
'============================================== = =
'Имя функции: UrlEncoding
'Функция: конвертировать кодировку
'============================================== = =
Функция UrlEncoding(DataStr)
Dim StrReturn, Si, ThisChr, InnerCode, High8, Low8
СтрReturn = ""
Для Si = 1 To Len(DataStr)
ThisChr = Mid(DataStr,Si,1)
Если Abs(Asc(ThisChr)) < &HFF Тогда
StrReturn = StrReturn & ThisChr
Еще
ВнутреннийКод = Asc(ThisChr)
Если Внутренний Код < 0 Тогда
Внутренний код = Внутренний код + &H10000
Конец, если
Высота8 = (Внутренний код и &HFF00)/&HFF
Low8 = внутренний код и &HFF
StrReturn = StrReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)
Конец, если
Следующий
URLEncoding = StrReturn
Конечная функция
'============================================== = =
'Имя функции: GetBody
'Функция: перехватить строку
'Параметр: ConStr ------Строка, которую необходимо перехватить.
'Параметр: StartStr ------ начальная строка
'Параметр: OverStr ------Конечная строка
'Параметр: IncluL ------Включен ли StartStr
'Параметр:IncluR ------включать ли OverStr
'============================================== = =
Функция GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)
Если ConStr="$False$" или ConStr="" или IsNull(ConStr)=True или StartStr="" или IsNull(StartStr)=True или OverStr="" или IsNull(OverStr)=True Тогда
GetBody="$False$"
Выход из функции
Конец, если
ДимКонСтрТемп
Тусклый старт, окончено
ConStrTemp=Lcase(ConStr)
StartStr=Lcase(StartStr)
OverStr=Lcase(OverStr)
Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
Если Начало<=0, то
GetBody="$False$"
Выход из функции
Еще
Если IncluL=False Тогда
Старт=Старт+LenB(СтартСтр)
Конец, если
Конец, если
Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
Если Over<=0 или Over<=Start, то
GetBody="$False$"
Выход из функции
Еще
Если InclR=True Тогда
Over=Over+LenB(OverStr)
Конец, если
Конец, если
GetBody=MidB(ConStr,Start,Over-Start)
Конечная функция
'============================================== = =
'Имя функции: GetArray
'Функция: извлечь адрес ссылки, разделенный $Array$
'Параметр: ConStr ------Извлечение исходных символов адреса
'Параметр: StartStr ------ начальная строка
'Параметр: OverStr ------Конечная строка
'Параметр: IncluL ------Включен ли StartStr
'Параметр:IncluR ------включать ли OverStr
'============================================== = =
Функция GetArray(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
Если ConStr="$False$" или ConStr="" Или IsNull(ConStr)=True или StartStr="" Или OverStr="" или IsNull(StartStr)=True или IsNull(OverStr)=True Тогда
GetArray="$False$"
Выход из функции
Конец, если
Dim TempStr, TempStr2, objRegExp, совпадения, совпадение
ТемпСтр=""
Установить objRegExp = Новое регулярное выражение
objRegExp.IgnoreCase = Истина
objRegExp.Global = Истина
objRegExp.Pattern = "("&StartStr&").+?("&OverStr&")"
Установить совпадения =objRegExp.Execute(ConStr)
За каждый матч в матчах
TempStr=TempStr & "$Array$" & Match.Value
Следующий
Установить совпадения = ничего
Если ТемпСтр="" Тогда
GetArray="$False$"
Выход из функции
Конец, если
TempStr=Вправо(TempStr,Len(TempStr)-7)
Если IncluL=False, то
objRegExp.Pattern =НачСтрока
TempStr=objRegExp.Replace(TempStr,"")
Конец, если
Если InclR=False, то
objRegExp.Pattern =OverStr
TempStr=objRegExp.Replace(TempStr,"")
Конец, если
Установить objRegExp=ничего
Установить совпадения = ничего
TempStr=Заменить(TempStr,"""","")
TempStr=Заменить(TempStr,"'","")
TempStr=Заменить(TempStr," ","")
TempStr=Заменить(TempStr,"(","")
TempStr=Заменить(TempStr,")","")
Если TempStr="" тогда
GetArray="$False$"
Еще
GetArray=ТемпСтр
Конец, если
Конечная функция
'============================================== = =
'Имя функции: DefiniteUrl
'Функция: преобразовать относительный адрес в абсолютный адрес.
'Параметр: PrimitiveUrl ------ относительный адрес для преобразования
'Параметр: ConsultUrl ------ адрес текущей веб-страницы
'============================================== = =
Функция DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Тусклый ConTemp, PriTemp, Pi, Ci, PriArray, ConArray
Если PrimitiveUrl="" или ConsultUrl="" или PrimitiveUrl="$False$" или ConsultUrl="$False$" Тогда
DefiniteUrl="$False$"
Выход из функции
Конец, если
Если Left(Lcase(ConsultUrl),7)<>"http://" Тогда
ConsultUrl = "http://" & ConsultUrl
Конец, если
ConsultUrl=Заменить(ConsultUrl,"/","/")
ConsultUrl=Replace(ConsultUrl,"://","://")
PrimitiveUrl=Заменить(PrimitiveUrl,"/","/")
Если Правильно(ConsultUrl,1)<>"/" Тогда
Если Instr(ConsultUrl,"/")>0 Тогда
Если Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0, то
Еще
ConsultUrl=ConsultUrl & "/"
Конец, если
Еще
ConsultUrl=ConsultUrl & "/"
Конец, если
Конец, если
ConArray=Split(ConsultUrl,"/")
Если Left(LCase(PrimitiveUrl),7) = "http://", то
DefiniteUrl=Replace(PrimitiveUrl,"://","://")
ElseIf Left(PrimitiveUrl,1) = "/" Тогда
DefiniteUrl=ConArray(0) и PrimitiveUrl
ElseIf Left(PrimitiveUrl,2)="./" Тогда
PrimitiveUrl=Вправо(PrimitiveUrl,Len(PrimitiveUrl)-2)
Если Верно(ConsultUrl,1)="/" Тогда
DefiniteUrl=ConsultUrl и PrimitiveUrl
Еще
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
Конец, если
ElseIf Left(PrimitiveUrl,3)="../" тогда
Делать, пока слева(PrimitiveUrl,3)="../"
PrimitiveUrl=Вправо(PrimitiveUrl,Len(PrimitiveUrl)-3)
Пи=Пи+1
Петля
От Ci=0 до (Ubound(ConArray)-1-Pi)
Если DefiniteUrl<>"" Тогда
DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
Еще
DefiniteUrl=ConArray(Ci)
Конец, если
Следующий
DefiniteUrl=DefiniteUrl & "/" и PrimitiveUrl
Еще
Если Instr(PrimitiveUrl,"/")>0 Тогда
PriArray=Split(PrimitiveUrl,"/")
Если Instr(PriArray(0),".")>0 Тогда
Если Правильно(PrimitiveUrl,1)="/" Тогда
DefiniteUrl="http://" и PrimitiveUrl
Еще
Если Instr(PriArray(Ubound(PriArray)-1),".")>0 Тогда
DefiniteUrl="http://" и PrimitiveUrl
Еще
DefiniteUrl="http://" и PrimitiveUrl & "/"
Конец, если
Конец, если
Еще
Если Верно(ConsultUrl,1)="/" Тогда
DefiniteUrl=ConsultUrl и PrimitiveUrl
Еще
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
Конец, если
Конец, если
Еще
Если Instr(PrimitiveUrl,".")>0 Тогда
Если Верно(ConsultUrl,1)="/" Тогда
Если правильно(LCase(PrimitiveUrl),3)=".cn" или right(LCase(PrimitiveUrl),3)="com" или right(LCase(PrimitiveUrl),3)="net" или right(LCase(PrimitiveUrl) ,3)="org" Тогда
DefiniteUrl="http://" и PrimitiveUrl & "/"
Еще
DefiniteUrl=ConsultUrl и PrimitiveUrl
Конец, если
Еще
Если правильно(LCase(PrimitiveUrl),3)=".cn" или right(LCase(PrimitiveUrl),3)="com" или right(LCase(PrimitiveUrl),3)="net" или right(LCase(PrimitiveUrl) ,3)="org" Тогда
DefiniteUrl="http://" и PrimitiveUrl & "/"
Еще
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
Конец, если
Конец, если
Еще
Если Верно(ConsultUrl,1)="/" Тогда
DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
Еще
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
Конец, если
Конец, если
Конец, если
Конец, если
Если Left(DefiniteUrl,1)="/", то
DefiniteUrl=Вправо(DefiniteUrl,Len(DefiniteUrl)-1)
Конец, если
Если DefiniteUrl<>"" Тогда
DefiniteUrl=Заменить(DefiniteUrl,"//","/")
DefiniteUrl=Replace(DefiniteUrl,"://","://")
Еще
DefiniteUrl="$False$"
Конец, если
Конечная функция
'============================================== = =
'Имя функции: replaceSaveRemoteFile
'Функция: замена и сохранение удаленных изображений
'Параметр: ConStr ------ заменяемая строка
'Параметр: SaveTf ------ Сохранять ли файл, False не сохраняет, True сохраняет
'Параметр: TistUrl ------ адрес текущей веб-страницы.
'============================================== = =
Функция replaceSaveRemoteFile(ConStr,InstallPath,strChannelDir,SaveTf,TistUrl)
Если ConStr="$False$" или ConStr="" или InstallPath="" или strChannelDir="" Тогда
replaceSaveRemoteFile=ConStr
Выход из функции
Конец, если
Dim TempStr, TempStr2, TempStr3, Re, Matches, Match, Tempi, TempArray, TempArray2
Установить Re = Новое регулярное выражение
Re.IgnoreCase = Истина
Re.Global = Истина
Re.Pattern ="<img.+?>"
Установить совпадения =Re.Execute(ConStr)
За каждый матч в матчах
Если TempStr<>"" тогда
TempStr=TempStr & "$Array$" & Match.Value
Еще
TempStr=Соответствие.Значение
Конец, если
Следующий
Если TempStr<>"" Тогда
TempArray=Split(TempStr,"$Array$")
ТемпСтр=""
Для Tempi = 0 в Ubound (TempArray)
Re.Pattern ="src/s*=/s*.+?/.(gifjpgbmpjpegpsdpngsvgdxfwmftiff)"
Установить совпадения =Re.Execute(TempArray(Tempi))
За каждый матч в матчах
Если TempStr<>"" тогда
TempStr=TempStr & "$Array$" & Match.Value
Еще
TempStr=Соответствие.Значение
Конец, если
Следующий
Следующий
Конец, если
Если TempStr<>"" Тогда
Re.Pattern="src/s*=/s*"
TempStr=Re.Replace(TempStr,"")
Конец, если
Установить совпадения = ничего
Установить Re=ничего
Если TempStr="" или IsNull(TempStr)=True Тогда
replaceSaveRemoteFile=ConStr
Функция выхода
Конец, если
TempStr=Заменить(TempStr,"""","")
TempStr=Заменить(TempStr,"'","")
TempStr=Заменить(TempStr," ","")
Dim RemoteFileurl, SavePath, PathTemp, DtNow, strFileName, strFileType, ArrSaveFileName, RanNum, Arr_Path
DtNow=Сейчас()
'*********************************
Если SaveTf=True, тогда
SavePath=InstallPath&strChannelDir
Если CheckDir(InstallPath & strChannelDir)=False Тогда
Если не CreateMultiFolder(InstallPath & strChannelDir), Тогда
ответ. Напишите InstallPath & strChannelDir&"Не удалось создать каталог"
SaveTf=False
Конец, если
Конец, если
Конец, если
«Начнем с удаления дубликатов изображений
TempArray=Split(TempStr,"$Array$")
ТемпСтр=""
Для Tempi = 0 в Ubound (TempArray)
Если Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Тогда
TempStr=TempStr & "$Array$" & TempArray(Tempi)
Конец, если
Следующий
TempStr=Вправо(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'Удалите дубликаты изображений и завершите
ответ. Напишите "<br>Найдено изображение:<br>"&Replace(TempStr,"$Array$","<br>")
'Начать преобразование относительных адресов изображений
ТемпСтр=""
Для Tempi = 0 в Ubound (TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Следующий
TempStr=Вправо(TempStr,Len(TempStr)-7)
TempStr=Replace(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
ТемпСтр=""
'Конец преобразования относительного адреса изображения
'Замена/сохранение изображения
Установить Re = Новое регулярное выражение
Re.IgnoreCase = Истина
Re.Global = Истина
Для Tempi = 0 в Ubound (TempArray2)
'*********************************
RemoteFileUrl=TempArray2(Темпи)
Если RemoteFileUrl<>"$False$" и SaveTf=True, то сохраните изображение.
ArrSaveFileName = Split(RemoteFileurl,".")
strFileType=Lcase(ArrSaveFileName(Ubound(ArrSaveFileName)))'Тип файла
Если strFileType="asp" или strFileType="asa" или strFileType="aspx" или strFileType="cer" или strFileType="cdx" или strFileType="exe" или strFileType="rar" или strFileType="zip", то
ЗагрузитьФайлы=""
replaceSaveRemoteFile=ConStr
Выход из функции
Конец, если
Рандомизировать
RanNum=Int(900*Rnd)+100
strFileName = год(DtNow) & вправо("0" и месяц(DtNow),2) & вправо("0" и день(DtNow),2) & вправо("0" и час(DtNow) ),2) & right ("0" & минута(DtNow),2) & right("0" & секунда(DtNow),2) & ranNum & "." & strFileType
Re.Pattern =TempArray(Темпи)
ответ. Напишите «<br>Сохранить по локальному адресу:»&InstallPath & strChannelDir & strFileName
Если SaveRemoteFile(InstallPath & strChannelDir & strFileName,RemoteFileUrl,RemoteFileUrl)=True Тогда
ответ. Напишите «<font color=blue>Успех</font><br>»
PathTemp = Путь установки & strChannelDir & strFileName
ConStr=Re.Replace(ConStr,PathTemp)
Re.Pattern=InstallPath&strChannelDir
UploadFiles=UploadFiles & "" & InstallPath & strChannelDir & strFileName
Еще
PathTemp=RemoteFileUrl
ConStr=Re.Replace(ConStr,PathTemp)
Конец, если
ElseIf RemoteFileurl<>"$False$" и SaveTf=False Тогда не сохранять изображение
Re.Pattern =TempArray(Темпи)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Конец, если
'*********************************
Следующий
Установить Re=ничего
replaceSaveRemoteFile=ConStr
Конечная функция
'============================================== = =
'Имя функции: replaceSwfFile
'Функция: анализ пути анимации
'Параметр: ConStr ------ заменяемая строка
'Параметр: TistUrl ------ адрес текущей веб-страницы.
'============================================== = =
Функция replaceSwfFile(ConStr,TistUrl)
Если ConStr="$False$" или ConStr="" или TistUrl="" или TistUrl="$False$" Тогда
replaceSwfFile=ConStr
Выход из функции
Конец, если
Dim TempStr, TempStr2, TempStr3, Re, Matches, Match, Tempi, TempArray, TempArray2
Установить Re = Новое регулярное выражение
Re.IgnoreCase = Истина
Re.Global = Истина
Re.Pattern ="<object.+?[^/>]>"
Установить совпадения =Re.Execute(ConStr)
За каждый матч в матчах
Если TempStr<>"" тогда
TempStr=TempStr & "$Array$" & Match.Value
Еще
TempStr=Соответствие.Значение
Конец, если
Следующий
Если TempStr<>"" Тогда
TempArray=Split(TempStr,"$Array$")
ТемпСтр=""
Для Tempi = 0 в Ubound (TempArray)
Re.Pattern ="значение/s*=/s*.+?/.swf"
Установить совпадения =Re.Execute(TempArray(Tempi))
За каждый матч в матчах
Если TempStr<>"" тогда
TempStr=TempStr & "$Array$" & Match.Value
Еще
TempStr=Соответствие.Значение
Конец, если
Следующий
Следующий
Конец, если
Если TempStr<>"" Тогда
Re.Pattern ="значение/s*=/s*"
TempStr=Re.Replace(TempStr,"")
Конец, если
Если TempStr="" или IsNull(TempStr)=True Тогда
replaceSwfFile=ConStr
Функция выхода
Конец, если
TempStr=Заменить(TempStr,"""","")
TempStr=Заменить(TempStr,"'","")
TempStr=Заменить(TempStr," ","")
Установить совпадения = ничего
Установить Re=ничего
'Начнем с удаления дубликатов файлов
TempArray=Split(TempStr,"$Array$")
ТемпСтр=""
Для Tempi = 0 в Ubound (TempArray)
Если Instr(Lcase(TempStr),Lcase(TempArray(Tempi)))<1 Тогда
TempStr=TempStr & "$Array$" & TempArray(Tempi)
Конец, если
Следующий
TempStr=Вправо(TempStr,Len(TempStr)-7)
TempArray=Split(TempStr,"$Array$")
'Удаляем дубликаты файлов и завершаем
'Начало преобразования относительных адресов
ТемпСтр=""
Для Tempi = 0 в Ubound (TempArray)
TempStr=TempStr & "$Array$" & DefiniteUrl(TempArray(Tempi),TistUrl)
Следующий
TempStr=Вправо(TempStr,Len(TempStr)-7)
TempStr=Replace(TempStr,Chr(0),"")
TempArray2=Split(TempStr,"$Array$")
ТемпСтр=""
'Конец преобразования относительного адреса
'заменять
Установить Re = Новое регулярное выражение
Re.IgnoreCase = Истина
Re.Global = Истина
Для Tempi = 0 в Ubound (TempArray2)
RemoteFileUrl=TempArray2(Темпи)
Re.Pattern =TempArray(Темпи)
ConStr=Re.Replace(ConStr,RemoteFileUrl)
Следующий
Установить Re=ничего
replaceSwfFile=ConStr
Конечная функция
'============================================== = =
'Имя процесса: SaveRemoteFile
'Функция: сохранять удаленные файлы на локальном
'Параметр: LocalFileName ------ имя локального файла
'Параметр: RemoteFileUrl ------ URL-адрес удаленного файла
'Параметр: Referer ------ Файл удаленного вызова (для антисбора используйте адрес страницы контента, оставьте его пустым, если нет антисбора)
'============================================== = =
Функция SaveRemoteFile(LocalFileName,RemoteFileUrl,Referer)
SaveRemoteFile=Истина
тусклые объявления, извлечение, GetRemoteData
Установить получение = Server.CreateObject("Microsoft.XMLHTTP")
С поиском
.Откройте «Получить», RemoteFileUrl, False, «», «»
если Referer<>"" то .setRequestHeader "Referer",Referer
.Отправлять
Если .Readystate<>4, то
SaveRemoteFile=False
Выход из функции
Конец, если
GetRemoteData = .ResponseBody
Конец с
Установить получение = Ничего
Установить рекламу = Server.CreateObject("Adodb.Stream")
С рекламой
.Тип = 1
.Открыть
.Напишите GetRemoteData
.SaveToFile server.MapPath(LocalFileName),2
.Отмена()
.Закрывать()
Конец с
Установить рекламу = ничего
Конечная функция
'============================================== = =
'Имя функции: GetPaing
'Функция: получить нумерацию страниц
'============================================== = =
Функция GetPaing(Byval ConStr,StartStr,OverStr,IncluL,IncluR)
Если ConStr="$False$" или ConStr="" Или StartStr="" Или OverStr="" или IsNull(ConStr)=True или IsNull(StartStr)=True или IsNull(OverStr)=True Тогда
GetPaing="$False$"
Выход из функции
Конец, если
Тусклый старт, Конец, ConTemp, TempStr
TempStr=LCase(ConStr)
StartStr=LCase(StartStr)
OverStr=LCase(OverStr)
Over=Instr(1,TempStr,OverStr)
Если Больше<=0 Тогда
GetPaing="$False$"
Выход из функции
Еще
Если InclR=True Тогда
Over=Over+Len(OverStr)
Конец, если
Конец, если
TempStr=Средне(TempStr,1,Более)
Start=InstrRev(TempStr,StartStr)
Если IncluL=False Тогда
Старт=Старт+Len(СтартСтр)
Конец, если
Если Start<=0 или Start>=Over Тогда
GetPaing="$False$"
Выход из функции
Конец, если
ConTemp=Mid(ConStr,Start,Over-Start)
ConTemp=Обрезать(ConTemp)
'ConTemp=Replace(ConTemp," ","")
ConTemp=Заменить(ConTemp,",","")
ConTemp=Заменить(ConTemp,"'","")
ConTemp=Заменить(ConTemp,"""","")
ConTemp=Заменить(ConTemp,">","")
ConTemp=Replace(ConTemp,"<","")
ConTemp=Заменить(ConTemp," ;","")
GetPaing=ConTemp
Конечная функция
'************************************************
'Имя функции: gotTopic
'Функция: обрезать строку, каждый китайский символ считается за два символа, а английский символ считается за один символ.
'Параметр: str ---- исходная строка
' strlen ---- длина перехвата
'Возвращаемое значение: перехваченная строка
'************************************************
функция gotTopic(str,strlen)
если ул="" тогда
gotTopic=""
функция выхода
конец, если
дим л, т, с, я
str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
л=лен(стр)
т=0
для я = от 1 до л
c=Abs(Asc(Mid(str,i,1)))
если с>255, то
т=т+2
еще
т=т+1
конец, если
если t>=strlen тогда
gotTopic=left(str,i) & "…"
выход для
еще
gotTopic=str
конец, если
следующий
gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<;")
конечная функция
'*********************************************
'Имя функции: JoinChar
'Функция: Добавить ? или & к адресу
'Параметр: strUrl ---- URL
'Возвращаемое значение: URL с добавлением ?
'*********************************************
функция JoinChar (strUrl)
если стрUrl="" тогда
ДжойнЧар=""
функция выхода
конец, если
если InStr(strUrl,"?")<len(strUrl) тогда
если InStr(strUrl,"?")>1, то
если InStr(strUrl,"&")<len(strUrl) тогда
JoinChar=strUrl & "&"
еще
JoinChar=strUrl
конец, если
еще
JoinChar=strUrl & "?"
конец, если
еще
JoinChar=strUrl
конец, если
конечная функция
'********************************************** *
'Имя функции: CreateKeyWord
'Функция: генерировать ключевые слова из заданной строки
'Параметр: Constr --- исходная строка для генерации ключевого слова
'Возвращаемое значение: сгенерированное ключевое слово
'********************************************** *
Функция CreateKeyWord(byval Constr,Num)
Если Constr="" или IsNull(Constr)=True или Constr="$False$" Тогда
CreateKeyWord="$False$"
Выход из функции
Конец, если
Если Num="" или IsNumeric(Num)=False Тогда
Число=2
Конец, если
Constr=Replace(Constr,CHR(32),"")
Constr=Replace(Constr,CHR(9),"")
Constr=Replace(Constr," ","")
Constr=Replace(Constr," ","")
Constr=Заменить(Constr,"(","")
Constr=Заменить(Constr,")","")
Constr=Replace(Constr,"<","")
Constr=Replace(Constr,">","")
Constr=Replace(Constr,"""","")
Constr=Replace(Constr,"?","")
Constr=Replace(Constr,"*","")
Constr=Заменить(Constr,"","")
Constr=Заменить(Constr,",","")
Constr=Replace(Constr,".","")
Constr=Replace(Constr,"/","")
Constr=Replace(Constr,"/","")
Constr=Заменить(Constr,"-","")
Constr=Replace(Constr,"@","")
Constr=Replace(Constr,"#","")
Constr=Replace(Constr,"$","")
Constr=Replace(Constr,"%","")
Constr=Заменить(Constr,"&","")
Constr=Заменить(Constr,"+","")
Constr=Replace(Constr,":","")
Constr=Replace(Constr,"：","")
Constr=Replace(Constr,"'","")
Constr=Replace(Constr,""","")
Constr=Replace(Constr,""","")
Dim i,ConstrTemp
Для i=1 To Len(Constr)
ConstrTemp=ConstrTemp & "" & Mid(Constr,i,Num)
Следующий
Если Len(ConstrTemp)<254 Тогда
ConstrTemp=ConstrTemp & ""
Еще
ConstrTemp=Влево(ConstrTemp,254) & ""
Конец, если
CreateKeyWord=ConstrTemp
Конечная функция
'============================================== = =
'Имя функции: CheckUrl
'Функция: проверить URL-адрес
'Параметр: strUrl ------ Чтобы проверить URL-адрес
'============================================== = =
Функция CheckUrl(strUrl)
Дим Ре
Установить Re=новое регулярное выражение
Re.IgnoreCase=истина
Re.Global=Истина
Re.Pattern="http://([/w-]+/.)+[/w-]+(/[/w-./?%&=]*)?"
Если Re.test(strUrl)=True Тогда
CheckUrl=strUrl
Еще
CheckUrl="$False$"
Конец, если
Установить Rs=Ничего
Конечная функция
'============================================== = =
'Имя функции: ScriptHtml
'Функция: фильтровать html-теги
'Параметр: ConStr ------ Строка, подлежащая фильтрации.
'============================================== = =
Функция ScriptHtml(Byval ConStr,TagName,FType)
Дим Ре
Установить Re=новое регулярное выражение
Re.IgnoreCase=истина
Re.Global=Истина
Выберите Case FType
Случай 1
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Случай 2
Re.Pattern="<" & TagName & "([^>])*>.*?</" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Случай 3
Re.Pattern="<" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Re.Pattern="</" & TagName & "([^>])*>"
ConStr=Re.Replace(ConStr,"")
Конец выбора
ScriptHtml=ConStr
Установить Re=Ничего
Конечная функция
'============================================== = =
'Имя функции: RemoveHTML
'Функция: полностью удалить html-теги
'Параметр: strHTML ------ Строка, подлежащая фильтрации.
'============================================== = =
Функция RemoveHTML(strHTML)
Dim objRegExp, Матч, Совпадения
Установить objRegExp = Новое регулярное выражение
objRegExp.IgnoreCase = Истина
objRegExp.Global = Истина
'Получить закрытый <>
objRegExp.Pattern = "<.+?>"
'Соответствовать
Установить совпадения = objRegExp.Execute(strHTML)
' Проходим соответствующий набор и заменяем соответствующие элементы
За каждый матч в матчах
strHtml=Заменить(strHTML,Match.Value,"")
Следующий
RemoveHTML=strHTML
Установить objRegExp = Ничего
Конечная функция
'============================================== = =
'Имя функции: CheckDir
'Функция: проверить, существует ли папка
'Параметр: FolderPath ------ путь к папке
'============================================== = =
Функция CheckDir (byval FolderPath)
тусклый фсо
Установите fso = Server.CreateObject("Scripting.FileSystemObject")
Если fso.FolderExists(Server.MapPath(путь к папке)) то
'существовать
ЧекДир = Истина
Еще
'не существует
ЧекДир = Ложь
Конец, если
Установите fso = ничего
Конечная функция
'============================================== = =
'Имя функции: MakeNewsDir
'Функция: создать папку
'Параметр: имя папки ------ имя папки
'============================================== = =
Функция MakeNewsDir (имя_папки)
тусклый фсо
Установите fso = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
fso.CreateFolder(Server.MapPath(имя папки))
Если fso.FolderExists(Server.MapPath(имя папки)) Тогда
MakeNewsDir = Истина
Еще
MakeNewsDir = Ложь
Конец, если
Установите fso = ничего
Конечная функция
'============================================== = =
'Имя функции: DelDir
'Функция: создать папку
'Параметр: имя папки ------ имя папки
'============================================== = =
Функция DelDir (имя_папки)
тусклый фсо
Установите fso = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
If fso.FolderExists(Server.MapPath(имя папки)) Тогда 'Определить, существует ли папка
fso.DeleteFolder (Server.MapPath(имя папки)) 'Удалить папку
Конец, если
Установите fso = ничего
Конечная функция
'********************************************** *
'Имя функции: IsObjInstalled
'Функция: Проверить, установлен ли компонент
'Параметр: strClassString ---- имя компонента
'Возвращаемое значение: True ---- Уже установлено
' Ложь ---- не установлено
'********************************************** *
Функция IsObjInstalled(strClassString)
IsObjInstalled = Ложь
Ошибка = 0
Димкстестобдж
Установите xTestObj = Server.CreateObject(strClassString)
Если 0 = Ошибка, Тогда IsObjInstalled = Истина
Установить xTestObj = Ничего
Ошибка = 0
Конечная функция
'********************************************** *
'Имя функции: strLength
'Функция: найти длину строки. Китайские иероглифы считаются за два символа, а английские иероглифы считаются за один символ.
'Параметр: str ----Строка необходимой длины
'Возвращаемое значение: длина строки
'********************************************** *
функция strLength(str)
ПРИ ОШИБКЕ ВОЗОБНОВИТЬ СЛЕДУЮЩИЙ
тусклый WINNT_CHINESE
WINNT_CHINESE = (len("Китай")=2)
если WINNT_CHINESE тогда
тусклый л, т, с
тусклый я
л=лен(стр)
т=л
для я = от 1 до л
c=asc(mid(str,i,1))
если c<0, то c=c+65536
если с>255, то
т=т+1
конец, если
следующий
strLength=t
еще
strLength=len(str)
конец, если
если err.number<>0, то err.clear
конечная функция
'********************************************** * **
'Имя функции: CreateMultiFolder
'Функция: создание многоуровневых каталогов, вы можете создавать несуществующие корневые каталоги.
'Параметр: имя создаваемого каталога, который может быть многоуровневым
'Возвращаем логическое значение: True в случае успеха, False в случае неудачи.
'Создаем корневой каталог каталога, начиная с текущего каталога
'********************************************** * **
Функция CreateMultiFolder(ByVal CFolder)
Тусклый objFSO,PhCreateFolder,CreateFolderArray,CreateFolder
Dim i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo
БлИнфо=Ложь
CreateFolder = Cфолдер
При ошибке Возобновить Далее
Установите objFSO = Server.CreateObject("Scri" & "pti" & "ng.Fil" & "eSyst" & "emOb" & "ject")
Если Ошибка Тогда
Ошибка.Очистить()
Выход из функции
Конец, если
CreateFolder = Заменить(CreateFolder,"/","/")
Если Left(CreateFolder,1)="/" Тогда
'CreateFolder = Right(CreateFolder,Len(CreateFolder)-1)
Конец, если
Если Правильно(CreateFolder,1)="/" Тогда
CreateFolder = Влево(CreateFolder,Len(CreateFolder)-1)
Конец, если
CreateFolderArray = Split(CreateFolder,"/")
Для i = 0 до UBound(CreateFolderArray)
CreateFolderSub = ""
Для ii = 0 до i
CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/"
Следующий
PhCreateFolderSub = Server.MapPath(CreateFolderSub)
'response.Write PhCreateFolderSub&"<br>"
Если не objFSO.FolderExists(PhCreateFolderSub) Тогда
objFSO.CreateFolder(PhCreateFolderSub)
Конец, если
Следующий
Если Ошибка Тогда
Ошибка.Очистить()
Еще
Блинфо=Истина
Конец, если
Установить objFSO=ничего
CreateMultiFolder = Блинфо
Конечная функция
'********************************************** *
'Имя функции: FSOFileRead
'Функция: используйте FSO для чтения функции содержимого файла.
'Параметр: имя_файла ---- имя файла
'Возвращаемое значение: содержимое файла
'********************************************** *
функция FSOFileRead (имя файла)
Тусклый objFSO, objCountFile, FiletempData
Установите objFSO = Server.CreateObject("Scripting.FileSystemObject")
Установите objCountFile = objFSO.OpenTextFile(Server.MapPath(имя файла),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Установить objCountFile=Ничего
Установить objFSO = Ничего
Конечная функция
'********************************************** *
'Имя функции: FSOlinedit
'Функция: используйте FSO для чтения определенной строки файловой функции
'Параметр: имя_файла ---- имя файла
'lineNum ---- номер строки
'Возвращаемое значение: содержимое строки в файле
'********************************************** *
функция FSOlinedit(имя файла,lineNum)
если linenum < 1, то выходим из функции
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
если не fso.fileExists(server.mappath(имя файла)) то выйдите из функции
set f = fso.opentextfile(server.mappath(имя файла),1)
если не f.AtEndofStream, то
tempcnt = f.readall
е.закрыть
установить f = ничего
temparray = Split(tempcnt,chr(13)&chr(10))
если lineNum>ubound(temparray)+1, то
функция выхода
еще
FSOlinedit = temparray(lineNum-1)
конец, если
конец, если
конечная функция
'********************************************** *
'Имя функции: FSOlinewrite
'Функция: используйте FSO для записи определенной строки файловой функции
'Параметр: имя_файла ---- имя файла
'lineNum ---- номер строки
' Linecontent ---- содержимое
'Возвращаемое значение: нет
'********************************************** *
функция FSOlinewrite(имя файла,lineNum,Linecontent)
если linenum < 1, то выходим из функции
dim fso, f, temparray, tempCnt
set fso = server.CreateObject("scripting.filesystemobject")
если не fso.fileExists(server.mappath(имя файла)) то выйдите из функции
set f = fso.opentextfile(server.mappath(имя файла),1)
если не f.AtEndofStream, то
tempcnt = f.readall
е.закрыть
temparray = Split(tempcnt,chr(13)&chr(10))
если lineNum>ubound(temparray)+1, то
функция выхода
еще
temparray(lineNum-1) = lineContent
конец, если
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(имя файла),true)
f.writetempcnt
конец, если
е.закрыть
установить f = ничего
конечная функция
'********************************************** *
'Имя функции: Htmlmake
'Функция: использовать FSO для создания файлов
'Параметр: HtmlFolder ---- путь
' HtmlFilename ---- имя файла
'HtmlContent ----Содержимое
'********************************************** *
функция Htmlmake(HtmlFolder,HtmlFilename,HtmlContent)
При ошибке Возобновить Далее
тусклый путь к файлу, fso, fout
путь к файлу = HtmlFolder&"/"&HtmlFilename
Установите fso = Server.CreateObject("Scripting.FileSystemObject")
Если fso.FolderExists(HtmlFolder) Тогда
Еще
CreateMultiFolder(HtmlFolder)
&, ;nbs, p; Конец, если
Установите fout = fso.Createtextfile(server.mappath(filepath),true)
fout.writeline HtmlContent
фут.закрыть
установить fso=ничего
Установите fso = Server.CreateObject("Scripting.FileSystemObject")
Если fso.fileexists(Server.MapPath(путь к файлу)) Тогда
Response.Write "Файл<font color=red>"&HtmlFilename&"</font> создан!<br>"
Еще
'Response.Write Server.MapPath(путь к файлу)
Response.Write "Файл<font color=red>"&HtmlFilename&"</font> не создан!<br>"
Конец, если
Установите fso = ничего
Конечная функция
'********************************************** *
'Имя функции: Htmldel
'Функция: использовать FSO для удаления файлов
'Параметр: HtmlFolder ---- путь
' HtmlFilename ---- имя файла
'********************************************** *
Sub Htmldel(HtmlFolder,HtmlFilename)
тусклый путь к файлу, fso
путь к файлу = HtmlFolder&"/"&HtmlFilename
Установите fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile(Server.mappath(путь к файлу))
Установите fso = ничего
Установите fso = Server.CreateObject("Scripting.FileSystemObject")
Если fso.fileexists(Server.MapPath(путь к файлу)) Тогда
Response.Write "Файл<font color=red>"&HtmlFilename&"</font> не удален!<br>"
Еще
'Response.Write Server.MapPath(путь к файлу)
Response.Write "Файл<font color=red>"&HtmlFilename&"</font> удален!<br>"
Конец, если
Установите fso = ничего
Конец субтитра
'============================================== =
'Имя процесса: HTMLEncode
'Функция: фильтровать формат HTML
'Параметр: fString ---- Содержимое преобразования
'============================================== =
функция HTMLEncode(ByVal fString)
Если IsNull(fString)=False или fString<>"" или fString<>"$False$" Тогда
fString = Заменить(fString, ">", ">")
fString = Заменить(fString, "<", "<")
fString = Заменить(fString, Chr(32), " ")
fString = Заменить(fString, Chr(9), " ")
fString = Заменить(fString, Chr(34), """)
fString = Заменить(fString, Chr(39), "'")
fString = Заменить(fString, Chr(13), "")
fString = Заменить(fString, " ", " ")
fString = Заменить(fString, CHR(10) & CHR(10), "</P><P>")
fString = Заменить(fString, Chr(10), "<br /> ")
HTMLEncode = fString
еще
HTMLEncode = "$False$"
конец, если
конечная функция
'============================================== =
'Имя процесса: unHTMLEncode
'Функция: восстановить формат HTML
'Параметр: fString ---- Содержимое преобразования
'============================================== =
функция unHTMLEncode(ByVal fString)
Если IsNull(fString)=False или fString<>"" или fString<>"$False$" Тогда
fString = Заменить(fString, ">", ">")
fString = Заменить(fString, "<", "<")
fString = Заменить(fString, " ", Chr(32))
fString = Заменить(fString, """, Chr(34))
fString = Заменить(fString, "'", Chr(39))
fString = Заменить(fString, "", Chr(13))
fString = Заменить(fString, " ", " ")
fString = Заменить(fString, "</P><P>" , CHR(10) & CHR(10))
fString = Заменить(fString, "<br>", Chr(10))
unHTMLEncode = fString
еще
unHTMLEncode = "$False$"
конец, если
конечная функция
функция unhtmllist(содержание)
unhtmllist=содержание
если содержимое <> "" тогда
unhtmllist=replace(unhtmllist,"'","";")
unhtmllist=replace(unhtmllist,chr(10),"")
unHtmllist=replace(unHtmllist,chr(13),"<br>")
конец, если
конечная функция
функция unhtmllists(содержание)
unhtmllists=содержание
если содержимое <> "" тогда
unhtmllists=replace(unhtmllists,"""","")
unhtmllists=replace(unhtmllists,"'","")
unhtmllists=replace(unhtmllists,chr(10),"")
unHtmllists=replace(unHtmllists,chr(13),"<br>")
конец, если
конечная функция
функция htmllists(содержание)
htmllists=содержание
если содержимое <> "" тогда
htmllists=replace(htmllists,"''","""")
htmllists=replace(htmllists,"","'")
htmllists=replace(htmllists,"<br>",chr(13)&chr(10))
конец, если
конечная функция
функция uhtmllists(содержание)
uhtmllists=содержание
если содержимое <> "" тогда
uhtlists=replace(uhtlists,"""","''")
uhtlists=replace(uhtlists,"'","";")
uhtlists=replace(uhtlists,chr(10),"")
uHtmllists=replace(uHtmllists,chr(13),"<br>")
конец, если
конечная функция
'============================================== =
'Процесс: сон
'Функция: программа останавливается здесь на несколько секунд.
'Параметры: iSeconds Количество секунд для паузы
'============================================== =
Дополнительный сон (iSeconds)
response.Write "<font color=blue>Начать паузу на "&iSeconds&" секунд</font><br>"
Тусклый t:t=Таймер()
Пока (Таймер()<t+iSeconds)
«Ничего не делать
Венд
ответ. Напишите "<font color=blue>Pause"&iSeconds&" секунд до конца</font><br>"
Конец субтитра
'============================================== = =
'Имя функции: MyArray
'Функция: извлечение тегов для разделения
'Параметр: ConStr ------Извлечение исходных символов адреса
'============================================== = =
Функция MyArray(ByvalConStr)
Установить objRegExp = Новое регулярное выражение
objRegExp.IgnoreCase = Истина
objRegExp.Global = Истина
objRegExp.Pattern = "({).+?(})"
Установить совпадения =objRegExp.Execute(ConStr)
За каждый матч в матчах
TempStr=TempStr & "" & Match.Value
Следующий
Установить совпадения = ничего
TempStr=Вправо(TempStr,Len(TempStr)-1)
objRegExp.Pattern="{"
TempStr=objRegExp.Replace(TempStr,"")
objRegExp.Pattern="}"
TempStr=objRegExp.Replace(TempStr,"")
Установить objRegExp=ничего
Установить совпадения = ничего
TempStr=Replace(TempStr,"$","")
Если TempStr="" тогда
MyArray="В коде нечего извлекать"
Еще
MyArray=ТемпСтр
Конец, если
Конечная функция
'============================================== = =
'Имя функции: randm
'Функция: генерировать 6-значное случайное число.
'============================================== = =
Функция случайная
рандомизировать
randm=Int((900000*rnd)+100000)
Конечная функция
%>