sk_itemdatabase.asp

清风信息自动采集生成系统 很好用的大家试试看

%>
<br>
<form method="post" action="Sk_ItemDatabase.asp?Action=UpData">
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="tableBorder">
  <tr>
	<td colspan="2" align="center" class="title" height=22><b>检查更新数据</b></td>
	</tr>
</table>
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="tableBorder">
  <tr>
	<td height="34" align='left' class="tdbg">请选择要更新的数据</td>
  </tr>
  <tr>
	<td align='left' class="tdbg">
        <input type="checkbox" name="ChannelData" value="yes">频道部分数据&nbsp;&nbsp;
        <input type="checkbox" name="ItemData" value="yes" checked disabled>项目数据
        </td>
  </tr>
  <tr align='center'>
        <td height='40' colspan='3' class="tdbg"><input name='submit' type=submit value=' 开始更新 '></td>
  </tr>
</table>
</form>
<%Else
   Call UpData()
End If
End Sub%>

<%
sub CompactData()
        '关闭数据库链接
        Call CloseConnItem() 
	Dim fso, Engine,strDBPath,DBPath,DbTemp
	DBPath = server.mappath(DbItem)'数据库文件
        Randomize timer
	DbTemp = CStr(Clng(8999999*Rnd+1000000))
	if instr(DBPath,"/") then 
		strDBPath = left(DBPath,instrrev(DBPath,"/"))
	else
		strDBPath = left(DBPath,instrrev(DBPath,"\"))
	end if
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	If fso.FileExists(DBPath) Then
		Set Engine = CreateObject("JRO.JetEngine")
		Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBPath," Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDBPath & DbTemp & ".asa"
		fso.CopyFile strDBPath & DbTemp & ".asa",DBPath
		fso.DeleteFile(strDBPath & DbTemp & ".asa")
		ErrMsg="<br>数据库压缩成功!"
	Else
                FoundErr=True
		ErrMsg="<br><li>数据库没有找到!</li>"
	End If
	Set fso = nothing
	Set Engine = nothing
        If FoundErr=True Then
           Call WriteErrMsg(ErrMsg)
        else
           Call WriteSucced(ErrMsg)
        End If
end sub

sub BackUpData()
	Dim fso,BackPath,BackMdb
        BackPath=Trim(Request("BackPath"))
        BackMdb=Trim(Request("BackMdb"))
        If BackPath="" Then
           FoundErr=True
           ErrMsg="<br><li>请指定备份目录！</li>"
        else
           BackPath=Replace(BackPath," ","")
        End If
        If BackMdb="" Then
           FoundErr=True
           ErrMsg=ErrMsg & "<br><li>请指定备份文件名</li>"
        Else
           BackMdb=Replace(BackMdb," ","")
        End If
        If FoundErr<>True Then
           Set fso = Server.CreateObject("Scripting.FileSystemObject")
	   If fso.FolderExists(server.mappath(BackPath))=False Then
              fso.CreateFolder(server.mappath(BackPath))
           End If
           If fso.FileExists(server.mappath(BackPath & "/" & BackMdb & ".asa"))=True then
              fso.DeleteFile(server.mappath(BackPath & "/" & BackMdb & ".asa"))
           End If
           fso.copyfile server.mappath(DbItem),server.mappath(BackPath & "/" & BackMdb & ".asa")
	   If fso.FileExists(server.mappath(BackPath & "/" & BackMdb & ".asa"))=True Then
              ErrMsg="<br>数据库备份成功!"
              ErrMsg=ErrMsg & "<br>数据库备份为：" & BackPath & "/" & BackMdb & ".asa"
           Else
              FoundErr=True
              ErrMsg="<br><li>数据库备份失败!</li>"
	   End If
	   Set fso = nothing
	End If
        If FoundErr=True Then
           Call WriteErrMsg(ErrMsg)
        Else
           Call WriteSucced(ErrMsg)
        End If
end sub


sub RestoreData()
	Dim fso,RestorePath
        RestorePath=Trim(Request("RestorePath"))
        If RestorePath="" Then
           FoundErr=True
           ErrMsg="<br><li>请指定原备份的数据库文件名！</li>"
        else
           RestorePath=Replace(RestorePath," ","")
        End If

        If FoundErr<>True Then
           Set fso = Server.CreateObject("Scripting.FileSystemObject")
           If fso.FileExists(server.mappath(RestorePath))=True then
              fso.copyfile server.mappath(RestorePath),server.mappath(DbItem)
              ErrMsg="<br>数据库恢复成功!"
           Else
              FoundErr=True
              ErrMsg=ErrMsg & "<br><li>数据库：" & RestorePath & " 不存在！"
           End If
	   Set fso = nothing
	End If
        If FoundErr=True Then
           Call WriteErrMsg(ErrMsg)
        Else
           Call WriteSucced(ErrMsg)
        End If
end sub

Sub LeadOutData
   Dim fso,ItemMdb,ItemMdbPath,LeadOutMdb,RsF,SqlF,RsLead,SqlLead,ItemIDTemp
   LeadOutMdb=trim(request.form("LeadOutMdb"))
   ItemID=trim(request.form("ItemID"))
   ItemMdb=DbItem
   ItemMdbPath=Left(DbItem,Instrrev(DbItem,"/")-1)
   If Instr(ItemMdb,"/")>0 Then
      ItemMdbPath=Left(ItemMdb,InstrRev(ItemMdb,"/"))
   End If
   If LeadOutMdb="" then
      FoundErr=True
      ErrMsg="<br><li>数据库地址不能为空！</li>"
   End If
   If ItemID="" Then
      FoundErr=True
      ErrMsg=ErrMsg & "<br><li>请选择要导出的项目</li>"
   Else
      ItemID=Replace(ItemID," ","")
   End If
   If FoundErr<>True And ObjInstalled<>False Then
      Set fso = Server.CreateObject("Scripting.FileSystemObject")
      If fso.FileExists(Server.MapPath(LeadOutMdb)) Then
      Else
         '不存在则创建
         If fso.FileExists(Server.MapPath(ItemMdbPath & "ItemTemp.mdb")) Then
            fso.CopyFile Server.MapPath(ItemMdbPath & "ItemTemp.mdb"),Server.MapPath(LeadOutMdb)
         Else
            FoundErr=True
            ErrMsg=ErrMsg& "<br>用于导出项目的数据库：ItemTemp.mdb不存在！"
         End If
      End If
      set fso=nothing
   End If

   If FoundErr<>True Then
      dim connstrLead,connLead
      Set connLead = Server.CreateObject("ADODB.Connection")
      connstrLead="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(LeadOutMdb)
      connLead.Open connstrLead
      If Err Then
         err.Clear
         FoundErr=True
	 ErrMsg=ErrMsg & "<br>数据库连接出错，请确认数据库是否存在。"
      End If

      If FoundErr<>True Then
         ConnLead.execute("Delete From Item")
         ConnLead.execute("Delete From Filters")
         Set RsItem=server.createobject("adodb.recordset")         
         SqlItem="select * from Item where ItemID in(" & ItemID & ") order by ItemID DESC"         
         RsItem.open SqlItem,ConnItem,1,1
         If Not RsItem.Eof then
            Do while Not RsItem.Eof
               '打开数据库
               Set RsLead=server.createobject("adodb.recordset")         
               SqlLead="select * from Item"         
               RsLead.open SqlLead,ConnLead,1,3
               RsLead.AddNew
               for i=1 to Ubound(copyitem)
			   RsLead(i)=RsItem(i)
			   next
               RsLead.Update
               RsLead.Close
               Set RsLead=Nothing

               '过滤信息
               Set RsF=server.createobject("adodb.recordset")         
               SqlF="select * from Filters Where ItemID=" & RsItem("ItemID") & " order by ItemID DESC"         
               RsF.open SqlF,ConnItem,1,1              
               If Not RsF.Eof then
                  Do While Not RsF.Eof
                     Set RsLead=server.createobject("adodb.recordset")         
                     SqlLead="select * from Filters"         
                     RsLead.open SqlLead,ConnLead,1,3
                     RsLead.AddNew
                     RsLead("ItemID")=ItemIDTemp
                     RsLead("FilterName")=RsF("FilterName")
                     RsLead("FilterObject")=RsF("FilterObject")
                     RsLead("FilterType")=RsF("FilterType")
                     RsLead("FilterContent")=RsF("FilterContent")
                     RsLead("FisString")=RsF("FisString")
                     RsLead("FioString")=RsF("FioString")
                     RsLead("FilterRep")=RsF("FilterRep")
                     RsLead("Flag")=RsF("Flag")
                     RsLead("PublicTf")=RsF("PublicTf")
                     RsLead.Update
                     RsLead.Close
                     Set RsLead=Nothing
                  RsF.MoveNext
                  Loop
               End If
               RsF.Close
               Set RsF=Nothing

            RsItem.MoveNext
            Loop
         End If
         RsItem.Close
         Set RsItem=Nothing
      End If
      ConnLead.close
      set connlead=nothing

   End If
   If FoundErr<>True Then
      ErrMsg="<br>数据导出成功"
      ErrMsg=ErrMsg & "<br>数据导出为：" & LeadOutMdb
      Call WriteSucced(ErrMsg)
   Else
      Call WriteErrMsg(ErrMsg)
   End If
End Sub

Sub ShowLeadInData
   Dim LeadInMdb,connstrLead,connLead,RsLead,SqlLead
   LeadInMdb=Trim(Request("LeadInMdb"))
   If LeadInMdb="" Then
      FoundErr=True 
      ErrMsg="<br><li>数据库地址不能为空！</li>"
   End If
   If FoundErr<>True Then
      On error resume next
      Set connLead = Server.CreateObject("ADODB.Connection")
      connstrLead="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(LeadInMdb)
      connLead.Open connstrLead
      If Err Then
         err.Clear
         FoundErr=True
         ErrMsg=ErrMsg & "<br><li>数据库连接出错，请确认数据库是否存在。</li>"
      End If
      If FoundErr<>True Then
         Set RsLead=server.createobject("adodb.recordset")         
         SqlLead="select ItemID,ItemName,ChannelID,ClassID,SpecialID,Flag from Item order by ItemID DESC"         
         RsLead.open SqlLead,ConnLead,1,1
         If Not RsLead.Eof then
%>
<br>
<form method="post" action="Sk_ItemDatabase.asp?Action=LeadInData">
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="tableBorder">
  <tr>
	<td colspan="2" align="center" class="title" height=22><b>项目导入</b></td>
	</tr>
</table>
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="tableBorder">
   <tr class="tdbg">         
      <td width="5%" height="22" align="center" class=ButtonList>选择</td>                 
      <td width="10%" align="center" class=ButtonList>项目名称</td>
      <td width="10%" height="22" align="center" class=ButtonList>所属频道</td> 
      <td width="10%" height="22" align="center" class=ButtonList>所属栏目</td> 
      <td width="10%" align="center" class=ButtonList>所属专题</td>   
      <td width="5%" align="center" class=ButtonList>状态</td>      
   </tr>         
<%
            Do While Not RsLead.Eof
%>
   <tr class="tdbg">         
      <td width="5%" height="22" align="center"><input type="checkbox" value=<%=RsLead("ItemID")%> name="ItemID" onClick="unselectall(this.form)" style="border: 0px;background-color: #E1F4EE;"></td>                 
      <td width="10%" align="left"><%=RsLead("ItemName")%></td>
      <td width="10%" height="22" align="center"><%Call Admin_ShowChannel_Name(RsLead("ChannelID"))%></td> 
      <td width="10%" height="22" align="center"><%Call Admin_ShowClass_Name(RsLead("ChannelID"),RsLead("ClassID"))%></td> 
      <td width="10%" align="center"><%Call Admin_ShowSpecial_Name(RsLead("ChannelID"),RsLead("SpecialID"))%></td>
      <td width="5%" align="center">
      <%If RsLead("Flag")=True Then
           Response.write "√"
        Else
           Response.Write "<font color=red>×</font>"
      End If%>
      </td>            
   </tr>   
<%
            RsLead.MoveNext
            Loop
%>
</table>
<table width="100%" border="0" align="center" cellpadding="0" cellspacing="1" class="tableBorder">
   <tr class="tdbg">
     <td align="center">
	<input name="LeadInMdb" type="hidden" value="<%=LeadInMdb%>">
        <input name="chkAll" type="checkbox" id="chkAll" onclick=CheckAll(this.form) value="checkbox" >全选&nbsp;&nbsp;&nbsp;&nbsp;
	<input name="step" type="hidden" value="1">
	<input name="submit" type=submit value=" 确&nbsp;&nbsp;&nbsp;定 " style="cursor: hand;background-color: #cccccc;">
     </td>
   </tr>
</table>
</form>
<%
         Else
            FoundErr=True
            Errmsg=ErrMsg &  "<br>无任何记录！"
         End If
         RsLead.Close
         Set RsLead=Nothing
      End If
      connLead.close