<% Sub escreve (Str) Response.Write(Str & Vbcrlf) End Sub Sub W (Str) Response.Write(Str & Vbcrlf) End Sub 'Gera um número randômico, utilizado para gerar codigos de 'verificação de cadastros Function RandomNumber() Randomize RandomNumber = Int((899999 * Rnd) + 100000) End Function 'troca aspas simples por duplas Function sq(inputstr) sq = Replace(inputstr, "'", "''") End Function '------------------------------------------------------------------------------- ' Functions for default date format ' ANamedFormat = 0-7, where 0-4 same as VBScript ' 5 = "yyyy/mm/dd" ' 6 = "mm/dd/yyyy" ' 7 = "dd/mm/yyyy" Const EW_DATE_SEPARATOR = "/" Function EW_FormatDateTime(ADate, ANamedFormat) If IsDate(ADate) Then If ANamedFormat >= 0 And ANamedFormat <= 4 Then EW_FormatDateTime = FormatDateTime(ADate, ANameFormat) ElseIf ANamedFormat = 5 Then EW_FormatDateTime = Year(ADate) & EW_DATE_SEPARATOR & Month(ADate) & EW_DATE_SEPARATOR & Day(ADate) ElseIf ANamedFormat = 6 Then EW_FormatDateTime = Month(ADate) & EW_DATE_SEPARATOR & Day(ADate) & EW_DATE_SEPARATOR & Year(ADate) ElseIf ANamedFormat = 7 Then EW_FormatDateTime = Day(ADate) & EW_DATE_SEPARATOR & Month(ADate) & EW_DATE_SEPARATOR & Year(ADate) Else EW_FormatDateTime = ADate End If Else EW_FormatDateTime = ADate End If End Function Function EW_UnFormatDateTime(ADate, ANamedFormat) Dim arDateTime, arDate, AYear, AMonth, ADay ADate = Trim(ADate) While Instr(ADate, " ") > 0 ADate = Replace(ADate, " ", " ") Wend arDateTime = Split(ADate, " ") If UBound(arDateTime) < 0 Then EW_UnFormatDateTime = ADate Exit Function End If arDate = Split(arDateTime(0), EW_DATE_SEPARATOR) If UBound(arDate) = 2 Then If ANamedFormat = 6 Then EW_UnFormatDateTime = arDate(2) & EW_DATE_SEPARATOR & arDate(0) & EW_DATE_SEPARATOR & arDate(1) ElseIf ANamedFormat = 7 Then EW_UnFormatDateTime = arDate(2) & EW_DATE_SEPARATOR & arDate(1) & EW_DATE_SEPARATOR & arDate(0) Else ' ANamedFormat = 5 or other EW_UnFormatDateTime = arDateTime(0) End If If UBound(arDateTime) > 0 Then If IsDate(arDateTime(1)) Then ' Is time EW_UnFormatDateTime = EW_UnFormatDateTime & " " & arDateTime(1) End If End If Else EW_UnFormatDateTime = ADate End If End Function '------------------------------------------------------------------------------- ' Function for debug Sub Trace(aMsg) On Error Resume Next Dim fso, ts Set fso = Server.Createobject("Scripting.FileSystemObject") Set ts = fso.OpenTextFile(Server.MapPath("debug.txt"), 8, True) ts.writeline(aMsg) ts.Close Set ts = Nothing Set fso = Nothing End Sub %> <% '------------------------------------------------------------------------------- ' Functions for file upload Function stringToByte(toConv) For i = 1 to Len(toConv) tempChar = Mid(toConv, i, 1) stringToByte = stringToByte & chrB(AscB(tempChar)) Next End Function Function byteToString(toConv) For i = 1 to LenB(toConv) byteord = AscB(MidB(toConv, i, 1)) If byteord < &H80 Then ' Ascii byteToString = byteToString & Chr(byteord) Else ' Double-byte characters? If i < LenB(toConv) Then nextbyteord = AscB(MidB(toConv, i+1, 1)) On Error Resume Next ' Note: This line does NOT work on all systems due to limitation of the ' Chr() function byteToString = byteToString & Chr(CInt(byteord) * &H100 + CInt(nextbyteord)) If Err.Number <> 0 Then On Error GoTo 0 byteToString = byteToString & Chr(byteord) & Chr(nextbyteord) End If i = i + 1 ElseIf i = LenB(toConv) Then byteToString = byteToString & Chr(byteord) End If End If Next End Function Function getValue(name) If dict.Exists(name) Then gv = CStr(dict(name).Item("Value")) gv = Left(gv,Len(gv)-2) getValue = gv Else getValue = "" End If End Function Function getFileData(name) If dict.Exists(name) Then getFileData = dict(name).Item("Value") If LenB(getFileData) Mod 2 = 1 Then getFileData = getfileData & ChrB(0) End If Else getFileData = "" End If End Function Function getFileName(name) If dict.Exists(name) Then temp = dict(name).Item("FileName") tempPos = 1 + InStrRev(temp, "\") getFileName = Mid(temp, tempPos) Else getFileName = "" End If End Function Function getFileSize(name) If dict.Exists(name) Then getFileSize = LenB(dict(name).Item("Value")) Else getFileSize = 0 End If End Function Function getFileContentType(name) If dict.Exists(name) Then getFileContentType = dict(name).Item("ContentType") Else getFileContentType = "" End If End Function '------------------------------------------------------------------------------- ' Note: This function does NOT work on non English servers due to limitation of ' the Chr() function Function saveToFile(name, path) If dict.Exists(name) Then Dim temp temp = dict(name).Item("Value") Dim fso Set fso = Server.CreateObject("Scripting.FileSystemObject") Dim file Set file = fso.CreateTextFile(path) For tPoint = 1 to LenB(temp) file.Write Chr(AscB(MidB(temp,tPoint,1))) Next file.Close saveToFile = True Else saveToFile = False End If End Function %> <% 'Troca nome por sobrenome (sobrenome, nome 'chamada da funcao: VerNome("Fulano da Silva Neto") Function VerNome(str) Dim strPos, strMid, strAnt strPos = InStrRev(str, " ") strMid = Mid(str, strPos, Len(str)) strAnt = Left(str, strPos) VerNome = strMid & ", " & strAnt End Function %> <% Function dtIdade(data) 'Dim dtIdade dtIdade = DateDiff("yyyy",data,Now) & " anos" End Function %> <% '------------------------------------------------ 'MOSTRA MENUS de acordo com a categoria 'inttipo: 0 - texto; 1 - imagem '------------------------------------------------ function MostraMenusCSS(intCat, intTipo) W "" Dim SQL_Noticias2 Dim SQL_Noticias2_numRows Set SQL_Noticias2 = Server.CreateObject("ADODB.Recordset") SQL_Noticias2.ActiveConnection = xDb_Conn_Str SQL_Noticias2.Source = "SELECT * FROM sw_noticiascategorias WHERE ((catTipo = 1 or cattipo=3) and catDisponivel = 1) and (CatPertenceA = 0 or CatPertenceA is null) ORDER BY CatDesc asc" SQL_Noticias2.CursorType = 0 SQL_Noticias2.CursorLocation = 2 SQL_Noticias2.LockType = 1 SQL_Noticias2.Open() SQL_Noticias2_numRows = 0 W "" W "" end function %> <% '------------------------------------------------ 'MOSTRA SUBMENUS de acordo com a categoria '------------------------------------------------ function MostraSubMenusCSS(intCat,strMarcador) if intCat <> "" then 'se o param foi passado corretamente Dim SQL_Subs_sub Dim SQL_Subs_sub_numRows Set SQL_Subs_sub = Server.CreateObject("ADODB.Recordset") SQL_Subs_sub.ActiveConnection = xDb_Conn_Str SQL_Subs_sub.Source = "SELECT * FROM sw_noticiascategorias WHERE ((catTipo = 1 or cattipo=3) and catDisponivel = 1) and CatPertenceA = "& intCat &" ORDER BY CatDesc asc" SQL_Subs_sub.CursorType = 0 SQL_Subs_sub.CursorLocation = 2 SQL_Subs_sub.LockType = 1 SQL_Subs_sub.Open() SQL_Subs_sub_numRows = 0 If SQL_Subs_sub.EOF And SQL_Subs_sub.BOF Then W "" SQL_Subs_sub.close() else W "" W "" W "" end if 'se tem registros end if 'param correto end function %>