marcus Gemeos

Uso visual basico entoa VBA

Uso visual basico

Obrigado! :)

Olá pessoal, Um sistema de código completo de páginação: Banco de dados: clientes.mdb Tabela: contatos Campos: id, nome, telefone, email <%'Efetuando a conexão com a base de dados criada ----------------------- Set Conn = Server.CreateObject("AdoDb.Connection") Conn.provider="Microsoft.Jet.OLEDB.4.0" Conn.connectionstring=Server.Mappath("/paginacao/clientes.mdb") Conn.open '-------------------------------------------------------------------------- 'Vamos criar o objeto Record Set -> neste caso é necessário declará-lo, 'pois vamos utilizar algumas funções deste objeto Set RS = Server.CreateObject("adodb.recordset") RS.PageSize = 5 'quantidade de registros por página. Você pode alterar sem conforme precise. 'Vamos fazer a busca na tabela contatos SQL = "select * from contatos" RS.Open SQL,Conn,3,3 'Vamos agora verificar exceções do tipo “fim de arquivo” (EOF), se a página atual é menor 'que zero, se é maior que o número total de páginas, etc. IF RS.EOF then Response.Write "nenhum registro encontrado" Response.End 'paramos o programa ELSE 'Definindo em qual pagina o visitante está IF Request.QueryString("pagina")="" then intpagina=1 ELSE IF cint(Request.QueryString("pagina"))<1 then intpagina=1 ELSE IF cint(Request.QueryString("pagina"))> RS.PageCount then intpagina=RS.PageCount ELSE intpagina=Request.QueryString("pagina") END IF END IF END IF END IF 'Fim das verificações de exceções 'Usamos a propriedade AbsolutePage para dizer ao RS que página ele esta RS.AbsolutePage=intpagina ' Inicia o contador que vai controlar os registros mostrados intrec=0 'Enquanto o contador for menor que a quantidade de registros mostrados ou ' não for o final do arquivo While intrec < RS.PageSize and not RS.EOF '------------------- AQUI VEM TUDO O QUE SERÁ PAGINADO ----------------------- response.write RS("nome") & " - " & RS("telefone") & " - " & RS("email") & "<BR>" '--------------------------------------------------------------------------------------------- RS.MoveNext ' Acrescenta +1 ao contador intrec=intrec+1 'Se for EOF (fim de arquivo), imprimir branco na tela IF RS.EOF then response.write " " END IF Wend 'fim do loop 'Vamos verificar se não é a página 1, para podermos colocar o link “anterior”. IF intpagina > 1 then 'AND intpagina <> 2 Then %> <align="center"><font color="#FFFFFF" size="2" face="Verdana"><span style="background-color: #808080">&nbsp;<a href="paginacao.asp?pagina=<%=intpagina - 1%>"><font color="#FFFFFF"><b>Anterior</b></font></a>&nbsp;</span><% END IF %> <% For i = 1 to rs.PageCount%> <align="center"><font color="#FFFFFF" size="2" face="Verdana"><span style="background-color: #808080">&nbsp;<a href="paginacao.asp?pagina=<%=i%>"><font color="#FFFFFF"><b><%=i%></b></font></a>&nbsp;</span> <% Next %> <% 'Se não estivermos no último registro contado, então é mostrado o link p/ a próxima página IF strcomp(intpagina,rs.PageCount) <> 0 then %> <align="center"><font color="#FFFFFF" size="2" face="Verdana"><span style="background-color: #808080">&nbsp;<a href="paginacao.asp?pagina=<%=intpagina + 1%>"><font color="#FFFFFF"><b>Próxima</b></font></a>&nbsp;</span> </font></font></font> <% END IF %>

Olá pessoal, Como faço para a função abaixo dê uma mensagem de alerta invés de surgir uma mensagem impressa? If byteCount > 55000 Then '200.000 Response.write "Tamanho do arquivo grande</font><br>" Aqui ficasse a mensagem de alerta! Response.End End If Preciso! Obrigado! Marcus

