<% '========================================================= ' @ Maurizio '=============================================== Sub QSort(a,ilo,ihi) '=============================================== ' Funzione quick-sort. ' Script creato da Zani Andrea ' lo=ilo hi=ihi mezzo=a((lo+hi)/2) do while (a(lo)mezzo) hi=hi-1 wend if lo<=hi then t=a(lo) a(lo)=a(hi) a(hi)=t lo=lo+1 hi=hi-1 end if loop while (lo<=hi) if hi>ilo then call QSort(a,ilo,hi) if lo.." & vbcrlf Set objFSO = Server.CreateObject("Scripting.FileSystemObject") Set Cartella = objFSO.GetFolder( sDir ) For Each objItem In cartella.SubFolders ' Se volete visualizzare i files mettete ' For Each objItem In cartella.files str_combo = str_combo & "" & vbcrlf Next response.write vbcrlf & str_combo end sub '=============================================== Sub ComboFF ( sDir , sPath , sFilter) '=============================================== ' genera il contenuto delle combobox ' ' sDir ; Directory di partenza ' sPath ; tipo di percorso nell' ""option value"" : full > percorso completo | short > solo il nome del file ' sFilter ; filtro basato su espressione regolare 'response.write "" str_selected = "" 'str_combo = str_combo & "" & vbcrlf str_combo = str_combo & "" & vbcrlf Set objFSO = Server.CreateObject("Scripting.FileSystemObject") Set Cartella = objFSO.GetFolder( sDir ) if sPath = "short" then sDir = "" For Each objItem In Cartella.Files ' Se volete visualizzare i files mettete ' For Each objItem In cartella.files if ReFind( objItem.Name , sFilter ) then str_combo = str_combo & "" & vbcrlf end if Next response.write vbcrlf & str_combo end sub '=============================================== Sub ComboFile ( sDir , sPath) '=============================================== ' genera il contenuto delle combobox ' ' sDir ; Directory di partenza ' sPath ; tipo di percorso nell' ""option value"" : full > percorso completo | short > solo il nome del file ' ' se risulta neecessario filtrare per tipo di file usare ComboFF 'response.write "" str_selected = "" 'str_combo = str_combo & "" & vbcrlf str_combo = str_combo & "" & vbcrlf Set objFSO = Server.CreateObject("Scripting.FileSystemObject") Set Cartella = objFSO.GetFolder( sDir ) if sPath = "short" then sDir = "" For Each objItem In Cartella.Files ' Se volete visualizzare i files mettete ' For Each objItem In cartella.files str_combo = str_combo & "" & vbcrlf Next response.write vbcrlf & str_combo end sub '========================================================= Function inputfile( spage , mode , stext) '========================================================= ' page rappresenta il percorso del file ' mode la modalità di accesso ( r w a ) ( read , write , add ) ' stext il testo del file ' 12.7.2005 | maurizio ' aggiunto controllo per eliminazione file inputfile = "" if mode <> "ww" then spage = trim(spage) spage = replace(spage,vbtab,"") spage = replace(spage,vbcr,"") spage = replace(spage,vblf,"") end if if mode = "d" then mode = 0 rewrite = false end if if mode = "r" then mode = 1 rewrite = false end if if mode = "w" then mode = 2 rewrite = true end if if mode = "ww" then mode = 2 rewrite = true end if if mode = "a" then mode = 8 rewrite = false end if sFullPage = Server.MapPath(spage) 'response.write sFullPage Dim filesys, txtfile, line Set filesys = CreateObject("Scripting.FileSystemObject") if mode = 2 then Set txtfile = filesys.CreateTextFile(sFullPage,rewrite,0) else if filesys.FileExists( sFullPage ) then if mode = 0 then filesys.DeleteFile sFullPage , true else Set txtfile = filesys.OpenTextFile(sFullPage,mode,0) end if else ' se il file non è presente esco restituendo ' inputfile = "" if mode = 8 then ' se sei in appand ma il file non esiste lo Set txtfile = filesys.CreateTextFile(sFullPage,true,0) else mode = 0 end if end if end if if mode = 1 then 'Do ' line = txtfile.ReadLine ' inputfile = inputfile & line & VbCrLf ' 'Loop Until txtfile.AtEndOfStream inputfile = txtfile.ReadAll() txtfile.Close else if mode > 1 then txtfile.write sText end if End Function '========================================================= Function clean( stext , bhtml ) '========================================================= ' clean = "" if not IsNull(stext) and not IsEmpty(stext) then stext = trim ( stext ) if ( bhtml = true ) then stext = Replace(stext,"<","<") stext = Replace(stext,">",">") stext = Replace(stext,"""",""") stext = Replace(stext,"'","'") stext = Replace(stext,vbCrLf,"
") stext = Replace(stext,vbLf,"") else stext = Replace(stext,vbCr,"") stext = Replace(stext,vbLf,"") end if clean = stext end if End function '========================================================= Function HtmlEncode( stext ) '========================================================= stext = Replace(stext,"<","<") stext = Replace(stext,">",">") stext = Replace(stext,"""",""") stext = Replace(stext,"'","'") stext = Replace(stext,vbCrLf,"
") stext = Replace(stext,vbLf,"") HtmlEncode = trim(stext) end function '========================================================= Function ReCode( sText ) '========================================================= ReCode = sText & " " ' definisco caratteri ReCode = Replace(ReCode,"[b]" ,"" ) ReCode = Replace(ReCode,"[/b]" ,"" ) ReCode = Replace(ReCode,"[i]" ,"" ) ReCode = Replace(ReCode,"[/i]" ,"" ) ReCode = Replace(ReCode,"[li]" ,"
  • " ) ReCode = Replace(ReCode,"[/li]" ,"
    • " ) ReCode = Replace(ReCode,"[ul]" ,"" ) ReCode = trim( ReCode ) end function '========================================================= Function hex_code(s1) '========================================================= for x = 1 to len(s1) shex1 = shex1 & hex ( asc( mid(s1,x,1) ) ) next hex_code = shex1 end function '========================================================= Function hex_decode(s1) '========================================================= for x = 1 to len(s1) Step 2 c = c & chr(Clng("&H" & mid(s1,x,2))) next hex_decode = c end function '========================================================= Function byte_code( sPlain ) '========================================================= lLength = Len(sPlain) ReDim byteIn(lLength-1) For lCount = 1 To lLength byte_code(lCount-1)=CByte(AscB(Mid(sPlain,lCount,1))) Next end function '========================================================= Function byte_decode( aCode ) '========================================================= lLength = UBound(aCode) + 1 sTemp = "" For lCount = 0 To lLength - 1 byte_decode = byte_decode & Chr(aCode(lCount)) Next end function '========================================================= Function ReReplace( sText , sPattern , sReplace) '========================================================= Dim re Set re = New RegExp 'Specify the pattern 're.Pattern = "(\d{3})(\d{3})(\d{4})" re.Pattern = sPattern re.Global = True re.IgnoreCase = True 'Use the replace method to perform the formatting 'ReReplace = re.Replace(sText, "($1) $2-$3") ReReplace = re.Replace(sText, sReplace) end function '========================================================= Function ReFind( sText , sPattern ) '========================================================= ReFind = false Dim re Set re = New RegExp re.Pattern = sPattern 're.Global = true 're.IngnoreCase = false Set ReMatches = re.Execute(sText) if ReMatches.Count > 0 Then ReFind = true end function '========================================================= Function ReGet( sText , sPattern ) '========================================================= ReGet = "" Dim re Set re = New RegExp re.Pattern = sPattern 're.Global = true 're.IngnoreCase = false Set ReMatches = re.Execute(sText) if ReMatches.Count > 0 Then ReGet = ReMatches(0) end function '========================================================= Sub CDOmail (mailto, mailfrom, mailsubject, mailbody , pathattachment) '========================================================= Dim CDOMail ' istanza di CDO.Message Set CDOMail = Server.CreateObject("CDO.Message") CDOMail.To = mailto CDOMail.from = mailfrom CDOMail.subject = mailsubject ' testo da inviare CDOMail.htmlbody = mailbody if pathattachment <> "" then CDOMail.AddAttachment pathattachment end if ' invio del messaggio CDOMail.Send End sub '========================================================= Sub CDOmailtxt (mailto, mailfrom, mailsubject, mailbody , pathattachment) '========================================================= Dim CDOMail ' istanza di CDO.Message Set CDOMail = Server.CreateObject("CDO.Message") CDOMail.To = mailto CDOMail.from = mailfrom CDOMail.subject = mailsubject ' testo da inviare CDOMail.TextBody = mailbody if pathattachment <> "" then CDOMail.AddAttachment pathattachment end if ' invio del messaggio CDOMail.Send End sub '========================================================= Sub CDOmailhtm (mailto, mailfrom, mailsubject, mailbody , pathattachment) '========================================================= Dim CDOMail ' istanza di CDO.Message Set CDOMail = Server.CreateObject("CDO.Message") CDOMail.To = mailto CDOMail.from = mailfrom CDOMail.subject = mailsubject ' testo da inviare CDOMail.htmlbody = mailbody if pathattachment <> "" then CDOMail.AddAttachment pathattachment end if ' invio del messaggio CDOMail.Send End sub '========================================================= Sub CDOmailFile (mailto, mailfrom, mailsubject, sFilePath , pathattachment) '========================================================= Dim CDOMail ' istanza di CDO.Message Set CDOMail = Server.CreateObject("CDO.Message") CDOMail.To = mailto CDOMail.from = mailfrom CDOMail.subject = mailsubject ' testo da inviare CDOMail.htmlbody = inputfile( sFilePath , "r" , "") if pathattachment <> "" then CDOMail.AddAttachment pathattachment end if ' invio del messaggio CDOMail.Send End sub '========================================================= Sub PrintPost () '========================================================= response.write "

    --------------" set oRequest = request.form n = 0 for each r in oRequest n = n + 1 response.write "

  • " & n & " :: Form :: " & r & " :: " & request(r) next set oRequest = request.querystring n = 0 for each r in oRequest n = n + 1 response.write "
  • " & n & " :: QueryString :: " & r & " :: " & request(r) next response.write "
    --------------

    " set oRequest = Nothing End sub '========================================================= Function GetURL(sUrl) '========================================================= ' ' 08.07.2005 | maurizio ' prima release ' 09.02.2006 | maurizio ' aggiunto isvoid e verifica se l'url è valido if not isvoid(sUrl) then if instr(sUrl,"http://") = 0 then athisurl = split(Request.ServerVariables("URL") ,"/") thispage = athisurl(ubound(athisurl)) sUrl = "http://" & Request.ServerVariables("SERVER_NAME") & replace(Request.ServerVariables("URL"),thispage,sUrl) end if debug "# url: " & sUrl Dim Http Set Http = Server.CreateObject("WinHttp.WinHttpRequest.5.1") Http.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0+(compatible;+MSIE+6.0;+Windows+NT+5.2)" Http.Open "GET", sUrl Http.Send If CInt(Http.Status) <> 200 Then GetURL = Http.Status & " " & Http.StatusText & "
    " & sUrl & "
    " & Http.ResponseText else GetURL = Http.ResponseText end if else GetURL = "Formato indirizzo non valido: " & setvalue(sUrl) end if End Function '========================================================= Function RemoveTag( sText , sTag ) '========================================================= ' ' 12.11.2005 | maurizio ' rimuove dal testo il tag indicato ' se non viene specifiato nessun tag elimitati tutti i tag sTemp = trim(sText) Set RegEx = New RegExp RegEx.Global = True RegEx.IgnoreCase = True RegEx.Pattern = "" if isvoid(sTag) then RegEx.Pattern = "<[^>]*>| [ ]+" else aTag = split( sTag , "," ) For i = 0 To UBound(aTag) if not isvoid( aTag(i) ) then RegEx.Pattern = RegEx.Pattern & "<" & aTag(i) & "[^>]*>|]*>|" end if Next RegEx.Pattern = RegEx.Pattern & " [ ]+" end if sReturn = RegEx.Replace(sTemp, "") Set RegEx = Nothing RemoveTag = sReturn End Function %>