В этой статье представлен полный набор функций сбора 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 = заменить (заменить (GetHTTPPage, vbCr,), vbLf,)
Установить HTTP=Ничего
Если номер ошибки<>0, то
Ошиб.Очистить
Конец, если
Конечная функция
'============================================== = =
'Имя функции: BytesToBstr
'Функция: конвертировать полученный исходный код в китайский
'Параметр: Тело ------Переменная для преобразования
'Параметр: Cset ------тип для преобразования
'============================================== = =
Функция BytesToBstr(Body,Cset)
Дим Обжстрим
Установите 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 Content-Length, Len (PostData)
xmlHttp.setRequestHeader Content-Type, 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
Конец, если
ИначеЕсли 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 Тогда
Если Right(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)=/ Тогда
Если right(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
Конец, если
Еще
Если right(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=Заменить(TempStr,Chr(0),)
TempArray2=Разделить(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) и вправо(0 и минута(DtNow) ) ),2) & right(0 & Second(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 =value/s*=/s*.+?/.swf
Установить совпадения =Re.Execute(TempArray(Tempi))
За каждый матч в матчах
Если TempStr<>, то
TempStr=TempStr & $Array$ & Match.Value
Еще
TempStr=Соответствие.Значение
Конец, если
Следующий
Следующий
Конец, если
Если TempStr<> Тогда
Re.Pattern =значение/с*=/с*
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=Заменить(TempStr,Chr(0),)
TempArray2=Разделить(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)
С поиском
.Открыть Get, 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=Заменить(ConTemp, ,)
ConTemp=Заменить(ConTemp,,,)
ConTemp=Заменить(ConTemp,',)
ConTemp=Заменить(ConTemp,,)
ConTemp=Заменить(ConTemp,>,)
ConTemp=Заменить(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=Заменить(Constr,CHR(32),)
Constr=Заменить(Constr,CHR(9),)
Constr=Заменить(Constr, ,)
Constr=Заменить(Constr, ,)
Constr=Заменить(Constr,(,)
Constr=Заменить(Constr,),)
Constr=Заменить(Constr,<,)
Constr=Заменить(Constr,>,)
Constr=Заменить(Constr,,)
Constr=Заменить(Constr,?,)
Constr=Заменить(Constr,*,)
Constr=Заменить(Constr,,)
Constr=Заменить(Constr,,,)
Constr=Заменить(Constr,.,)
Constr=Заменить(Constr,/,)
Constr=Заменить(Constr,/,)
Constr=Заменить(Constr,-,)
Constr=Заменить(Constr,@,)
Constr=Заменить(Constr,#,)
Constr=Заменить(Constr,$,)
Constr=Заменить(Constr,%,)
Constr=Заменить(Constr,&,)
Констр=Заменить(Констр,+,)
Constr=Заменить(Constr,:,)
Constr=Заменить(Constr,:,)
Constr=Заменить(Constr,',)
Constr=Заменить(Constr,,)
Constr=Заменить(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=< & Имя тега & ([^>])*>
ConStr=Re.Replace(ConStr,)
Случай 2
Re.Pattern=< & TagName & ([^>])*>.*?</ & TagName & ([^>])*>
ConStr=Re.Replace(ConStr,)
Случай 3
Re.Pattern=< & Имя тега & ([^>])*>
ConStr=Re.Replace(ConStr,)
Re.Pattern=</ & Имя тега & ([^>])*>
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
установите 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
установите 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.Файл записи<font color=red>&HtmlFilename&</font> не создан!<br>
Конец, если
Установить fso = ничего
Конечная функция
'********************************************** *
'Имя функции: Htmldel
'Функция: использовать FSO для удаления файлов
'Параметр: HtmlFolder ---- путь
' HtmlFilename ---- имя файла
'********************************************** *
Подраздел 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.Файл записи<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>Пауза&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=Заменить(TempStr,$,)
Если TempStr=, то
MyArray=В коде нечего извлекать
Еще
MyArray=TempStr
Конец, если
Конечная функция
'============================================== = =
'Имя функции: randm
'Функция: генерировать 6-значное случайное число.
'============================================== = =
Функция случайная
рандомизировать
randm=Int((900000*rnd)+100000)
Конечная функция
%>