Olá pessoal, Para quem precisa realmente de um sistema de upload, esse sistema abaixo é de uplaod sem componentes, então roda em qualquer servidor perfeitamente! Esse sistema é composto do arquivo "upload.asp" e do arquivo "upload.inc", esse último é chamado pelo "upload.asp" em comando CODE<!---#INCLUDE FILE="upload.inc" --->como vocês iram vê nos códigos abaixo. O sistema abaixo tem opções a mais ativas em: Não permitir arquivos não imagens, não permitir que usuários escrevam no campo do upload, limita o tamanho de arquivos (imagens) a ser enviadas. Só faltou a opção de renomear arquivos antes de enviar, que seria uma boa também, mas infelizmente não tem mas vocês poderam acrescentar essa opção sem problemas! Os códigos abaixo não precisam praticamente de alteração nenhuma, só vocês prestarem atenção no local (diretório ou pasta) onde irão serem enviadas as imagens ao servidor. Para você criar o arquivo "uplaod.inc", você poderá fazer perfeitamente em um bloco de notas, na hora de salvar os códigos aqui disponíveis, vá no menu "Salvar como..." escreva no campo adequado "upload.inc" não esquecendo de deixar o campo "Salvar como tipo" em *.txt e sim em *.*, ou seja, todos os arquivos, entenderam né? E salva e pronto, o arquivo terá extençao *.inc. Abaixo segue os códigos completos de cada arquivo (upload.asp e upload.inc) Críticas, só fazerem se quiserem! Abraços! Marcus upload.asp <% byteCount = Request.TotalBytes 'RequestBin = Request.BinaryRead(byteCount) %> <html> <head> <title>SISTEMA DE UPLOAD DE QUALQUER ARQUIVO</title> <script LANGUAGE="JavaScript"> function Limit(upload) { if (upload.file.value == "") { alert("Informe o nome do arquivo (.jpg ou .gif)!"); upload.file.focus(); return false; } vfile = upload.file.value; tfile = vfile.length; if ((vfile.substr(tfile - 4, 4) != ".jpg") & (vfile.substr(tfile - 4, 4) != ".gif")){ alert("O arquivo deverá possuir o formato (.jpg ou .gif)!"); upload.file.focus(); return false; } } </script> </head> <body> <form name=upload OnKeyPress="return false;" OnSubmit= "return Limit(upload);" method=post ENCTYPE="multipart/form-data"> Arquivo : <input type="file" name="file" size="20"><br> <input type=submit Name="Action" value="Upload do Arquivo"> </form></input></input> </body></HTML> <!---#INCLUDE FILE="upload.inc" ---> <% If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request method must be "POST" For get the fields Set Fields = GetUpload() If byteCount > 200000 Then Response.write "Tamanho do arquivo: <font color='red'>" & byteCount & "</font><br>" Response.Write "<center>Não deu certo...</center>" Response.End End If 'ALTERE A PASTA CHAMADA "imgs" PELA PASTA QUE VOCÊ QUER DEIXAR AS IMGENS 'LEMBRANDO QUE DEVE ESTAR NO MESMO DIRETORIO DAS PAGINAS UPLOAD.ASP E UPLOAD.INC 'DEIXE A BARRA "/" - PARA USAR NO SEU SITE 'DEIXE A BARRA "\" - PARA USAR NA SUA INTRANET FilePath = Server.MapPath("imgs") & "\" & Fields("file").FileName Fields("file").Value.SaveAs FilePath End If 'BY - ROBERTO GODOY %> upload.inc 'BYROBERTO GODOY - SAMPA - SP - BRASIL <script RUNAT=SERVER LANGUAGE=VBSCRIPT> Const IncludeType = 2 Dim UploadSizeLimit Function GetUpload() Dim Result Set Result = Nothing If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'la méthode REQUEST doit être POST Dim CT, PosB, Boundary, Length, PosE CT = Request.ServerVariables("HTTP_Content_Type") ' lit le header If LCase(Left(CT, 19)) = "multipart/form-data" Then 'qui doit être de type "multipart/form-data" PosB = InStr(LCase(CT), "boundary=") 'Finds boundary If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separetes boundary PosB = InStr(LCase(CT), "boundary=") If PosB > 0 then 'Patch pour l'erreur IE PosB = InStr(Boundary, ",") If PosB > 0 Then Boundary = Left(Boundary, PosB - 1) end if Length = CLng(Request.ServerVariables("HTTP_Content_Length")) If "" & UploadSizeLimit <> "" Then UploadSizeLimit = CLng(UploadSizeLimit) If Length > UploadSizeLimit Then Request.BinaryRead (Length) Err.Raise 2, "GetUpload", "Upload size " & FormatNumber(Length, 0) & "B exceeds limit of " & FormatNumber(UploadSizeLimit, 0) & "B" Exit Function End If End If If Length > 0 And Boundary <> "" Then Boundary = "--" & Boundary Dim Head, Binary Binary = Request.BinaryRead(Length) 'lit les données à partir du poste client Set Result = SeparateFields(Binary, Boundary) Binary = Empty 'Mise à jour des variables Else Err.Raise 10, "GetUpload", "ERR 10" End If Else Err.Raise 11, "GetUpload", "ERR 11" End If Else Err.Raise 1, "GetUpload", "ERR 10" End If Set GetUpload = Result End Function Function SeparateFields(Binary, Boundary) Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary Dim Fields Boundary = StringToBinary(Boundary) PosOpenBoundary = InStrB(Binary, Boundary) PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0) Set Fields = CreateObject("Scripting.Dictionary") Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary) Dim HeaderContent, FieldContent, bFieldContent Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type Dim Field, TwoCharsAfterEndBoundary PosEndOfHeader = InStrB(PosOpenBoundary + Len(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf)) HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2) bFieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary - (PosEndOfHeader + 4) - 2) GetHeadFields BinaryToString(HeaderContent), Content_Disposition, FormFieldName, SourceFileName, Content_Type Set Field = CreateUploadField()'See the JS function bellow Set FieldContent = CreateBinaryData(bFieldContent,LenB(bFieldContent)) Field.Name = FormFieldName Field.ContentDisposition = Content_Disposition Field.FilePath = SourceFileName Field.FileName = GetFileName(SourceFileName) Field.ContentType = Content_Type Field.Length = FieldContent.Length Set Field.Value = FieldContent Fields.Add FormFieldName, Field TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBoundary + LenB(Boundary), 2)) isLastBoundary = TwoCharsAfterEndBoundary = "--" If Not isLastBoundary Then PosOpenBoundary = PosCloseBoundary PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary) End If Loop Set SeparateFields = Fields End Function Function GetHeadFields(ByVal Head, Content_Disposition, Name, FileName, Content_Type) Content_Disposition = LTrim(SeparateField(Head, "content-disposition:", ";")) Name = (SeparateField(Head, "name=", ";")) 'ltrim If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2) FileName = (SeparateField(Head, "filename=", ";")) 'ltrim If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2, Len(FileName) - 2) Content_Type = LTrim(SeparateField(Head, "content-type:", ";")) End Function Function SeparateField(From, ByVal sStart, ByVal sEnd) Dim PosB, PosE, sFrom sFrom = LCase(From) PosB = InStr(sFrom, sStart) If PosB > 0 Then PosB = PosB + Len(sStart) PosE = InStr(PosB, sFrom, sEnd) If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf) If PosE = 0 Then PosE = Len(sFrom) + 1 SeparateField = Mid(From, PosB, PosE - PosB) Else SeparateField = Empty End If End Function Function GetFileName(FullPath) Dim Pos, PosF PosF = 0 For Pos = Len(FullPath) To 1 Step -1 Select Case Mid(FullPath, Pos, 1) Case "/", "\": PosF = Pos + 1: Pos = 0 End Select Next If PosF = 0 Then PosF = 1 GetFileName = Mid(FullPath, PosF) End Function Function BinaryToStringSimple(Binary) Dim I, S For I = 1 To LenB(Binary) S = S & Chr(AscB(MidB(Binary, I, 1))) Next BinaryToStringSimple = S End Function Function BinaryToString(Binary) dim cl1, cl2, cl3, pl1, pl2, pl3 Dim L', nullchar cl1 = 1 cl2 = 1 cl3 = 1 L = LenB(Binary) Do While cl1<=L pl3 = pl3 & Chr(AscB(MidB(Binary,cl1,1))) cl1 = cl1 + 1 cl3 = cl3 + 1 if cl3>300 then pl2 = pl2 & pl3 pl3 = "" cl3 = 1 cl2 = cl2 + 1 if cl2>200 then pl1 = pl1 & pl2 pl2 = "" cl2 = 1 End If End If Loop BinaryToString = pl1 & pl2 & pl3 End Function Function RSBinaryToString(xBinary) Dim Binary if vartype(xBinary)=8 then Binary = MultiByteToBinary(xBinary) else Binary = xBinary Dim RS, LBinary Const adLongVarChar = 201 Set RS = CreateObject("ADODB.Recordset") LBinary = LenB(Binary) if LBinary>0 then RS.Fields.Append "mBinary", adLongVarChar, LBinary RS.Open RS.AddNew RS("mBinary").AppendChunk Binary RS.Update RSBinaryToString = RS("mBinary") Else RSBinaryToString = "" End If End Function Function MultiByteToBinary(MultiByte) Dim RS, LMultiByte, Binary Const adLongVarBinary = 205 Set RS = CreateObject("ADODB.Recordset") LMultiByte = LenB(MultiByte) if LMultiByte>0 then RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte RS.Open RS.AddNew RS("mBinary").AppendChunk MultiByte & ChrB(0) RS.Update Binary = RS("mBinary").GetChunk(LMultiByte) End If MultiByteToBinary = Binary End Function Function StringToBinary(String) Dim I, B For I=1 to len(String) B = B & ChrB(Asc(Mid(String,I,1))) Next StringToBinary = B End Function Function vbsSaveAs(FileName, ByteArray) Dim FS, TextStream Set FS = CreateObject("Scripting.FileSystemObject") Set TextStream = FS.CreateTextFile(FileName) TextStream.Write BinaryToString(ByteArray) ' BinaryToString is in upload.inc. TextStream.Close End Function </SCRIPT> <script RUNAT=SERVER LANGUAGE=JSCRIPT> function CreateUploadField(){ return new uf_Init() } function uf_Init(){ this.Name = null this.ContentDisposition = null this.FileName = null this.FilePath = null this.ContentType = null this.Value = null this.Length = null } function CreateBinaryData(Binary, mLength){ return new bin_Init(Binary, mLength) } function bin_Init(Binary, mLength){ this.ByteArray = Binary this.Length = mLength this.String = BinaryToString(Binary) this.SaveAs = jsSaveAs } //function jsBinaryToString(){ // return BinaryToString(this.ByteArray) //}; function jsSaveAs(FileName){ return vbsSaveAs(FileName, this.ByteArray) } //Simulate ByteArray class by JS/VBS - end </SCRIPT>

