aspcms免费开源企业网站开发建设管理系统源码程序

 找回密码
 立即注册

QQ登录

只需一步,快速开始

搜索
查看: 2700|回复: 0

aspcms教你修改远程复制过来的图片,保存在本地

[复制链接]

187

主题

188

帖子

609

积分

高级会员

Rank: 4

积分
609
发表于 2019-3-28 11:12:16 | 显示全部楼层 |阅读模式
使用说明:
1,
  1. <%
  2. '==================================================
  3. '函数名:CheckDir2
  4. '作 用:检查文件夹是否存在
  5. '参 数:FolderPath ------文件夹地址
  6. '==================================================
  7. Function CheckDir2(byval FolderPath)
  8. dim fso
  9. folderpath=Server.MapPath(folderpath)
  10. Set fso = Server.CreateObject("Scripting.FileSystemObject")
  11. If fso.FolderExists(FolderPath) then
  12. '存在
  13. CheckDir2 = True
  14. Else
  15. '不存在
  16. CheckDir2 = False
  17. End if
  18. Set fso = nothing
  19. End Function
  20. '==================================================
  21. '函数名:MakeNewsDir2
  22. '作 用:创建新的文件夹
  23. '参 数:foldername ------文件夹名称
  24. '==================================================
  25. Function MakeNewsDir2(byval foldername)
  26. dim fso
  27. Set fso = Server.CreateObject("Scripting.FileSystemObject")
  28. fso.CreateFolder(Server.MapPath(".") &"" &foldername)
  29. If fso.FolderExists(Server.MapPath(".") &"" &foldername) Then
  30. MakeNewsDir2 = True
  31. Else
  32. MakeNewsDir2 = False
  33. End If
  34. Set fso = nothing
  35. End Function
  36. '==================================================
  37. '函数名:DefiniteUrl
  38. '作 用:将相对地址转换为绝对地址
  39. '参 数:PRimitiveUrl ------要转换的相对地址
  40. '参 数:ConsultUrl ------当前网页地址
  41. '==================================================
  42. Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)
  43. Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray
  44. If PrimitiveUrl="" or PrimitiveUrl="$False$" Then
  45. DefiniteUrl="$False$"
  46. Exit Function
  47. End If
  48. If Left(ConsultUrl,7)<>"HTTP://" And Left(ConsultUrl,7)<>"http://" Then
  49. ConsultUrl= "http://" & ConsultUrl
  50. End If
  51. ConsultUrl=Replace(ConsultUrl,"://",":\")
  52. If Right(ConsultUrl,1)<>"/" Then
  53. If Instr(ConsultUrl,"/")>0 Then
  54. If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then
  55. Else
  56. ConsultUrl=ConsultUrl & "/"
  57. End If
  58. Else
  59. ConsultUrl=ConsultUrl & "/"
  60. End If
  61. End If
  62. ConArray=Split(ConsultUrl,"/")
  63. If Left(PrimitiveUrl,7) = "http://" then
  64. DefiniteUrl=Replace(PrimitiveUrl,"://",":\")
  65. ElseIf Left(PrimitiveUrl,1) = "/" Then
  66. DefiniteUrl=ConArray(0) & PrimitiveUrl
  67. ElseIf Left(PrimitiveUrl,2)="./" Then
  68. DefiniteUrl=ConArray(0) & Right(PrimitiveUrl,Len(PrimitiveUrl)-1)
  69. ElseIf Left(PrimitiveUrl,3)="../" then
  70. Do While Left(PrimitiveUrl,3)="../"
  71. PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)
  72. Pi=Pi+1
  73. Loop
  74. For Ci=0 to (Ubound(ConArray)-1-Pi)
  75. If DefiniteUrl<>"" Then
  76. DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)
  77. Else
  78. DefiniteUrl=ConArray(Ci)
  79. End If
  80. Next
  81. DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl
  82. Else
  83. If Instr(PrimitiveUrl,"/")>0 Then
  84. PriArray=Split(PrimitiveUrl,"/")
  85. If Instr(PriArray(0),".")>0 Then
  86. If Right(PrimitiveUrl,1)="/" Then
  87. DefiniteUrl="http:\" & PrimitiveUrl
  88. Else
  89. If Instr(PriArray(Ubound(PriArray)-1),".")>0 Then
  90. DefiniteUrl="http:\" & PrimitiveUrl
  91. Else
  92. DefiniteUrl="http:\" & PrimitiveUrl & "/"
  93. End If
  94. End If
  95. Else
  96. If Right(ConsultUrl,1)="/" Then
  97. DefiniteUrl=ConsultUrl & PrimitiveUrl
  98. Else
  99. DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl
  100. End If
  101. End If
  102. Else
  103. If Instr(PrimitiveUrl,".")>0 Then
  104. If Right(ConsultUrl,1)="/" Then
  105. If right(PrimitiveUrl,3)=".cn" or right(PrimitiveUrl,3)="com" or right(PrimitiveUrl,3)="net" or right(PrimitiveUrl,3)="org" Then
  106. DefiniteUrl="http:\" & PrimitiveUrl & "/"
  107. Else
  108. DefiniteUrl=ConsultUrl & PrimitiveUrl
  109. End If
  110. Else
  111. If right(PrimitiveUrl,3)=".cn" or right(PrimitiveUrl,3)="com" or right(PrimitiveUrl,3)="net" or right(PrimitiveUrl,3)="org" Then
  112. DefiniteUrl="http:\" & PrimitiveUrl & "/"
  113. Else
  114. DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl
  115. End If
  116. End If
  117. Else
  118. If Right(ConsultUrl,1)="/" Then
  119. DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"
  120. Else
  121. DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"
  122. End If
  123. End If
  124. End If
  125. End If
  126. If Left(DefiniteUrl,1)="/" then
  127. DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)
  128. End if
  129. If DefiniteUrl<>"" Then
  130. DefiniteUrl=Replace(DefiniteUrl,"//","/")
  131. DefiniteUrl=Replace(DefiniteUrl,":\","://")
  132. Else
  133. DefiniteUrl="$False$"
  134. End If
  135. End Function
  136. '==================================================
  137. '函数名:ReplaceSaveRemoteFile
  138. '作 用:替换、保存远程文件
  139. '参 数:ConStr ------ 要替换的字符串
  140. '参 数:StarStr ----- 前导
  141. '参 数:OverStr -----
  142. '参 数:IncluL ------
  143. '参 数:IncluR ------
  144. '参 数:SaveTf ------ 是否保存文件,False不保存,True保存
  145. '参 数:SaveFilePath- 保存文件夹
  146. '参 数: TistUrl------ 当前网页地址
  147. '==================================================
  148. Function ReplaceSaveRemoteFile(ConStr,StartStr,OverStr,IncluL,IncluR,SaveTf,SaveFilePath,TistUrl)
  149. If ConStr="$False$" or ConStr="" Then
  150. ReplaceSaveRemoteFile="$False$"
  151. Exit Function
  152. End If
  153. Dim TempStr,TempStr2,ReF,Matches,Match,Tempi,TempArray,TempArray2,OverTypeArray,UploadFiles
  154. Set ReF = New Regexp
  155. ReF.IgnoreCase = True
  156. ReF.Global = True
  157. ReF.Pattern = "("&StartStr&").+?("&OverStr&")"
  158. Set Matches =ReF.Execute(ConStr)
  159. For Each Match in Matches
  160. If Instr(TempStr,Match.Value)=0 Then
  161. If TempStr<>"" then
  162. TempStr=TempStr & "$Array$" & Match.Value
  163. Else
  164. TempStr=Match.Value
  165. End if
  166. End If
  167. Next
  168. Set Matches=nothing
  169. Set ReF=nothing
  170. If TempStr="" or IsNull(TempStr)=True Then
  171. ReplaceSaveRemoteFile=ConStr
  172. Exit function
  173. End if
  174. If IncluL=False then
  175. TempStr=Replace(TempStr,StartStr,"")
  176. End if
  177. If IncluR=False then
  178. If Instr(OverStr,"|")>0 Then
  179. OverTypeArray=Split(OverStr,"|")
  180. For Tempi=0 To Ubound(OverTypeArray)
  181. TempStr=Replace(TempStr,OverTypeArray(Tempi),"")
  182. Next
  183. Else
  184. TempStr=Replace(TempStr,OverStr,"")
  185. End If
  186. End if
  187. TempStr=Replace(TempStr,"""","")
  188. TempStr=Replace(TempStr,"'","")
  189. TempStr=Replace(TempStr,""","")
  190. TempStr=Replace(TempStr,CHR(34),"")

  191. Dim RemoteFile,RemoteFileurl,SaveFileName,SaveFileType,ArrSaveFileName,RanNum
  192. If Right(SaveFilePath,1)="/" then
  193. SaveFilePath=Left(SaveFilePath,Len(SaveFilePath)-1)
  194. End If
  195. If SaveTf=True then
  196. If CheckDir2(SaveFilePath)=False Then
  197. If MakeNewsDir2(SaveFilePath)=False Then
  198. SaveTf=False
  199. End If
  200. End If
  201. End If
  202. SaveFilePath=SaveFilePath & "/"
  203. '图片转换/保存
  204. TempArray=Split(TempStr,"$Array$")
  205. For Tempi=0 To Ubound(TempArray)
  206. RemoteFileurl=DefiniteUrl(TempArray(Tempi),TistUrl)
  207. If RemoteFileurl<>"$False$" And SaveTf=True Then'保存图片
  208. ArrSaveFileName = Split(RemoteFileurl,".")
  209. SaveFileType=ArrSaveFileName(Ubound(ArrSaveFileName))'文件类型
  210. RanNum=Int(900*Rnd)+100
  211. SaveFileName = SaveFilePath&year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum&"."&SaveFileType
  212. Call SaveRemoteFile(SaveFileName,RemoteFileurl)
  213. ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName)
  214. ElseIf RemoteFileurl<>"$False$" and SaveTf=False Then'不保存图片
  215. SaveFileName=RemoteFileUrl
  216. ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName)
  217. End If
  218. If RemoteFileUrl<>"$False$" Then
  219. If UploadFiles="" then
  220. UploadFiles=SaveFileName
  221. Else
  222. UploadFiles=UploadFiles & "|" & SaveFileName
  223. End if
  224. End If
  225. Next
  226. ReplaceSaveRemoteFile=ConStr
  227. End function
  228. '==================================================
  229. '过程名:SaveRemoteFile
  230. '作 用:保存远程的文件到本地
  231. '参 数:LocalFileName ------ 本地文件名
  232. '参 数:RemoteFileUrl ------ 远程文件URL
  233. '==================================================
  234. sub SaveRemoteFile(LocalFileName,RemoteFileUrl)
  235. dim Ads,Retrieval,GetRemoteData
  236. Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
  237. With Retrieval
  238. .Open "Get", RemoteFileUrl, False, "", ""
  239. .Send
  240. GetRemoteData = .ResponseBody
  241. End With
  242. Set Retrieval = Nothing
  243. Set Ads = Server.CreateObject("Adodb.Stream")
  244. With Ads
  245. .Type = 1
  246. .Open
  247. .Write GetRemoteData
  248. .SaveToFile server.MapPath(LocalFileName),2
  249. .Cancel()
  250. .Close()
  251. End With
  252. Set Ads=nothing
  253. end sub
  254. '==================================================
  255. '过程名:GetImg
  256. '作 用:取得文章中第一张图片
  257. '参 数:str ------ 文章内容
  258. '参 数:strpath ------ 保存图片的路径
  259. '==================================================
  260. Function GetImg(str,strpath)
  261. set objregEx = new RegExp
  262. objregEx.IgnoreCase = true
  263. objregEx.Global = true
  264. zzstr=""&strpath&"(.+?)\.(jpg|gif|png|bmp)"
  265. objregEx.Pattern = zzstr
  266. set matches = objregEx.execute(str)
  267. for each match in matches
  268. retstr = retstr &"|"& Match.Value
  269. next
  270. if retstr<>"" then
  271. Imglist=split(retstr,"|")
  272. Imgone=replace(Imglist(1),strpath,"")

  273. GetImg=Imgone
  274. else
  275. GetImg=""
  276. end if
  277. end function

  278. Dim FilesStartStr,FilesOverStr,FilesPath,NewsUrl
  279. '调用

  280. '图片开始的字符串
  281. FilesStartStr="src="
  282. '图片结束的字符串
  283. FilesOverStr="gif|jpg|bmp|png"
  284. '保存图片的文件夹
  285. FilesPath=sitePath&setting.languagepath&"upload/image"
  286. '取得保存图片的网站URL 自动判断是绝对 还是相对路径 该例子中图片是绝对地址 所以NEWURL等于没用 如果是../images/123.gif这样的 就需要指定NEWURL了
  287. NewsUrl=""
  288. %>
复制代码
放到 admin_aspcms\_content\_Content 目录下边
2,打开AspCms_ContentFun.asp


下面添加

3,查找 Content=getForm("Content", "post") 在下面添加
Content=ReplaceSaveRemoteFile(Content,FilesStartStr,FilesOverStr,False,True,True,FilesPath,NewsUrl)
回复

使用道具 举报

*滑块验证:
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|Archiver|手机版|小黑屋|aspcms免费开源企业网站开发建设管理系统源码程序 ( 冀ICP备17022052号-2|网站地图

GMT+8, 2024-3-29 08:04 , Processed in 0.049269 second(s), 19 queries .

Powered by aspcms免费开源企业网站开发建设管理系统源码程序

© 2001-2025 aspcms免费开源企业网站开发建设管理系统源码程序

快速回复 返回顶部 返回列表