📄 system_gather.asp
字号:
If Not IsObjInstalled("Persits.Jpeg") Then
Exit Function
End If
Set objImage = Server.CreateObject("Persits.Jpeg")
objImage.Open FileName
objImage.Canvas.Font.Color = FontColor
objImage.Canvas.Font.Family = FontName
objImage.Canvas.Font.Bold = FondBond
objImage.Canvas.Font.size = FontSize
If objImage.OriginalWidth < TextWidth Or objImage.OriginalHeight < FontSize Then
Exit Function
End If
GetPostion CInt(MarkPosition), x, y, objImage.OriginalWidth, objImage.OriginalHeight, WR_UpLoad(36), WR_UpLoad(37)
With objImage.Canvas
.Print x, y, Text
End With
objImage.Save FileName
End Select
Set objImage = Nothing
End Function
Function AddPhotoMark(MarkComponentID, MarkWidth, MarkHeight, MarkPicture, MarkOpacity, MarkTranspColor, MarkPosition, FileName)
Dim objImage, objMark, x, y, OriginalWidth, OriginalHeight, Position
If InStr(FileName, ":") = 0 Then
FileName = Server.MapPath(FileName)
End If
If IsNull(MarkWidth) Or MarkWidth = "" Then
MarkWidth = 0
Else
MarkWidth = CInt(MarkWidth)
End If
If IsNull(MarkHeight) Or MarkHeight = "" Then
MarkHeight = 0
Else
MarkHeight = CInt(MarkHeight)
End If
If Trim(MarkPicture) = "" Or IsNull(MarkPicture) Then
Exit Function
End If
If IsNull(MarkOpacity) Or MarkOpacity = "" Then
MarkOpacity = 1
Else
MarkOpacity = CSng(MarkOpacity)
End If
If MarkTranspColor <> "" Then
MarkTranspColor = Replace(MarkTranspColor, "#", "&H")
Else
End If
Select Case MarkComponentID
Case 1
If Not IsObjInstalled("Persits.Jpeg") Then
Exit Function
End If
Set objImage = Server.CreateObject("Persits.Jpeg")
Set objMark = Server.CreateObject("Persits.Jpeg")
objImage.Open FileName
If objImage.OriginalWidth < MarkWidth Or objImage.OriginalHeight < MarkHeight Then
Exit Function
End If
objMark.Open Server.MapPath(MarkPicture)
GetPostion CInt(MarkPosition), x, y, objImage.OriginalWidth, objImage.OriginalHeight, MarkWidth, MarkHeight
If MarkTranspColor <> "" Then
objImage.DrawImage x, y, objMark, MarkOpacity, MarkTranspColor
Else
objImage.DrawImage x, y, objMark, MarkOpacity
End If
objImage.Save FileName
End Select
Set objImage = Nothing
Set objMark = Nothing
End Function
Function GetPostion(MarkPosition, x, y, ImageWidth, ImageHeight, MarkWidth, MarkHeight)
Select Case CInt(MarkPosition)
Case 1
x = MarkWidth
y = MarkHeight
Case 2
x = MarkWidth
y = Int(ImageHeight - MarkHeight)
Case 3
x = Int((ImageWidth - MarkWidth) / 2)
y = Int((ImageHeight - MarkHeight) / 2)
Case 4
x = Int(ImageWidth - MarkWidth)
y = MarkHeight
Case 5
x = Int(ImageWidth - MarkWidth)
y = Int(ImageHeight - MarkHeight)
End Select
End Function
'由原图片根据数据里保存的设置生成缩略图
'原图路径 , 新图路径
Function CreateThumbs(FileName,ThumbFileName)
CreateThumbs = False
If WR_UpLoad(20) <> "0" And (Not IsNull(WR_UpLoad(20))) Then
If WR_UpLoad(21) = "0" Then
CreateThumbs = CreateThumb(FileName, CInt(WR_UpLoad(23)), CInt(WR_UpLoad(24)), 0, ThumbFileName)
Else
CreateThumbs = CreateThumb(FileName, 0, 0, CSng(WR_UpLoad(22)), ThumbFileName)
End If
End If
End Function
'由原图片生成指定宽度和高度的缩略图
Function CreateThumb(FileName, Width, Height, Rate, ThumbFileName)
Dim strSql, RsSetting, objImage, iWidth, iHeight, strFileExtName
CreateThumb = False
If IsNull(FileName) Then '如果原图片未指定直接退出
Exit Function
ElseIf FileName = "" Then
Exit Function
End If
If InStr(FileName, ".") <> 0 Then
strFileExtName = LCase(Trim(Mid(FileName, InStrRev(FileName, ".") + 1)))
End If
If strFileExtName <> "jpg" And strFileExtName <> "gif" And strFileExtName <> "bmp" And strFileExtName <> "png" Then '文件不是可用图片则退出
Exit Function
End If
If IsNull(ThumbFileName) Then
Exit Function
ElseIf ThumbFileName = "" Then
Exit Function
End If
If IsNull(Width) Then
Width = 0
ElseIf Width = "" Then
Width = 0
End If
If IsNull(Rate) Then
Rate = 0
ElseIf Rate = "" Then
Rate = 0
End If
If IsNull(Height) Then
Height = 0
ElseIf Height = "" Then
Height = 0
End If
If InStr(FileName, ":") = 0 Then
FileName = Server.MapPath(FileName)
End If
If InStr(ThumbFileName, ":") = 0 Then
ThumbFileName = Server.MapPath(ThumbFileName)
End If
Width = CInt(Width)
Height = CInt(Height)
Rate = CSng(Rate)
Select Case CInt(WR_UpLoad(20))
Case 0
Exit Function
Case 1
If Not IsObjInstalled("Persits.Jpeg") Then
Exit Function
End If
If IsExpired("Persits.Jpeg") Then
Response.Write ("对不起，Persits.Jpeg 组件已过期<br><a href=# Onclick=""javascript:history.back()"">返回</a>")
Response.End
End If
Set objImage = Server.CreateObject("Persits.Jpeg")
objImage.Open FileName
If Rate = 0 And (Width <> 0 Or Height <> 0) Then
If Width < objImage.OriginalWidth And Height < objImage.OriginalHeight Then
If Width = 0 And Height <> 0 Then
objImage.Width = objImage.OriginalWidth / objImage.OriginalHeight * Height
objImage.Height = Height
ElseIf Width <> 0 And Height = 0 Then
objImage.Width = Width
objImage.Height = objImage.OriginalHeight / objImage.OriginalWidth * Width
ElseIf Width <> 0 And Height <> 0 Then
objImage.Width = Width
objImage.Height = Height
End If
End If
ElseIf Rate <> 0 Then
objImage.Width = objImage.OriginalWidth * Rate
objImage.Height = objImage.OriginalHeight * Rate
End If
objImage.Save ThumbFileName
End Select
CreateThumb = True
End Function
'获取下载文件保存地址
Function GetPath(gModule)
Dim gI
GetPath = WR_Setting(3)&WR_UpLoad(0)&"/"&WR_Gather(1)
Select Case gModule
Case 1'文章
GetPath = GetPath&"/"&WR_Gather(2)
Case 2'分类信息
GetPath = GetPath&"/"&WR_Gather(3)
Case 3'店铺
GetPath = GetPath&"/"&WR_Gather(4)
End Select
GetPath = GetPath&WRMPS.SaveTimeDir()
End Function
'采集数据处理
Function GetTitle(gStr,gHtml)
GetTitle = HCode(gStr,Split(gHtml,Sign1)(0),Split(gHtml,Sign1)(1))
GetTitle = WRMPS.LeachHTML(GetTitle)
GetTitle = Left(FpHtmlEnCode(GetTitle),50)
End Function
'gID 项目ID，gUrl目标URL, gModule采集分类，gType是否下载图片，gWaterMark是否添加水印，gCReThumb是否生成缩略图
Function GetContent(gStr,gHtml,gID,gUrl,gModule,gType,gWaterMark,gCReThumb)
Dim sPicTemp
If UBound(Split(gHtml,Sign1)) > 1 Then
If Int(Split(gHtml,Sign1)(0)) < 1 Then GetContent = Null:Exit Function
gHtml = Split(gHtml,Sign1)(1)&Sign1&Split(gHtml,Sign1)(2)
End If
GetContent = HCode(gStr,Split(gHtml,Sign1)(0),Split(gHtml,Sign1)(1))
If GetContent = "" Then GetContent = Null:Exit Function
GetContent = LeachFilter(GetContent,BaseSetting(9)) 'object等标签过滤
GetContent = LeachStr(GetContent,BaseSetting(10)) '字符替换
Set Grs = Gconn.Execute("Select WR_LeachType,WR_Leach1,WR_Leach2 From WR_Leach Where WR_ItemID="&gID&" and WR_Module="&gModule&" and WR_Key=1")
Do While Not Grs.Eof
GetContent = LeachData(GetContent,Grs(0),Grs(1),Grs(2)) '数据过滤
Grs.Movenext
Loop
Grs.Close
If gType > 0 Then '下载图片
GetContent = ReplaceSaveRemoteFile(GetContent,GetPath(gModule),True,gUrl,gWaterMark,gCReThumb) '格式化内容里的图片路径
If UploadFiles <> "" Then
If Instr(UploadFiles,"|") > 0 Then
sPicTemp = GetPath(Module)&Split(UploadFiles,"|")(0)
Session(ID&"Item") = Itemdata(UBound(Split(UploadFiles,"|"))+1,5)
Else
sPicTemp = GetPath(Module)&UploadFiles
Session(ID&"Item") = Itemdata(1,5)
End If
End If
If sPicTemp = "" Or IsNull(sPicTemp) Then
SavePic = NULL
Else
If Int(WR_UpLoad(20)) > 0 Then '缩略图
SavePic = GetPath(gModule)&"S/"&Split(sPicTemp,"/")(UBound(Split(sPicTemp,"/")))
Else
SavePic = GetPath(gModule)&Split(sPicTemp,"/")(UBound(Split(sPicTemp,"/")))
End If
End If
Else
GetContent = ReplaceSaveRemoteFile(GetContent,GetPath(gModule),False,gUrl,0,0) '格式化内容里的图片路径
End If
End Function
Function GetTime(gStr,gHtml)
If Int(Split(gHtml,Sign1)(0)) = 1 Then GetTime = HCode(gStr,Split(gHtml,Sign1)(1),Split(gHtml,Sign1)(2)) Else GetTime = Now()
If IsDate(GetTime) = False Then GetTime = Now()
If GetTime = "" Then GetTime = NULL Else GetTime = Trim(GetTime)
End Function
Function GetShaReC(gStr,gHtml)
If Int(Split(gHtml,Sign1)(0)) = 1 Then GetShaReC = HCode(gStr,Split(gHtml,Sign1)(1),Split(gHtml,Sign1)(2))
GetShaReC = WRMPS.LeachHTML(GetShaReC)
GetShaReC = Left(WR.CheckStr(GetShaReC, 0),50)
If GetShaReC = "" Then GetShaReC = NULL
End Function
Function GetShaReCon(gStr,gHtml)
If Int(Split(gHtml,Sign1)(0)) = 1 Then
GetShaReCon = HCode(gStr,Split(gHtml,Sign1)(1),Split(gHtml,Sign1)(2))
ElseIf Int(Split(gHtml,Sign1)(0)) = 2 Then
GetShaReCon = Split(gHtml,Sign1)(1)
End If
GetShaReCon = WRMPS.LeachHTML(GetShaReCon)
GetShaReCon = Left(WR.CheckStr(GetShaReCon, 0),50)
If GetShaReCon = "" Then GetShaReCon = NULL
End Function
Function GetTags(gStr,gHtml,gTitle)
Select Case Int(Split(gHtml,Sign1)(0))
Case 0
GetTags = gTitle
GetTags = GetCReateTags(GetTags)
Case 1
GetTags = HCode(gStr,Split(gHtml,Sign1)(1),Split(gHtml,Sign1)(2))
GetTags = GetCReateTags(GetTags)
Case 2
GetTags = Split(gHtml,Sign1)(1)
End Select
If GetTags = "" Then GetTags = ","
GetTags = Left(WR.CheckStr(GetTags, 0),50)
If GetTags = "" Then GetTags = NULL
End Function
'自动生成关键字
Function GetCReateTags(Str)
Dim gLen,gSign
Str=WRMPS.LeachHTML(Str)
Str=FilterJS(Str)
Str=Replace(Str,",","")
gSign = vbCrLf&","&CHR(9)&","&CHR(32)&",',", ,<,>,`,~,!,@,#,$,%,^,*,(,),（,）,_,+,=,-,{,},|,\,],[,:,"",',;,<,>,?,/,.,《,》,？,＜,＞,’,‘,“,”,；,：,、,&,！,■,▲,★,◆,※,〓,【,】,〗,〖,『,』,，,。"
For ga=0 To Ubound(Split(gSign,","))
Str=WRMPS.GetReplace(Str,Split(gSign,",")(ga),"")
Next
gLen = Len(Str)
For gI = 1 To gLen-1
GetCReateTags = GetCReateTags &","& Mid(Str,gI,2)
Next
If GetCReateTags = "" Then GetCReateTags = ","
If Left(GetCReateTags,1) = "," Then GetCReateTags = Right(GetCReateTags,Len(GetCReateTags)-1)
If Right(GetCReateTags,1) = "," Then GetCReateTags = Left(GetCReateTags,Len(GetCReateTags)-1)
End Function
%>⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -