Esta função pode ser usada durante a coleta ou ao adicionar artigos online.
O código que pesquisei no Baidu para salvar imagens remotas na área local parece um pouco difícil de usar e não existe um código pronto e completo que eu não consiga entender.
Extraí algumas funções do sistema de coleta de notícias SNA para 3.62 (programado por: ansir) e usei-as, que são relativamente simples e fáceis de usar.
A seguir está a função
código do programa
Copie o código do código da seguinte forma:
<%
'================================================ = =
'Nome da função: CheckDir2
'Função: Verifica se a pasta existe
'Parâmetro: FolderPath ------endereço da pasta
'================================================ = =
Função CheckDir2 (byval FolderPath)
escurecer fso
folderpath=Server.MapPath(.)&/&folderpath
Definir fso = Server.CreateObject(Scripting.FileSystemObject)
Se fso.FolderExists(FolderPath) então
'existir
CheckDir2 = Verdadeiro
Outro
'não existe
CheckDir2 = Falso
Terminar se
Defina fso = nada
Função final
'================================================ = =
'Nome da função: MakeNewsDir2
'Função: Criar uma nova pasta
'Parâmetro: nome da pasta ------nome da pasta
'================================================ = =
Função MakeNewsDir2 (byval nome da pasta)
escurecer fso
Definir fso = Server.CreateObject(Scripting.FileSystemObject)
fso.CreateFolder(Server.MapPath(.) &/ &nome da pasta)
Se fso.FolderExists(Server.MapPath(.) &/ &foldername) Então
MakeNewsDir2 = Verdadeiro
Outro
MakeNewsDir2 = Falso
Terminar se
Defina fso = nada
Função final
'================================================ = =
'Nome da função: DefiniteUrl
'Função: Converte endereço relativo em endereço absoluto
'Parâmetro: PrimitiveUrl ------ endereço relativo a ser convertido
'Parâmetro: ConsultUrl ------Endereço atual da página web
'================================================ = =
Função DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
Se PrimitiveUrl= ou ConsultUrl= ou PrimitiveUrl=$False$ Então
UrlDefinido=$Falso$
Função de saída
Terminar se
Se Esquerda(ConsultUrl,7)<>HTTP:// E Esquerda(ConsultUrl,7)<>http:// Então
ConsultUrl= http:// & ConsultUrl
Terminar se
ConsultUrl=Substituir(ConsultUrl,://,://)
If Right(ConsultUrl,1)<>/Então
Se Instr(ConsultUrl,/)>0 Então
Se Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,/)),.)>0 então
Outro
ConsultUrl=ConsultarUrl & /
Terminar se
Outro
ConsultUrl=ConsultarUrl & /
Terminar se
Terminar se
ConArray=Dividir(ConsultarUrl,/)
Se Esquerda(PrimitiveUrl,7) = http:// então
DefiniteUrl=Substituir(PrimitiveUrl,://,://)
ElseIf Left(PrimitiveUrl,1) = / Então
DefiniteUrl=ConArray(0) e PrimitiveUrl
ElseIf Left(PrimitiveUrl,2)=./Então
DefiniteUrl=ConArray(0) & Right(PrimitiveUrl,Len(PrimitiveUrl)-1)
ElseIf Left(PrimitiveUrl,3)=../então
Faça enquanto à esquerda(PrimitiveUrl,3)=../
PrimitiveUrl=Direito(PrimitiveUrl,Len(PrimitiveUrl)-3)
Pi=Pi+1
Laço
Para Ci=0 a (Ubound(ConArray)-1-Pi)
Se DefiniteUrl<> então
DefiniteUrl = DefiniteUrl & / & ConArray(Ci)
Outro
DefiniteUrl=ConArray(Ci)
Terminar se
Próximo
DefiniteUrl = DefiniteUrl & / & PrimitiveUrl
Outro
Se Instr(PrimitiveUrl,/)>0 Então
PriArray=Split(PrimitiveUrl,/)
Se Instr(PriArray(0),.)>0 Então
Se Certo(PrimitiveUrl,1)=/ Então
DefiniteUrl=http:// e PrimitiveUrl
Outro
Se Instr(PriArray(Ubound(PriArray)-1),.)>0 Então
DefiniteUrl=http:// e PrimitiveUrl
Outro
DefiniteUrl=http:// & PrimitiveUrl & /
Terminar se
Terminar se
Outro
Se Certo(ConsultUrl,1)=/ Então
DefiniteUrl = ConsultUrl e PrimitiveUrl
Outro
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,/)) & PrimitiveUrl
Terminar se
Terminar se
Outro
Se Instr(PrimitiveUrl,.)>0 Então
Se Certo(ConsultUrl,1)=/ Então
Se right(PrimitiveUrl,3)=.cn ou right(PrimitiveUrl,3)=com ou right(PrimitiveUrl,3)=net ou right(PrimitiveUrl,3)=org Então
DefiniteUrl=http:// & PrimitiveUrl & /
Outro
DefiniteUrl = ConsultUrl e PrimitiveUrl
Terminar se
Outro
Se right(PrimitiveUrl,3)=.cn ou right(PrimitiveUrl,3)=com ou right(PrimitiveUrl,3)=net ou right(PrimitiveUrl,3)=org Então
DefiniteUrl=http:// & PrimitiveUrl & /
Outro
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,/)) & / & PrimitiveUrl
Terminar se
Terminar se
Outro
Se Certo(ConsultUrl,1)=/ Então
DefiniteUrl=ConsultUrl & PrimitiveUrl & /
Outro
DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,/)) & / & PrimitiveUrl & /
Terminar se
Terminar se
Terminar se
Terminar se
Se Esquerda(DefiniteUrl,1)=/então
DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
Terminar se
Se DefiniteUrl<> Então
DefiniteUrl=Substituir(DefiniteUrl,//,/)
DefiniteUrl=Substituir(DefiniteUrl,://,://)
Outro
UrlDefinido=$Falso$
Terminar se
Função final
'================================================ = =
'Nome da função: ReplaceSaveRemoteFile
'Função: substituir e salvar arquivos remotos
'Parâmetro: ConStr ------ string a ser substituída
'Parâmetro: StarStr ----- líder
'Parâmetro: OverStr-----
'Parâmetro:IncluL ------
'Parâmetro:IncluR ------
'Parâmetro: SaveTf ------ Se deseja salvar o arquivo, False não salva, True salva
'Parâmetro: pasta SaveFilePath-save
'Parâmetro: TistUrl------ endereço da página web atual
'================================================ = =
Função SubstituaSaveRemoteFile(ConStr,StartStr,OverStr,IncluL,IncluR,SaveTf,SaveFilePath,TistUrl)
Se ConStr=$False$ ou ConStr=Então
SubstituaSaveRemoteFile=$Falso$
Função de saída
Terminar se
Dim TempStr,TempStr2,ReF,Correspondências,Correspondência,Tempi,TempArray,TempArray2,OverTypeArray
Definir ReF = Novo Regexp
ReF.IgnoreCase = Verdadeiro
ReF.Global = Verdadeiro
ReF.Pattern = (&StartStr&).+?(&OverStr&)
Definir correspondências =ReF.Execute(ConStr)
Para cada partida nas partidas
Se Instr(TempStr,Match.Value)=0 Então
Se TempStr<> então
TempStr=TempStr & $Array$ & Match.Value
Outro
TempStr=Match.Value
Terminar se
Terminar se
Próximo
Definir correspondências = nada
Definir ReF = nada
Se TempStr= ou IsNull(TempStr)=True Então
SubstituaSaveRemoteFile=ConStr
Função de saída
Terminar se
Se IncluL=Falso então
TempStr=Substituir(TempStr,StartStr,)
Terminar se
Se InclR=Falso então
Se Instr(OverStr,|)>0 Então
OverTypeArray=Dividir(OverStr,|)
Para Tempi = 0 para Ubound (OverTypeArray)
TempStr=Substituir(TempStr,OverTypeArray(Tempi),)
Próximo
Outro
TempStr=Substituir(TempStr,OverStr,)
Terminar se
Terminar se
TempStr=Substituir(TempStr,,)
TempStr=Substituir(TempStr,',)
Dim RemoteFile,RemoteFileurl,SaveFileName,SaveFileType,ArrSaveFileName,RanNum
Se Right(SaveFilePath,1)=/então
SaveFilePath=Esquerda(SaveFilePath,Len(SaveFilePath)-1)
Terminar se
Se SaveTf=True então
Se CheckDir2(SaveFilePath)=False então
Se MakeNewsDir2(SaveFilePath)=False então
SalvarTf=Falso
Terminar se
Terminar se
Terminar se
SaveFilePath=SaveFilePath & /
'Conversão/salvamento de imagem
TempArray=Dividir(TempStr,$Array$)
Para Tempi = 0 para Ubound (TempArray)
RemoteFileurl=DefiniteUrl(TempArray(Tempi),TistUrl)
Se RemoteFileurl<>$False$ And SaveTf=True Então'Salve a imagem
ArrSaveFileName = Dividir(RemoteFileurl,.)
SaveFileType=ArrSaveFileName(Ubound(ArrSaveFileName))'Tipo de arquivo
NumRan=Int(900*Rnd)+100
SaveFileName = SaveFilePath&ano(agora)&mês(agora)&dia(agora)&hora(agora)&minuto(agora)&segundo(agora)&ranNum&.&SaveFileType
Chame SaveRemoteFile(SaveFileName,RemoteFileurl)
ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName)
ElseIf RemoteFileurl<>$False$ e SaveTf=False Then'Não salve a imagem
SaveFileName=RemoteFileUrl
ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName)
Terminar se
Se RemoteFileUrl<>$False$ Então
Se UploadFiles = então
UploadFiles=SalvarNomeArquivo
Outro
UploadFiles=CarregarArquivos & | & SaveFileName
Terminar se
Terminar se
Próximo
SubstituaSaveRemoteFile=ConStr
Função final
'================================================ = =
'Nome do processo: SaveRemoteFile
'Função: salvar arquivos remotos em local
'Parâmetro: LocalFileName ------ nome do arquivo local
'Parâmetro: RemoteFileUrl ------ URL do arquivo remoto
'================================================ = =
sub SaveRemoteFile(LocalFileName,RemoteFileUrl)
dim Anúncios, Recuperação, GetRemoteData
Definir recuperação = Server.CreateObject(Microsoft.XMLHTTP)
Com recuperação
.Abra Get, RemoteFileUrl, Falso, ,
.Enviar
GetRemoteData = .ResponseBody
Terminar com
Definir recuperação = nada
Definir anúncios = Server.CreateObject (Adodb.Stream)
Com anúncios
.Tipo = 1
.Abrir
.Escreva GetRemoteData
.SaveToFile servidor.MapPath(LocalFileName),2
.Cancelar()
.Fechar()
Terminar com
Definir anúncios = nada
final sub
'================================================ = =
'Nome do processo: GetImg
'Função: Obtenha a primeira foto do artigo
'Parâmetro: str ------ conteúdo do artigo
'Parâmetro: strpath ------ caminho para salvar a imagem
'================================================ = =
Função GetImg(str,strpath)
definir objregEx = novo RegExp
objregEx.IgnoreCase = verdadeiro
objregEx.Global = verdadeiro
zzstr=&strpath&(.+?)/.(jpg|gif|png|bmp)
objregEx.Pattern = zzstr
definir correspondências = objregEx.execute (str)
para cada partida em partidas
retstr = retstr &|& Match.Value
próximo
se retstr<> então
ListaImg=dividir(retstr,|)
Imgone=substituir(Imglist(1),strpath,)
GetImg=Imgone
outro
ObterImg=
terminar se
função final
%>
A seguir estão exemplos
código do programa
Copie o código do código da seguinte forma:
<form id=form1 nome=form1 método=post action=?action=test>
<nome da área de texto=corpo cols=50 linhas=5 id=corpo>
<img height=180 src=http://cimg2.163.com/cnews/2006/8/21/200608210738371d0a8.jpg width=240 border=0 />
<img class=leftsrc=http://news.163.com/img/netease_logo.gif width=114 />
<img height=60 src=http://cimg2.163.com/cnews/2006/8/18/2006081811465369976.jpg width=120 border=0 />
<img altura=60 /></textarea>
<tipo de entrada=nome de envio=Valor de envio=Enviar/>
</form>
<%
se request.QueryString(action)=teste então
'A string que inicia a imagem
FilesStartStr=src=
'String no final da imagem
FilesOverStr=gif|jpg|bmp
'Pasta para salvar fotos
Caminho dos arquivos=qq
'Obtenha a URL do site onde a imagem foi salva e determine automaticamente se é um caminho absoluto ou relativo. Neste exemplo, a imagem é um endereço absoluto, então NEWURL é inútil se for ../images/123. gif, você precisa especificar NEWURL.
NewsUrl=http://news.163.com
'Obtenha o conteúdo do artigo
Conteúdo =Solicitação.Formulário(corpo)
'Comece a salvar fotos
Content=ReplaceSaveRemoteFile(Content,FilesStartStr,FilesOverStr,False,True,True,FilesPath,NewsUrl)
'Cria uma miniatura para a primeira foto da notícia
se GetImg(Content,FilesPath)<> então
Imgsrc=GetImg(Conteúdo, Caminho dos Arquivos)
Imgsrc=substituir(Imgsrc,FilesPath,)
Definir Jpeg = Server.CreateObject(Persits.Jpeg)
Caminho = Server.MapPath(&FilesPath&) & /&Imgsrc&
Jpeg.Caminho aberto
'Se a largura da imagem for menor ou igual a 120 e a altura for menor ou igual a 90, nenhuma miniatura será criada.
se Jpeg.OriginalWidth<=120 e Jpeg.Height<=90 então
Jpeg.Largura = Jpeg.OriginalLargura
Jpeg.Altura = Jpeg.OriginalAltura
Smallimg=FilesPath&&GetImg(Conteúdo,FilesPath)
outro
'Largura e altura da imagem/2
Jpeg.Largura = Jpeg.OriginalLargura / 2
Jpeg.Altura = Jpeg.OriginalAltura / 2
Jpeg.Save Server.MapPath(&FilesPath&) & /small_&Imgsrc&
Smallimg=&Caminho dos Arquivos&/small_&Imgsrc&
terminar se
terminar se
'Mostrar resultados
resposta.Write(A primeira foto da notícia é:)
resposta.Write(<img src=&FilesPath&/&GetImg(Conteúdo,FilesPath)&>)
response.Write(<br>A miniatura da primeira foto da notícia é:)
resposta.Write(<img src=&Smallimg&>)
response.Write(<br>Novo conteúdo de notícias (a imagem é local):<br>)
Resposta.Write(Conteúdo)
Resposta.End()
terminar se
%>