Private Sub Command1_Click()
time1 = Time()
Dim DBconnect As New ADODB.Connection
DBconnect.Provider = "Microsoft.jet.OLEDB.4.0"
DBconnect.ConnectionString = App.Path & "\down.asp"'数据库路径
If DBconnect.State = adStateOpen And Not IsEmpty(adStateOpen) Then
DBconnect.Close
Else
DBconnect.Open
End If
Dim Rs_type As New ADODB.Recordset
Dim RS As New ADODB.Recordset
Dim SQLStr, Sortdir, pencat, pencatbak, sql, MaxPerPage
MaxPerPage = 30
RS.Open ("select down_list from mb"), DBconnect, adOpenKeyset
pencatbak = RS("down_list")
RS.Close
Sortdir = "Catalog" '软件分类前的前缀，可以自定义
SQLStr = "select id,tname,ts from downtype order by id desc"
If Rs_type.State = adStateOpen And Not IsEmpty(adStateOpen) Then
Rs_type.Close
Else
Rs_type.Open SQLStr, DBconnect, adOpenKeyset
End If
cum = Rs_type.RecordCount
While Not Rs_type.EOF
'################ 读取标题 ################
tid = Rs_type("id")
TN = Split(Rs_type("tname"), "")
TI = Split(Rs_type("ts"), ",")
thistype = ""
For i = 0 To UBound(TN) - 1
If i = UBound(TN) - 2 And UBound(TN) > 1 Then
TTY_id = TI(i)
TTY_name = TN(i)
End If
all_type_top_id = TI(i)
all_type_name = TN(i)
thistype = thistype & " >> <a href='http://"&Sortdir&TI(i)&"/"&TI(i)&"_1.htm'>" & TN(i) & "</a>"
Next
'################################
txtop = ""
sql = "select id from downtype where ts like '" & Rs_type("ts") & "%'"
RS.Open sql, DBconnect, adOpenKeyset
If Not RS.EOF Then
sqqq = ""
Do While Not RS.EOF
sqqq = sqqq & "" & RS("id") & ", "
RS.MoveNext
Loop
End If
RS.Close
'################ 读取本类top10 ################
sql = "select top 10 cxn,softpath from down where tid in (" & sqqq & ") order by hits desc"
'Label2.Caption = sql
'Label2.Refresh
RS.Open sql, DBconnect, adOpenKeyset
If RS.EOF Then
txtop = "·还没有下载"
Else
Do While Not RS.EOF
h = h + 1
txtop = txtop & "<img src=""../../images/c.gif"" border=""0"" width=""1"" height=""3"">·<a href=""../" & RS("softpath") & """>" & RS("cxn") & "</a><br>" & vbCrLf
If h >= 10 Then Exit Do
RS.MoveNext
Loop
h = 0
End If
RS.Close
'################################
'################ 读取软件列表 ################
sql = "select tid,cxn,hot,cd,body,hits,date,softpath from down where tid in (" & sqqq & ") order by date desc"
RS.Open sql, DBconnect, adOpenKeyset
If RS.EOF Then
lb = lb & "<table border=""0"" width=""100%"" cellspacing=""0"" cellpadding=""0""><tr><td width=""100%"" height=""30"" align=""center"">对不起,本类还没有软件呢！</td></tr></table>"
mpage = 1
allshu = 0
Else
RS.PageSize = MaxPerPage '得到每页数
mpage = RS.PageCount '得到总页数
'RS.Move (currentPage - 1) * MaxPerPage
allshu = RS.RecordCount
currentPage = 0
While Not RS.EOF
pencat = pencatbak
currentPage = currentPage + 1
Label2.Caption = "正在生成：" & tid & "/" & cum & "分类 第" & currentPage & "/" & mpage & "页"
Label2.Refresh
h = 0
lb = ""
Do While Not RS.EOF
h = h + 1
lb = lb & "<table border=""0"" width=""100%"" cellspacing=""0"" cellpadding=""0""><tr><td width=""65%"" height=""22"">·<a href=""../" & RS("softpath") & """ target=_blank><b>" & RS("cxn") & "<b></a></td>" & vbCrLf
lb = lb & "<td width=""15%"" align=""center"" height=""22"">" & Year(RS("date")) & "-" & Month(RS("date")) & "-" & Day(RS("date")) & "</td><td width=""15%"" align=""center"" height=""22"">" & vbCrLf
For i = 1 To RS("hot")
lb = lb & "<img src=""../../images/d_star.gif"" border=""0"">" & vbCrLf
Next
lb = lb & "</td><td width=""10%"" align=""center"" height=""22"">" & RS("hits") & "</td></tr><tr><td width=""100%"" colspan=""5""> " & vbCrLf
If RS("body") <> "" Then
tempstr = Replace(RS("body"), "<br>", "")
tempstr = Replace(tempstr, "<p>", "")
tempstr = Replace(tempstr, "<b>", "")
tempstr = Replace(tempstr, "<", "")
tempstr = Replace(tempstr, " ", "")
tempstr = Replace(tempstr, " ", "")
lb = lb & "" & Left(tempstr, 95) & "..."
Else
lb = lb & "还不错，自己看看吧！"
End If
lb = lb & "<br><img src=""../../images/c.gif"" border=""0"" width=""1"" height=""4""><br><FONT color=""#666666"">软件类别：" & vbCrLf
lb = lb & "<a href=""../" & Sortdir & RS("tid") & "/" & RS("tid") & "_1.htm""><FONT color=""#666666"">" & RS("cd") & "</FONT></a>" & vbCrLf
lb = lb & "</td></tr><tr><td width=""100%"" colspan=""5"" height=""3""></td></tr><tr><td width=""100%"" colspan=""5"" height=""1"" background=""../../images/bg_dot.gif""></td></tr><tr><td width=""100%"" colspan=""5"" height=""3""></td></tr></table>" & vbCrLf
If h >= MaxPerPage Then Exit Do
RS.MoveNext
Loop
'#########读取页次
lb = lb & "<table border=""0"" width=""100%"" cellspacing=""0"" cellpadding=""0""><tr><td>页次：<b>" & currentPage & "</b>/<b>" & mpage & "</b> 每页<b>" & MaxPerPage & "</b> 本类软件<b>" & allshu & "</b>个</td><td width=""45%""><p align=""center"">"
pageno = currentPage
If CInt(pageno) > 1 Then
lb = lb & "<a href=../" & Sortdir & "" & tid & "/" & tid & "_1.htm title=""最前页"">"
End If
lb = lb & "<font face=""Webdings"">9</font></a> "
If CInt(pageno) > 1 Then
lb = lb & "<a href=../" & Sortdir & "" & tid & "/" & tid & "_" & pageno - 1 & ".htm title=""上一页"">"
End If
lb = lb & "<font face=""Webdings"">7</font></a>"
pp = CInt(pageno) - 2
If pp < 1 Then
pp = 1
End If
p = 0
For pno = pp To mpage
p = p + 1
If pno * 1 = CInt(pageno) * 1 Then
lb = lb & " <font color=""#FF0000"">[" & pno & "]</font>"
Else
lb = lb & " <a href=../" & Sortdir & "" & tid & "/" & tid & "_" & pno & ".htm>[" & pno & "]</a>"
End If
If p >= 5 Then Exit For
Next
lb = lb & " "
If CInt(pageno) < mpage Then
lb = lb & "<a href=../" & Sortdir & "" & tid & "/" & tid & "_" & pageno + 1 & ".htm title=""下一页"">"
End If
lb = lb & "<font face=""Webdings"">8</font></a> "
If CInt(pageno) < mpage Then
lb = lb & "<a href=../" & Sortdir & "" & tid & "/" & tid & "_" & mpage & ".htm title=""最后页"">"
End If
lb = lb & "<font face=""Webdings"">:</font></a></td><td><table cellpadding=""0"" cellspacing=""0"">"
lb = lb & "<form onsubmit=""window.location=this.KKK2.options[this.KKK2.selectedIndex].value; return false;"">"
lb = lb & "<tr><td>转到第<select name=""select"" onchange=""javascript:window.location.href=this.options[this.selectedIndex].value"">"
For i = 1 To mpage
Selected = ""
If currentPage = i Then
Selected = " selected"
End If
lb = lb & "<option value=../" & Sortdir & "" & tid & "/" & tid & "_" & i & ".htm" & Selected & ">" & i & "</option>"
Next
lb = lb & "</select>页</td></tr></form></table>< /td></tr></table>"
'################ 读取完成 ################
pencat = Replace(pencat, "Txtop", txtop)
pencat = Replace(pencat, "T_LB", lb)
pencat = Replace(pencat, "T_TYPE", thistype)
foldername = App.Path & "\..\sort\" & Sortdir & "" & tid & ""
sortpath = App.Path & "\..\sort\" & Sortdir & "" & tid & "\" & tid & "_" & currentPage & ".htm"
If Dir(foldername, 16) = "" Then
MkDir foldername
End If
Open sortpath For Output As #1
Print #1, pencat
Close #1
If Not RS.EOF Then RS.MoveNext
Wend
End If
RS.Close
Rs_type.MoveNext
Wend
Rs_type.Close
Label1.Caption = "开始时间：" & time1 & " 结束时间：" & Time()
End Sub |
博文