Olá pessoal, Para quem precisa realmente de um sistema de upload, esse sistema abaixo é de uplaod sem componentes, então roda em qualquer servidor perfeitamente! Esse sistema é composto do arquivo "upload.asp" e do arquivo "upload.inc", esse último é chamado pelo "upload.asp" em comando <!---#INCLUDE FILE="upload.inc" ---> como vocês iram vê nos códigos abaixo. O sistema abaixo tem opções a mais ativas em: Não permitir arquivos não imagens, não permitir que usuários escrevam no campo do upload, limita o tamanho de arquivos (imagens) a ser enviadas. Só faltou a opção de renomear arquivos antes de enviar, que seria uma boa também, mas infelizmente não tem :( mas vocês poderam acrescentar essa opção sem problemas! Os códigos abaixo não precisam praticamente de alteração nenhuma, só vocês prestarem atenção no local (diretório ou pasta) onde irão serem enviadas as imagens ao servidor. Para você criar o arquivo "uplaod.inc", você poderá fazer perfeitamente em um bloco de notas, na hora de salvar os códigos aqui disponíveis, vá no menu "Salvar como..." escreva no campo adequado "upload.inc" não esquecendo de deixar o campo "Salvar como tipo" em *.txt e sim em *.*, ou seja, todos os arquivos, entenderam né? E salva e pronto, o arquivo terá extençao *.inc. Abaixo segue os códigos completos de cada arquivo (upload.asp e upload.inc) Críticas, só fazerem se quiserem! Abraços! Marcus upload.asp <% byteCount = Request.TotalBytes 'RequestBin = Request.BinaryRead(byteCount) %> <html> <head> <title>SISTEMA DE UPLOAD DE QUALQUER ARQUIVO</title> <script LANGUAGE="JavaScript"> function Limit(upload) { if (upload.file.value == "") { alert("Informe o nome do arquivo (.jpg ou .gif)!"); upload.file.focus(); return false; } vfile = upload.file.value; tfile = vfile.length; if ((vfile.substr(tfile - 4, 4) != ".jpg") & (vfile.substr(tfile - 4, 4) != ".gif")){ alert("O arquivo deverá possuir o formato (.jpg ou .gif)!"); upload.file.focus(); return false; } } </script> </head> <body> <form name=upload OnKeyPress="return false;" OnSubmit= "return Limit(upload);" method=post ENCTYPE="multipart/form-data"> Arquivo : <input type="file" name="file" size="20"><br> <input type=submit Name="Action" value="Upload do Arquivo"> </form></input></input> </body></HTML> <!---#INCLUDE FILE="upload.inc" ---> <% If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request method must be "POST" For get the fields Set Fields = GetUpload() If byteCount > 200000 Then Response.write "Tamanho do arquivo: <font color='red'>" & byteCount & "</font><br>" Response.Write "<center>Não deu certo...</center>" Response.End End If 'ALTERE A PASTA CHAMADA "imgs" PELA PASTA QUE VOCÊ QUER DEIXAR AS IMGENS 'LEMBRANDO QUE DEVE ESTAR NO MESMO DIRETORIO DAS PAGINAS UPLOAD.ASP E UPLOAD.INC 'DEIXE A BARRA "/" - PARA USAR NO SEU SITE 'DEIXE A BARRA "\" - PARA USAR NA SUA INTRANET FilePath = Server.MapPath("imgs") & "\" & Fields("file").FileName Fields("file").Value.SaveAs FilePath End If 'BY - ROBERTO GODOY %> upload.inc 'BYROBERTO GODOY - SAMPA - SP - BRASIL <script RUNAT=SERVER LANGUAGE=VBSCRIPT> Const IncludeType = 2 Dim UploadSizeLimit Function GetUpload() Dim Result Set Result = Nothing If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'la méthode REQUEST doit être POST Dim CT, PosB, Boundary, Length, PosE CT = Request.ServerVariables("HTTP_Content_Type") ' lit le header If LCase(Left(CT, 19)) = "multipart/form-data" Then 'qui doit être de type "multipart/form-data" PosB = InStr(LCase(CT), "boundary=") 'Finds boundary If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separetes boundary PosB = InStr(LCase(CT), "boundary=") If PosB > 0 then 'Patch pour l'erreur IE PosB = InStr(Boundary, ",") If PosB > 0 Then Boundary = Left(Boundary, PosB - 1) end if Length = CLng(Request.ServerVariables("HTTP_Content_Length")) If "" & UploadSizeLimit <> "" Then UploadSizeLimit = CLng(UploadSizeLimit) If Length > UploadSizeLimit Then Request.BinaryRead (Length) Err.Raise 2, "GetUpload", "Upload size " & FormatNumber(Length, 0) & "B exceeds limit of " & FormatNumber(UploadSizeLimit, 0) & "B" Exit Function End If End If If Length > 0 And Boundary <> "" Then Boundary = "--" & Boundary Dim Head, Binary Binary = Request.BinaryRead(Length) 'lit les données à partir du poste client Set Result = SeparateFields(Binary, Boundary) Binary = Empty 'Mise à jour des variables Else Err.Raise 10, "GetUpload", "ERR 10" End If Else Err.Raise 11, "GetUpload", "ERR 11" End If Else Err.Raise 1, "GetUpload", "ERR 10" End If Set GetUpload = Result End Function Function SeparateFields(Binary, Boundary) Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary Dim Fields Boundary = StringToBinary(Boundary) PosOpenBoundary = InStrB(Binary, Boundary) PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0) Set Fields = CreateObject("Scripting.Dictionary") Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary) Dim HeaderContent, FieldContent, bFieldContent Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type Dim Field, TwoCharsAfterEndBoundary PosEndOfHeader = InStrB(PosOpenBoundary + Len(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf)) HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2) bFieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary - (PosEndOfHeader + 4) - 2) GetHeadFields BinaryToString(HeaderContent), Content_Disposition, FormFieldName, SourceFileName, Content_Type Set Field = CreateUploadField()'See the JS function bellow Set FieldContent = CreateBinaryData(bFieldContent,LenB(bFieldContent)) Field.Name = FormFieldName Field.ContentDisposition = Content_Disposition Field.FilePath = SourceFileName Field.FileName = GetFileName(SourceFileName) Field.ContentType = Content_Type Field.Length = FieldContent.Length Set Field.Value = FieldContent Fields.Add FormFieldName, Field TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBoundary + LenB(Boundary), 2)) isLastBoundary = TwoCharsAfterEndBoundary = "--" If Not isLastBoundary Then PosOpenBoundary = PosCloseBoundary PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary) End If Loop Set SeparateFields = Fields End Function Function GetHeadFields(ByVal Head, Content_Disposition, Name, FileName, Content_Type) Content_Disposition = LTrim(SeparateField(Head, "content-disposition:", ";")) Name = (SeparateField(Head, "name=", ";")) 'ltrim If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2) FileName = (SeparateField(Head, "filename=", ";")) 'ltrim If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2, Len(FileName) - 2) Content_Type = LTrim(SeparateField(Head, "content-type:", ";")) End Function Function SeparateField(From, ByVal sStart, ByVal sEnd) Dim PosB, PosE, sFrom sFrom = LCase(From) PosB = InStr(sFrom, sStart) If PosB > 0 Then PosB = PosB + Len(sStart) PosE = InStr(PosB, sFrom, sEnd) If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf) If PosE = 0 Then PosE = Len(sFrom) + 1 SeparateField = Mid(From, PosB, PosE - PosB) Else SeparateField = Empty End If End Function Function GetFileName(FullPath) Dim Pos, PosF PosF = 0 For Pos = Len(FullPath) To 1 Step -1 Select Case Mid(FullPath, Pos, 1) Case "/", "\": PosF = Pos + 1: Pos = 0 End Select Next If PosF = 0 Then PosF = 1 GetFileName = Mid(FullPath, PosF) End Function Function BinaryToStringSimple(Binary) Dim I, S For I = 1 To LenB(Binary) S = S & Chr(AscB(MidB(Binary, I, 1))) Next BinaryToStringSimple = S End Function Function BinaryToString(Binary) dim cl1, cl2, cl3, pl1, pl2, pl3 Dim L', nullchar cl1 = 1 cl2 = 1 cl3 = 1 L = LenB(Binary) Do While cl1<=L pl3 = pl3 & Chr(AscB(MidB(Binary,cl1,1))) cl1 = cl1 + 1 cl3 = cl3 + 1 if cl3>300 then pl2 = pl2 & pl3 pl3 = "" cl3 = 1 cl2 = cl2 + 1 if cl2>200 then pl1 = pl1 & pl2 pl2 = "" cl2 = 1 End If End If Loop BinaryToString = pl1 & pl2 & pl3 End Function Function RSBinaryToString(xBinary) Dim Binary if vartype(xBinary)=8 then Binary = MultiByteToBinary(xBinary) else Binary = xBinary Dim RS, LBinary Const adLongVarChar = 201 Set RS = CreateObject("ADODB.Recordset") LBinary = LenB(Binary) if LBinary>0 then RS.Fields.Append "mBinary", adLongVarChar, LBinary RS.Open RS.AddNew RS("mBinary").AppendChunk Binary RS.Update RSBinaryToString = RS("mBinary") Else RSBinaryToString = "" End If End Function Function MultiByteToBinary(MultiByte) Dim RS, LMultiByte, Binary Const adLongVarBinary = 205 Set RS = CreateObject("ADODB.Recordset") LMultiByte = LenB(MultiByte) if LMultiByte>0 then RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte RS.Open RS.AddNew RS("mBinary").AppendChunk MultiByte & ChrB(0) RS.Update Binary = RS("mBinary").GetChunk(LMultiByte) End If MultiByteToBinary = Binary End Function Function StringToBinary(String) Dim I, B For I=1 to len(String) B = B & ChrB(Asc(Mid(String,I,1))) Next StringToBinary = B End Function Function vbsSaveAs(FileName, ByteArray) Dim FS, TextStream Set FS = CreateObject("Scripting.FileSystemObject") Set TextStream = FS.CreateTextFile(FileName) TextStream.Write BinaryToString(ByteArray) ' BinaryToString is in upload.inc. TextStream.Close End Function </SCRIPT> <script RUNAT=SERVER LANGUAGE=JSCRIPT> function CreateUploadField(){ return new uf_Init() } function uf_Init(){ this.Name = null this.ContentDisposition = null this.FileName = null this.FilePath = null this.ContentType = null this.Value = null this.Length = null } function CreateBinaryData(Binary, mLength){ return new bin_Init(Binary, mLength) } function bin_Init(Binary, mLength){ this.ByteArray = Binary this.Length = mLength this.String = BinaryToString(Binary) this.SaveAs = jsSaveAs } //function jsBinaryToString(){ // return BinaryToString(this.ByteArray) //}; function jsSaveAs(FileName){ return vbsSaveAs(FileName, this.ByteArray) } //Simulate ByteArray class by JS/VBS - end </SCRIPT>

