<%
'**************************************************************************************************'
'                                 大路整站靜態生成程式              '
'                                   by     呂鑫                   '
'                                   date   2006.3.30                                               '
'                              

http://www.dalu2000.com                                       '
'***************************************************************************************************
const def_page = "index.asp"   '定義程式開始讀取的頁面
const html_url = "html"     '定義靜態程式存放的目錄
const html_flag = 0      '0為只生成沒有的,1為全部重新生成
const temp_name = "~temp.html"   '臨時檔名稱

dim dalu,fsoname
set dalu = new allhtml
call dalu.page_load()
'**************************************************************************************************** 
class allhtml

 Function IsObjInstalled(strClassString)
  On Error Resume Next
  IsObjInstalled = False
  Err = 0
  Dim xTestObj
  Set xTestObj = Server.CreateObject(strClassString)
  If 0 = Err Then IsObjInstalled = True
  Set xTestObj = Nothing
  Err = 0
 End Function

 sub page_load()
  fsoname = checkfso()
  'call deltemp()
  'response.Write("刪除OK")
  'response.End()
  'on error resume next
  call getfile(def_page)
  'call checkurl(html_url)
 end sub
 
 Function checkfso()
  '為了相容伺服器上不同名的FSO
  if IsObjInstalled("scripting.daluabc2000fso") then
   checkfso = "scripting.daluabc2000fso"
  else
   checkfso = "scripting.filesystemobject"
  end if
 end Function
 
 sub getfile(def_page)
  dim content,fso,ts
  response.Write def_page&"<br />"
  call asptohtm(def_page)
  '讀取檔案
  set fso = server.CreateObject(fsoname)
  set ts = fso.OpenTextFile(server.MapPath(html_url&"/"&temp_name),1)
  content = ts.ReadAll
  '釋放記憶體
  set fso = nothing
  set ts = nothing
  '正則判斷內容裡面是否有連結並替換
  content = chglink(content,def_page)
 end sub
 
 sub writefile(content,page_url)
  '把內容寫入靜態頁面
  set fso = server.CreateObject(fsoname)
  set ts_w = fso.OpenTextFile(server.MapPath(page_url),2,true)
  ts_w.write content 
  '釋放記憶體
  set fso = nothing
  set ts_w = nothing
 end sub
 
 sub deltemp()
  set fso = server.CreateObject(fsoname)
  if fso.fileExists(server.MapPath(html_url&"/"&temp_name)) then
   fso.deletefile(server.MapPath(html_url&"/"&temp_name))
  end if 
  set fso = nothing
 end sub
 
 function checkfile(page_url)
  set fso = server.CreateObject(fsoname)
  if fso.fileExists(server.MapPath(page_url)) then
   checkfile = false
  else
   checkfile = true
  end if
  '釋放記憶體
  set fso = nothing
 end function
 
 function chglink(content,page_url)
  Dim regEx,Matches,match,str,j
  dim part1,part2,part3,part4,part5 '檔名及字尾
  dim html_name
  j = 0
  str = "href="&chr(34)&"([^ /s/t/r/n.:;>"&chr(34)&"]+).([^ /t/r/n.:;>"&chr(34)&"]+)"&chr(34)&"" '設定模板

  content = CheckExp(str,content,"href="&chr(34)&"$1.$2"&chr(34)&"")
  Set regEx=New RegExp    '建立一個新對像
  regEx.Pattern=str     '設定模板 
  regEx.IgnoreCase=true    '搜尋是否區分大小寫的 true表是不區分 flase表示區分
  regEx.Global=True     '搜尋是否應用於整個字串
  
  set Matches = regEx.execute(content)
    
  for each match in Matches
   part1 = CheckExp(str,match.value,"$1")
   part2 = CheckExp(str,match.value,"$2")
   part4 = part1&"."&part2
   part3 = part1&tohtml(part2)
   '替換連結地址為靜態
   content = replace(content,chr(34)&part4&chr(34),chr(34)&part3&chr(34))
  next
  
  page_url = split(page_url,".")
  html_name = page_url(0)&tohtml(page_url(1))
  response.Write "生成靜態頁面"&html_url&"/"&html_name&"<br />"
  call writefile(content,html_url&"/"&html_name)
  
  for each match in Matches
   part1 = CheckExp(str,match.value,"$1")
   part2 = CheckExp(str,match.value,"$2")
   part4 = part1&"."&part2
   part3 = part1&tohtml(part2)
   '遞迴遍歷所有連結
   '判斷檔案是否已經生成
   if instr(part4,"asp") then
    if checkfile(html_url&"/"&part3) then
     call getfile(part4)
    end if
   end if
  next
  
  chglink = content
 end function
 
 function tohtml(key)
  dim temp
  '靜態頁面生成規則
  if instr(key,"css") or instr(key,"js") or instr(key,"html") or instr(key,"htm") or instr(key,"jpg") or instr(key,"gif")  then
   key = "."&key
  elseif instr(key,"?") then  
   if instr(key,"&") then
    key = replace(replace(replace(key,"asp?","_"),"=",""),"&","_")&".html"
   else
    key = replace(replace(replace(key,"asp?","_"),"=",""),"&","_")&".html"
   end if
  elseif instr(key,"asp") then
   key = ".html"
  else
   key = key
  end if
  tohtml = key
 end function
 
 Function CheckExp(patrn,strng,tagstr)
  Dim regEx,Matches

  Set regEx=New RegExp     '建立一個新對像
  regEx.Pattern=patrn      '設定模板
  regEx.IgnoreCase=true     '搜尋是否區分大小寫的 true表是不區分 flase表示區分
  regEx.Global=True      '搜尋是否應用於整個字串
   
  Matches=regEx.replace(strng,tagstr)  '匹配並替代字串
    
  CheckExp=Matches      '返回函式結果
 end function
 
 function bin2str(bin)
  dim tmp,ustr
   tmp=""
  for i=1 to LenB(bin)-1
   ustr=AscB(MidB(bin,i,1))
   if ustr>127 then
    i=i+1
    tmp=tmp&chr(ustr*256+AscB(MidB(bin,i,1)))
   else
    tmp=tmp&chr(ustr)
   end if
  next
  bin2str=tmp
 end function
 
 sub asptohtm(strUrl)
  'strUrl = geturl(http://www.blog.com.cn/strUrl)
  '讀取頁面生成靜態頁面
  dim objXmlHttp,objAdoStream
  
  set objXmlHttp = Server.CreateObject("MSXML2.XMLHTTP")
   objXmlHttp.open "POST",geturl(http://www.blog.com.cn/strUrl),false
   objXmlHttp.send()
   
   binFileData = objXmlHttp.responseBody
  
  '判斷是否臨時檔案是否存在
  'call deltemp()

  set objAdoStream = Server.CreateObject("ADODB.Stream")
   objAdoStream.Type = 1
   objAdoStream.Open
   objAdoStream.Write(binFileData)
   objAdoStream.SaveToFile Server.MapPath(html_url&"/"&temp_name),2
   objAdoStream.Close
   
  set objXmlHttp = nothing
  set objAdoStream = nothing
 end sub
 
 function geturl(http://www.blog.com.cn/strUrl)
  dim tem_ary,tem_url
  tem_url = request.ServerVariables("url")
  tem_ary = split(request.ServerVariables("url"),"/")
  tem_url = replace(tem_url,"/"&tem_ary(ubound(tem_ary)),"")
  
  geturl = "http://"&request.ServerVariables("SERVER_NAME")&tem_url&"/"&strUrl
 end function
 
end class
%>