Olá, Como faço para limitar o tamanho do arquivo a ser enviado em upload sem componente para o servidor? Obrigado! Marcus

Ola, Possui uma macro em VB e gostaria de saber mais da propriedade do shdocvw.dll? Tambem tem alguma lista de propriedades de dll para IE? Obrigado! Marcus

Olá Andreia, Deu certo... lógica bem pensada hem? ;) Muito obrigado!!! Abraços! Marcus

Olá pessoal, Eu tou com um sistema de paginação funcionando tudo OK! mas ele só tem a opção de anterior e próximo, como faço para que entre esse anterior e próximo apareça os números? Que são as páginas... Obrigado! Marcus

Olá pessoal, Como faço para que o comando SQL liste pelo ordem de menores valores e também queria saber de maiores valores? Abaixo segue o código Obrigado! Marcus 'busca na tabela SQLLista = "SELECT * FROM Produtos Where COD_Categoria =" & varID SQLCategorias = "SELECT * FROM Categorias where COD_Categoria =" & varID rsLista.Open SQLLista,Conn,3,3 rsCategorias.Open SQLCategorias,Conn,3,3

Pode deixar, conseguir! Obrigado! Marcus

Olá amigo, Eu não tenho que "caputurar" qual o arquivo que está no campo de upload? Não entendi funcionamento da lógica... Eu pego totaldebytes dor um valor a ele... exemplo totaldebytes = 20000 e depois eu variavel que está apontada para o campo do form e comparo o tamanho do arquivo antes do processo de upload? Obrigado! Marcus

Olá amigo, Obrigado, tudo ok agora! Abraços! Marcus

Ola, O que achei só foi para confirmar e apertava Ok e ação continuava, mas o que quero é de SIM ou NÃO se ele aperta não, o botão não aciona a ação...entendeu? Obrigado! Marcus

Olá, Eu tentei e não obtive sucesso... Alguém poderia me ajudar? Precisso! Obrigado! Marcus

Olá pessoal, Não conseguir... Como posso capturar o tamanho do arquivo em um campo e medir... para impedir.... Obrigado! Marcus

Olá, Alguém poderia me passar esse código? Obrigado! Marcus

Ola, Queria um script onde alguém quando for deletar algo no botão delete de um site em ASP ele aparece uma mensagem pedindo para confirmar se sim ou não? Preciso! Obrigado! Marcus

Olá pessoal, Eu coloquei um script de banner rotativo e está funcionado tudo bem a página, mas fica aquela exclamação na barra de status do navegador... eu dou duplo click nesse icone e aparece o tipo de erro, mas não sei como resolver... Obrigado! Lonha: 96 Caractere: 1 Erro: 'mfBanners[...].0' é nulo ou não é um objeto Código: 0 URL: ..default.asp

Olá amigo poderia me dar um exemplo básico? Pois não tenho muito conhecimento sobre o FSO! Há... nem vi... vou procurar.... no totorias! Muito obrigado! Marcus

Não... Tem que trabalhar jutamente com algum comando script? Obrigado! <form name= "form1" method="POST" action="pagina.asp"> <p align="right"> <select size="1" name="Ordem" style="font-family: Verdana; font-size: 10 px; border-style: solid; border-width: 1"> <option selected value="Listar por:">Listar por:</option> <option value="Maior valor">Maior valor</option> <option value="Menor valor">Menor valor</option> </select></p> </form>

Upload sem componentes! Que vê o código? Obrigado!

Olá, Seguinte, tem o menu suspenso, igual esse que a gente escolhe o tipo de fonte de letra daqui do forum! Mas guando ele selecionar o nome ao clicar nesse menu suspenso, execute açao! Pois no nomal você seleciona e depois clica no botão... Será que entendeu? :huh: Obrigado! Marcus