área para códigos

[Salgado 4]

Estou criando aqui um Tópico para que nós, usuários do IMASTERS FÓRUM, disponibilizemos códigos, scripts, funções e outras coisinhas interessantes e, acima de tudo, úteis.

 

Valeu?

[gastao 0]

Se a galera quiser, posso disponibilizar um sistema para isso...com comentários ....eu tenho um mais ou menos pronto, que eu fiz como agenda de tarefas, mas posso mudar o nome e algumas coisas.fica a critério de voces

[mebkocznski 0]

Aí Pessoal,

 

Segue um código intessante que pode ajudar !!!!!!

 

Para criar estas funções será necessário criarmos uma OCX - Activex

 

Ao abrir o Visual Basic click em "File" --> "New Project"

 

E Selecionem a opção "Activex Control"

 

Renomeando Projeto

 

Click com o botão direito em cima do "Project1"

 

Em ProjectName coloquem o que achar melhor, mas não se esqueçam de não colocar acentos ou espaços.

 

Utilizarei o seguinte nome "OCX1"

 

Agora vamos renomear o UserControl1 , eu utilizarei "MyFunctions"

 

Diminua o tamanho do form criado para o mínimo possível

 

Feito Isto, precisaremos fazer referência a um objeto

 

"Microsoft Outlook 9.0 Object Library"

 

Agora é só criar as funções abaixo:

 

 

'Por: Marcelo Eduardo Barcello Kopczynski

'Data: 30/06/2003

'Objetivo: Chama janela de envio de mensagens do outlook, inserindo

'no corpo da mensagem o texto passado por parâmetro

 

Public Sub EmailOutlook(CorpoEmail As String)

Dim ObjOut As Outlook.Application

Set ObjOut = New Outlook.Application

Dim Msg As Outlook.MailItem

Set Msg = ObjOut.CreateItem(olMailItem)

 

Msg.Display

Msg.HTMLBody = CorpoEmail

Msg.Attachments.Add MontaArquivo(CorpoEmail, "html")

 

Set ObjOut = Nothing

Set Msg = Nothing

End Sub

 

 

'Por: Marcelo Eduardo Barcello Kopczynski

'Data: 30/06/2003

'Objetivo: Monta arquivo no lado do cliente com o texto e extensão desejada

 

Function MontaArquivo(Texto As String, extensao As String) As String

Dim Obj As Object

Dim OFile As Object

Set Obj = CreateObject("scripting.filesystemobject")

Set OFile = Obj.CreateTextFile("C:\arquivo." & extensao, True)

OFile.Write Texto

MontaArquivo = "C:\arquivo." & extensao

OFile.Close

Set OFile = Nothing

Set Obj = Nothing

End Function

 

'Por: Marcelo Eduardo Barcello Kopczynski

'Data: 30/06/2003

'Objetivo: Inclui uma nova Tarefa no Outlook do Cliente

 

Public Sub AgendaOutlook(Assunto As String, Lugar As String, Inicio As Date, CorpoMensagem As String)

Dim ObjOut As Outlook.Application

Set ObjOut = New Outlook.Application

Dim Msg As Outlook.AppointmentItem

Set Msg = ObjOut.CreateItem(olAppointmentItem)

 

Msg.Subject = Assunto & " - Advocacia On Line"

Msg.Importance = olImportanceHigh

Msg.Location = Lugar

Msg.Start = Inicio

Msg.End = DateAdd("n", 30, Inicio)

Msg.ReminderOverrideDefault = True

Msg.ReminderSet = True

Msg.ReminderMinutesBeforeStart = 30

Msg.Body = CorpoMensagem

Msg.Save

 

Set ObjOut = Nothing

Set Msg = Nothing

 

If Err <> 0 Then

MsgBox Err.Description

Else

MsgBox "Compromisso criado com sucesso em seu Microsoft Outlook", vbInformation

End If

End Sub

 

'Por: Marcelo Eduardo Barcello Kopczynski

'Data: 30/06/2003

'Objetivo: Inclui um novo contato no Outlook do Cliente

 

Sub CriaEnderecoOutlook(Razao_Social As String, E_Mail As String, Endereco As String, Cidade As String, Estado As String, Fax As String, Telefone As String)

Dim ObjOut As Outlook.Application

Set ObjOut = New Outlook.Application

Dim Msg As Outlook.ContactItem

Set Msg = ObjOut.CreateItem(olContactItem)

Msg.Email1Address = E_Mail

Msg.FullName = Razao_Social

Msg.BusinessAddressStreet = Endereco

Msg.BusinessAddressCity = Cidade

Msg.BusinessAddressState = Estado

Msg.BusinessFaxNumber = Fax

Msg.BusinessTelephoneNumber = Telefone

Msg.Save

Msg.Close olPromptForSave

Msg.Display 0

End Sub

 

Tudo Pronto agora vamos compilar a OCX........

 

Click em "File" --> Make "Ocx.MyFunctions"

 

Encontrando o CLSID

 

Agora precisamos saber qual o CLSID que foi gerado para esta "OCX"

 

Click em iniciar --> executar --> Digitem "RegEdit"

 

Aberto o editor de registro, agora vamos localizar nosso objeto

Clikc em "editar" --> Localizar

 

Procurem pelo nome do Objeto que vocês criaram , neste exemplo seria

OCX.MyFunctions

 

O valor que aparecer na Chave Principal é nosso CLSID

 

Para utilizarmos as funções na página desejada , basta criarmos um objeto e acessar seus métodos via VbScript

 

 

Criando o objeto na página

<OBJECT classid="CLSID:C083CB1C-7FCC-4A1A-BF72-  E4FC26B18CD4"   height=0   style="LEFT: 0px; TOP: 0px"   width=200   VIEWASTEXT   id="MyOcx">  </object>

E Agora o VbScript

 

<script Language="vbscript">Sub NovaMensagem(CorpoMensagem)MyOcx.EmailOutlook CorpoMensagemEnd Sub</script>

Lembrando à todos que para que esta OCX funcione corretamente, o Internet Explorer do Cliente deve estar com as opções de Executar e Instalar activex todas ativas.....

 

Falow !!!!

 

Até a próxima

[mebkocznski 0]

Pessoal,Segue uma função que cria uma tabela em HTML, simplesmente informando o Recordset.........Para acessar a função façam o seguinteSet ORs = Server.CreateObject("adodb.recordset") ORs.Open "Select * from tb_usuario",oConn,2,2,1Response.Write CriaTabelaHtml(Ors)Falow Galera !!!!!!!!!

Function CriaTabelaHTML(ORs)Dim StrHtmlDim CountDim StrParametrosDim CorStrHtml = "<table id='" & nome_tabela & "' border=0 width=""100%"" Align=""center"">" & vbCrLfStrHtml = StrHtml & "<tr>" & vbCrLf        For Count = 0 to ORs.Fields.Count - 1            StrHtml = StrHtml & "<td BgColor=""#336699"" width='10%'><Font Color=""White"">" & ORs.Fields.item(Count).name & "</font></td>" & vbCrLf        NextStrHtml = StrHtml & "</tr>" & vbCrLf                        Cor = "White"        Do Until ORs.EOF                        If Cor = "White" Then                Cor = "Silver"                Else                Cor = "White"            End If                    StrHtml = StrHtml & "<tr>" & vbCrLf            For Count = 0 to ORs.Fields.Count - 1                StrHtml = StrHtml & "<td Bgcolor='" & Cor & "' width='10%'>" & ORs.Fields.Item(Count) & "</td>" & vbCrLf            Next                    StrHtml = StrHtml & "</tr>" & vbCrLf        ORs.MoveNext        Loop        StrHtml = StrHtml & "</table>" & vbCrLf            CriaTabelaHTML = StrHtml        If Err <> 0 then  Response.Write Err.Description & " - " & Err.number & " - " & Err.Source End if        End Function

[mebkocznski 0]

Srs,Essas funções que estarei passando a vocês só funcionam no SQL.....Ela ajuda e muito na adminstração de Tabelas .........Ela gerencia relacionamentos, chaves primárias, campos obrigatórios.É bem complexa mas vocês verificarão que poderão utiliza-la facilmente.Atenção....Para utilizar a função, deve ser criada a seguinte View no SQL Server :

Create View vw_visao_relacionamento_chave_secundariaasSelect Object_Name(constid) nome_relacionamento,Object_Name(fkeyid) tabela_secundaria,Object_Name(rkeyid)tabela_primaria,Col_name(fkeyid,fkey) chave_secundaria,Col_name(rkeyid,rkey) chave_primariafrom SysForeignKeys

Qualquer dúvida quanto ao código, estamos aí......

Set OConn = Server.CreateObject("adodb.connection")	OConn.Open "provider=SQLOLEDB;Server=;Database=;uid=;pwd="	nome_tabela = "nome_da_tabela"		Response.Write CriaTabelaHTMLAdmCompleta(oConn,nome_tabela)'*****************************************************************************'Data.......: 14/06/2003'Por........: Marcelo Eduardo B. Kopczynski'Objetivo...: Cria tabela HTML com todas as opções de administração'******************************************************************************Function CriaTabelaHTMLAdmCompleta(oConn, nome_tabela)Const adTinyInt = 16Const adSmallInt = 2Const adInteger = 3Const adBigInt = 20Const adUnsignedTinyInt = 17Const adUnsignedSmallInt = 18Const adUnsignedInt = 19Const adUnsignedBigInt = 21Const adSingle = 4Const adDouble = 5Const adCurrency = 6Const adDecimal = 14Const adNumeric = 131Const adBoolean = 11Const adError = 10Const adGuid = 72Const adDate = 7Const adDBDate = 133Const adDBTime = 134Const adDBTimestamp = 135Const adBSTR = 8Const adChar = 129Const adVarChar = 200Const adLongVarChar = 201Const adWChar = 130Const adVarWChar = 202Const adLongVarWChar = 203Const adBinary = 128Const adVarBinary = 204Const adLongVarBinary = 205Dim StrHtmlDim CountDim StrParametrosDim CorDim ColunaChaveDim NomeColuna Dim TamanhoColunaDim varColunasDim ParametrosDim ORsDim chave_primariaDim RetornoOrigem'*******************************************'Como precisamos de Um Recordset Conectado'para acessar as propriedades da conexão "Provider"'iremos usar uma conexão independente'*******************************************If oConn.State = 0 then oConn.Open     Set ORs = Server.CreateObject("adodb.recordset")    ORs.Open nome_tabela, oConn,1,3,2    campos_ignorados = "fazimento,Registra,nome_tabela,chave_primaria,campos_ignorados," & campos_ignorados    '********************************************************************'Definindo propriedades da tabela                                   *'varColuna(x,0) = Chave Primária - Boolean                          *'varColuna(x,1) = Auto Incrementação - Boolean                      *'varColuna(x,2) = Não utilizável neste contexto                     *'varColuna(x,3) = Nome Original - varchar                           *'varColuna(x,4) = Tamanho da Coluna ""Width"" - Integer             *'varColuna(x,5) = Tipo de Coluna - DataTypeEnum                     *'varColuna(x,6) = Aceita Nulo ? - Bollean                           *'varColuna(x,7) = Aceita Nulo ? - Bollean                           *'varColuna(x,8) = Aceita Nulo ? - Bollean                           *'varColuna(x,9) = Aceita Nulo ? - Bollean                           *'********************************************************************ReDim varColunas(ORs.Fields.Count, 9)            For Count = 0 To ORs.Fields.Count - 1            varColunas(Count, 0) = Trim(ORs.Fields.Item(Count).Properties("KEYCOLUMN"))            varColunas(Count, 1) = Trim(ORs.Fields.Item(Count).Properties("ISAUTOINCREMENT"))            varColunas(Count, 2) = ""            varColunas(Count, 3) = Trim(ORs.Fields.Item(Count).Name)            varColunas(Count, 4) = 100 \ (ORs.Fields.Count) & "%"            varColunas(Count, 5) = Trim(RetornaTipoCampo(ORs, ORs.Fields.Item(Count).Name))            varColunas(Count, 6) = Trim(RetornoPropriedadeColuna(oConn,nome_tabela, ORs.Fields.Item(Count).Name, "IsNullAble"))                        'Busca se há origem de informação            RetornoOrigem = RetornoOrigemInformacao(oConn,nome_tabela, Trim(ORs.Fields.Item(Count).Name))                            varColunas(Count, 7) = RetornoOrigem(0)                varColunas(Count, 8) = RetornoOrigem(1)                varColunas(Count, 9) = RetornoOrigem(2)                                        If Parametros = "" Then                Parametros = varColunas(Count, 3)               Else                Parametros = Parametros & "," & varColunas(Count, 3)            End If                        'Definição de campos chaves            If varColunas(Count, 0) Then                If chave_primaria = "" Then                    chave_primaria = varColunas(Count, 3)                    Else                    chave_primaria = chave_primaria & "," & varColunas(Count, 3)                End If                campos_ignorados = campos_ignorados & "," & varColunas(Count, 3)            End If                                    'Definição de campos Ignorados            If varColunas(Count, 1) Then                campos_ignorados = campos_ignorados & "," & varColunas(Count, 3)            End If                        Next            'Cria VbScript para manipulacao de Dados                    StrHtml = StrHtml & vbCrLf            StrHtml = StrHtml & vbCrLf            StrHtml = StrHtml & "<script Language=""VbScript"">" & vbCrLf            'Sub Registra Dados            StrHtml = StrHtml & "Sub RegistraDados()" & vbCrLf            StrHtml = StrHtml & "Set form = document.advocacia" & vbCrLf            StrHtml = StrHtml & "If form.Registra.value=""OK!"" then " & vbCrLf            StrHtml = StrHtml & "form.fazimento.value=""1""" & vbCrLf            StrHtml = StrHtml & "Else" & vbCrLf            StrHtml = StrHtml & "form.fazimento.value=""2""" & vbCrLf            StrHtml = StrHtml & "End if" & vbCrLf            StrHtml = StrHtml & "form.submit" & vbCrLf            StrHtml = StrHtml & "End Sub" & vbCrLf            StrHtml = StrHtml & vbCrLf                        'Captura Dados            StrHtml = StrHtml & vbCrLf            StrHtml = StrHtml & "Sub CapturaDados(" & Parametros & ")" & vbCrLf            StrHtml = StrHtml & "Set form = document.advocacia" & vbCrLf            For Count = 0 To (UBound(varColunas) - 1)                StrHtml = StrHtml & "form." & varColunas(Count, 3) & ".value=" & varColunas(Count, 3) & vbCrLf            Next            StrHtml = StrHtml & "form.Registra.value=""Alterar""" & vbCrLf            StrHtml = StrHtml & "Msgbox ""Opção de alteração ativada"",vbinformation" & vbCrLf            StrHtml = StrHtml & "form." & varColunas(1, 3) & ".Focus()" & vbCrLf            StrHtml = StrHtml & "End Sub" & vbCrLf            StrHtml = StrHtml & vbCrLf                        'Campos Obrigatórios            StrHtml = StrHtml & vbCrLf            StrHtml = StrHtml & "Sub CamposObrigatorios()" & vbCrLf            StrHtml = StrHtml & "Set form = document.advocacia" & vbCrLf            For Count = 0 To (UBound(varColunas) - 1)                If Not CBool(varColunas(Count, 1)) Then                If Not CBool(varColunas(Count, 6)) Then                    StrHtml = StrHtml & "if form." & varColunas(Count, 3) & ".value = """" then" & vbCrLf                    StrHtml = StrHtml & "Msgbox ""O Campo """"" & varColunas(Count,3) & """"" é de preenchimento obrigatório"",vbcritical" & vbCrLf                    StrHtml = StrHtml & "Exit Sub" & vbCrLf                    StrHtml = StrHtml & "End if" & vbCrLf                End If                End If            Next            StrHtml = StrHtml & "RegistraDados()" & vbCrLf            StrHtml = StrHtml & "End Sub" & vbCrLf            StrHtml = StrHtml & vbCrLf                                    StrHtml = StrHtml & vbCrLf            StrHtml = StrHtml & "Sub Excluir(" & Parametros & ")" & vbCrLf            StrHtml = StrHtml & "Set form = document.advocacia" & vbCrLf            For Count = 0 To (UBound(varColunas) - 1)                StrHtml = StrHtml & "form." & varColunas(Count, 3) & ".value=" & varColunas(Count, 3) & vbCrLf            Next            StrHtml = StrHtml & "Ask = Msgbox(""Tem certeza que deseja excluir este registro ?"",vbyesno + vbquestion)" & vbCrLf            StrHtml = StrHtml & "if Ask = vbyes then" & vbCrLf            StrHtml = StrHtml & "form.fazimento.value=3" & vbCrLf            StrHtml = StrHtml & "form.submit" & vbCrLf            StrHtml = StrHtml & "End If" & vbCrLf            StrHtml = StrHtml & "End Sub" & vbCrLf            StrHtml = StrHtml & "</script>" & vbCrLf            StrHtml = StrHtml & vbCrLfParametros = ""StrHtml = StrHtml & "<Form Name=""Advocacia"" Action='" & Request.ServerVariables("Script_Name") &  "'>" & vbCrLfStrHtml = StrHtml & "<table id='" & nome_tabela & "' border=0 width=""100%"" Align=""center"">" & vbCrLfStrHtml = StrHtml & "<tr>" & vbCrLf            'Criação do Cabeçalho da Tabela        For Count = 0 To ORs.Fields.Count - 1            StrHtml = StrHtml & "<td Bgcolor=""#336699"" width='" & varColunas(Count, 4) & "'><Font Color=""White"">" & varColunas(Count,3) & "</td>" & vbCrLf        Next        'Colunas de administração        StrHtml = StrHtml & "<td Bgcolor=""#336699"" width='0%'>#</td>" & vbCrLf        StrHtml = StrHtml & "<td Bgcolor=""#336699"" width='0%'>#</td>" & vbCrLfStrHtml = StrHtml & "</tr>" & vbCrLf        Cor = "White"                Do Until ORs.EOF            StrHtml = StrHtml & "<tr>" & vbCrLf            'Tabelas multicoloridas            If Cor = "White" Then                Cor = "White"                Else                Cor = "White"            End If                                                        'Criação da tabela propriamente dita                 For Count = 0 To ORs.Fields.Count - 1                         StrHtml = StrHtml & "<td Bgcolor='" & Cor & "' width='" & varColunas(Count, 4) & "'>" & ORs.Fields.Item(Count).Value & "</td>" & vbCrLf                                             If Parametros = "" Then                            Parametros = "'" & ORs.Fields.Item(Count).Value & "'"                        Else                            Parametros = Parametros & ",'" & ORs.Fields.Item(Count).Value & "'"                        End If                 Next                            'Colunas de administração                'Substitua a imagem Gif aqui pela que você utiliza                StrHtml = StrHtml & "<td Bgcolor='" & Cor & "' width='1%'><Img Src='" & PastaBase & "/images/alterar.gif' Style=""Cursor:hand"" Title=""Alterar"" OnClick=""CapturaDados " & Parametros & """></td>" & vbCrLf                StrHtml = StrHtml & "<td Bgcolor='" & Cor & "' width='1%'><Img Src='" & PastaBase & "/images/lixeira.gif' Style=""Cursor:hand"" Title=""Excluir"" OnClick=""Excluir " & Parametros & """></td>" & vbCrLf                Parametros = ""                            StrHtml = StrHtml & "<tr>" & vbCrLf            ORs.MoveNext        Loop                StrHtml = StrHtml & "<tr>" & vbCrLf        'Iniciamos a criação de linha de administração da tabela        For Count = 0 To ORs.Fields.Count - 1            If Not CBool(varColunas(Count, 1)) Then                Select Case varColunas(Count, 5)                    Case adInteger                        If CBool(varColunas(Count, 7)) Then                            StrCampo = CriaSelect(CStr(varColunas(Count, 9)), CStr(varColunas(Count, 9)), "", "Select * from " & varColunas(Count, 8), 1)                        Else                            StrCampo = "<Input Type=""text"" Name='" & varColunas(Count, 3) & "' Style=""Width=100%"">"                        End If                    Case Else                        StrCampo = "<Input Type=""text"" Name='" & varColunas(Count, 3) & "' Style=""Width=100%"">"                End Select                            Else                                        StrCampo = "<Input Type=""text"" Name='" & varColunas(Count, 3) & "' Value="""" Style=""Width=100%"" ReadOnly>"            End If                StrHtml = StrHtml & "<td width='" & varColunas(Count, 4) & "'>" & StrCampo & "</td>" & vbCrLf        Next        StrHtml = StrHtml & "<td width='2%' Colspan=""2""><Input Type=""BUTTON"" Name=""Registra"" Value=""OK!"" id=""botao"" OnClick=""CamposObrigatorios()"" Style=""Width=100%"" Align=""Center""></td>" & vbCrLf        StrHtml = StrHtml & "</tr>" & vbCrLf        StrHtml = StrHtml & "</table>" & vbCrLf                StrHtml = StrHtml & "<Input Type=""Hidden"" Name=""chave_primaria"" Value='" & chave_primaria & "'>" & vbCrLf        StrHtml = StrHtml & "<Input Type=""Hidden"" Name=""nome_tabela"" Value='" & nome_tabela & "'>" & vbCrLf        StrHtml = StrHtml & "<Input Type=""Hidden"" Name=""campos_ignorados"" Value='" & campos_ignorados & "'>" & vbCrLf        StrHtml = StrHtml & "<Input Type=""Hidden"" Name=""fazimento"" Value="""">" & vbCrLf                ORs.Close    Set ORs = Nothing    oConn.Close    Set oConn = Nothing    CriaTabelaHTMLAdmCompleta = StrHtml        If Err <> 0 then  Response.Write Err.Description 	End if	End Function'**********************************************************'Data.......: 14/06/2003'Por........: Marcelo Eduardo B. Kopczynski'Objetivo...: Define o tipo de CampoForm deve ser criado'**********************************************************Function RetornaTipoCampo(Recordset, CampoBd)Const adTinyInt = 16Const adSmallInt = 2Const adInteger = 3Const adBigInt = 20Const adUnsignedTinyInt = 17Const adUnsignedSmallInt = 18Const adUnsignedInt = 19Const adUnsignedBigInt = 21Const adSingle = 4Const adDouble = 5Const adCurrency = 6Const adDecimal = 14Const adNumeric = 131Const adBoolean = 11Const adError = 10Const adGuid = 72Const adDate = 7Const adDBDate = 133Const adDBTime = 134Const adDBTimestamp = 135Const adBSTR = 8Const adChar = 129Const adVarChar = 200Const adLongVarChar = 201Const adWChar = 130Const adVarWChar = 202Const adLongVarWChar = 203Const adBinary = 128Const adVarBinary = 204Const adLongVarBinary = 205Select Case Recordset(CampoBd).Type            Case adInteger, adBigInt, adUnsignedTinyInt, adUnsignedSmallInt, adUnsignedInt, adUnsignedBigInt            RetornaTipoCampo = adInteger                    Case adSingle, adDecimal, adNumeric, adDouble, adCurrency            RetornaTipoCampo = adCurrency                            Case adBoolean            RetornaTipoCampo = adBoolean                    Case adDate, adDBDate, adDBTime, adDBTimestamp            RetornaTipoCampo = adDate                    Case Else            RetornaTipoCampo = adVarChar                End SelectEnd FunctionFunction RetornoPropriedadeColuna(oConn,tabela, coluna, Propriedade)Set ORs = Server.CreateObject("adodb.recordset")StrSql = "Select " & Propriedade & " from syscolumns where id=Object_id('" & tabela & "') and name='" & coluna & "'"ORs.Open StrSQL,oConn,2,2,1    RetornoPropriedadeColuna = ORs(0)    ORs.Close    Set ORs = Nothing    End Function'*****************************************************************************'Data.......: 14/06/2003'Por........: Marcelo Eduardo B. Kopczynski'Objetivo...: Retorna o ForegnKey'******************************************************************************Function RetornoOrigemInformacao(OConn,tabela, coluna)Dim RetornoReDim Retorno(2)'***********************************************'RetornoOrigemInformacao(0) = True/False - Existe ou não o ForegnKey'RetornoOrigemInformacao(1) = nome_tabela_primaria'RetornoOrigemInformacao(2) = nome_coluna_primaria'************************************************StrSql = "Select "StrSql = StrSql & "a.tabela_primaria, "StrSql = StrSql & "a.chave_primaria, "StrSql = StrSql & "b.Colid "StrSql = StrSql & "from vw_visao_relacionamento_chave_secundaria a "StrSql = StrSql & "Left Join syscolumns b on "StrSql = StrSql & "a.tabela_primaria=Object_Name(b.id) and "StrSql = StrSql & "a.chave_primaria=b.name "StrSql = StrSql & "where  tabela_secundaria='" & tabela & "' and "StrSql = StrSql & "chave_secundaria='" & coluna & "'"Set Ors = Server.CreateObject("adodb.recordset")	Ors.open StrSql,Oconn,2,2,1If ORs.EOF Then    Retorno(0) = False    Retorno(1) = ""    Retorno(2) = ""    Else    Retorno(0) = True    Retorno(1) = ORs(0)    Retorno(2) = ORs(1)End IfRetornoOrigemInformacao = retornoEnd Function

[mjs 0]

Fiquei feliz um código para acessar o banco de dados que eu queria funcionou e peguei daqui!Eu tenho esse para paginação:<%Dim nomedica, numdica, nomeservernumdica = Request.QueryString("i")Function AbrirDica()set fs = Server.CreateObject("Scripting.FileSystemObject") dicacam = Server.MapPath ("/paginar/") & "/" & nomedicaset abrir = fs.OpenTextFile(dicacam) Response.Write(abrir.ReadAll)set fs = nothingset abrir = nothingEnd FunctionIf numdica <> "" Then nomedica = "pag" & numdica & ".txt"AbrirDica()ElseSet fs = Server.CreateObject("Scripting.FileSystemObject")caminho = Server.MapPath("/paginar/default.txt")set abrirlista = fs.OpenTextFile(caminho, 1, False, False) Response.Write(abrirlista.ReadAll)Set fs = nothingSet abrirlista = nothingEnd If%>Qualquer dúvida é só postar.

[d.eleete 0]

desculpem a intromissão, mas não é mais prático criar um sub forum (observem o forum de Photoshop)Abraço!

[Salgado 4]

Como o próprio silas deu a idéia e não a colocou em prática, eu abusadamente :) , criei o tópico, e, se não me engano, o Pacola pendurou.

Mas espero que a idéia inicial, um Sub-Fórum, não tenha sido abandonada.

E ai Moderadores / Administradores? <_<

Teremos ou não um Sub-Fórum de Códigos de usuários para usuários?

 

 

Valeu?

[tdeecken 0]

Vou entrar nessa, segue meu script, formulário de contato com os campos: nome, e-mail, assunto e mensagem, usando CDONTS.Nesse script você receberá em seu e-mail a mensagem e logo abaixo o IP do internauta.Basta apenas configurar seu e-mail no arquivo 'enviaemail.asp', ok!Arquivo 'form.asp':<form method=post action="enviaemail.asp"> <table border="0" width="18%" cellspacing="0" cellpadding="0" align="left"> <tr> <td width="96%" height="21" valign="bottom"> <p align="left"><font size="1" face="Verdana"><b>Seu nome:</b></font> </td> </tr> <tr> <td width="96%" height="23"> <p align="left"><font size="1" face="Verdana"> <input type="text" name="nome" size="21" style="font-family: Verdana; font-size: 9 pt; border-style: solid; border-width: 1" maxlength="50"> </font> </td> </tr> <tr> <td width="96%" height="21" valign="bottom"> <p align="left"><font size="1" face="Verdana"><b>E-mail:</b></font> </td> </tr> <tr> <td width="96%" height="23"> <p align="left"><font size="1" face="Verdana"> <input type="text" name="email" size="21" style="font-family: Verdana; font-size: 9 pt; border-style: solid; border-width: 1" maxlength="50"> </font> </td> </tr> <tr> <td width="96%" height="21" valign="bottom"><font size="1" face="Verdana"><b>Assunto:</b></font></td> </tr> <tr> <td width="96%" height="23"><font size="1" face="Verdana"> <input type="text" name="assunto" size="21" style="font-family: Verdana; font-size: 9 pt; border-style: solid; border-width: 1" maxlength="50"> </font></td> </tr> <tr> <td width="96%" height="21" valign="bottom"> <p align="left"><font size="1" face="Verdana"><b>Mensagem:</b></font> </td> </tr> <tr> <td width="96%"> <p align="left"><font size="1" face="Verdana"> <textarea rows="5" name="mensagem" cols="21" style="font-family: Verdana; font-size: 9 pt; border-style: solid; border-width: 1"></textarea> <input type="hidden" name="hiddenField" value="<%= Request.ServerVariables("REMOTE_ADDR")%>"> </font> </td> </tr> <tr> <td width="96%" height="40"> <p align="left"><font face="Verdana"> <input type="submit" src="file:///C|/WINDOWS/Desktop/C%F3gidos%20e%20Utilit%E1rios/C%F3gidos%20e%20Utilit%E1rios/C%F3gidos%20e%20Utilit%E1rios/imagens/enviar.gif" value="Enviar" name="enviar"> </font> </td> </tr> </table></form>Arquivo 'enviaemail.asp'<%str_nome = trim(request.form("nome"))str_email = trim(request.form("email"))str_assunto = trim(request.form("assunto"))str_mensagem = trim(request.form("mensagem"))str_ip = trim(request.form("hiddenField"))str_mensagememail = "" & str_mensagem & "<br><br>IP: " & str_ip & "" set mensagem = server.createobject("CDONTS.NewMail")mensagem.from = str_emailmensagem.to = "seuemail@seuprovedor.com.br"mensagem.Subject = str_assuntomensagem.bodyformat = 0mensagem.mailformat = 0mensagem.Body = str_mensagememailmensagem.SendSet objMail = nothingresponse.write "Sua mensagem foi enviada com sucesso!"%>Espero ter ajudado!

[1sys 0]

Ja q nosso amigo tdeecken postou uma resposta sobre componentes de e-mail vou postar um um codigo q suporta a maioria dos email instalados no servidor

 

 

Obs: Foi retirado da net, ñ lembro aonde ok

Code....

 

select case lcase(strMailMode)

case "abmailer"

Set objNewMail = Server.CreateObject("ABMailer.Mailman")

objNewMail.ServerAddr = strMailServer

objNewMail.FromName = strFromName

objNewMail.FromAddress = strSender

objNewMail.SendTo = strRecipients

objNewMail.MailSubject = strSubject

objNewMail.MailMessage = strMessage

on error resume next '## Ignore Errors

objNewMail.SendMail

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

case "aspemail"

Set objNewMail = Server.CreateObject("Persits.MailSender")

objNewMail.FromName = strFromName

objNewMail.From = strSender

objNewMail.AddReplyTo strSender

objNewMail.Host = strMailServer

objNewMail.AddAddress strRecipients, strRecipientsName

objNewMail.Subject = strSubject

objNewMail.Body = strMessage

on error resume next '## Ignore Errors

objNewMail.Send

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

case "aspmail"

Set objNewMail = Server.CreateObject("SMTPsvg.Mailer")

objNewMail.FromName = strFromName

objNewMail.FromAddress = strSender

'objNewMail.AddReplyTo = strSender

objNewMail.RemoteHost = strMailServer

objNewMail.AddRecipient strRecipientsName, strRecipients

objNewMail.Subject = strSubject

objNewMail.BodyText = strMessage

on error resume next '## Ignore Errors

SendOk = objNewMail.SendMail

If not(SendOk) <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & objNewMail.Response & "</li>"

End if

case "aspqmail"

Set objNewMail = Server.CreateObject("SMTPsvg.Mailer")

objNewMail.QMessage = 1

objNewMail.FromName = strFromName

objNewMail.FromAddress = strSender

objNewMail.RemoteHost = strMailServer

objNewMail.AddRecipient strRecipientsName, strRecipients

objNewMail.Subject = strSubject

objNewMail.BodyText = strMessage

on error resume next '## Ignore Errors

objNewMail.SendMail

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

case "cdonts"

Set objNewMail = Server.CreateObject ("CDONTS.NewMail")

objNewMail.BodyFormat = 1

objNewMail.MailFormat = 0

on error resume next '## Ignore Errors

objNewMail.Send strSender, strRecipients, strSubject, strMessage

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

on error resume next '## Ignore Errors

 

case "chilicdonts"

Set objNewMail = Server.CreateObject ("CDONTS.NewMail")

on error resume next '## Ignore Errors

objNewMail.Host = strMailServer

objNewMail.To = strRecipients

objNewMail.From = strSender

objNewMail.Subject = strSubject

objNewMail.Body = strMessage

objNewMail.Send

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

on error resume next '## Ignore Errors

 

case "cdosys"

Set iConf = Server.CreateObject ("CDO.Configuration")

Set Flds = iConf.Fields

 

'Set and update fields properties

Flds("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'cdoSendUsingPort

Flds("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strMailServer

'Flds("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic

'Flds("http://schemas.microsoft.com/cdo/configuration/sendusername") = "username"

'Flds("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"

Flds.Update

 

Set objNewMail = Server.CreateObject("CDO.Message")

Set objNewMail.Configuration = iConf

 

'Format and send message

Err.Clear

 

objNewMail.To = strRecipients

objNewMail.From = strSender

objNewMail.Subject = strSubject

objNewMail.TextBody = strMessage

On Error Resume Next

objNewMail.Send

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

 

case "dkqmail"

Set objNewMail = Server.CreateObject("dkQmail.Qmail")

objNewMail.FromEmail = strSender

objNewMail.ToEmail = strRecipients

objNewMail.Subject = strSubject

objNewMail.Body = strMessage

objNewMail.CC = ""

objNewMail.MessageType = "TEXT"

on error resume next '## Ignore Errors

objNewMail.SendMail()

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

 

case "dundasmailq"

set objNewMail = Server.CreateObject("Dundas.Mailer")

objNewMail.QuickSend strSender, strRecipients, strSubject, strMessage

on error resume next '##Ignore Errors

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

 

case "dundasmails"

set objNewMail = Server.CreateObject("Dundas.Mailer")

objNewMail.TOs.Add strRecipients

objNewMail.FromAddress = strSender

objNewMail.Subject = strSubject

objNewMail.Body = strMessage

on error resume next '##Ignore Errors

objNewMail.SendMail

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

 

case "geocel"

set objNewMail = Server.CreateObject("Geocel.Mailer")

objNewMail.AddServer strMailServer, 25

objNewMail.AddRecipient strRecipients, strRecipientsName

objNewMail.FromName = strFromName

objNewMail.FromAddress = strFrom

objNewMail.Subject = strSubject

objNewMail.Body = strMessage

on error resume next '## Ignore Errors

objNewMail.Send()

if Err <> 0 then

Response.Write "Your request was not sent due to the following error: " & Err.Description

else

Response.Write "Your mail has been sent..."

end if

 

case "iismail"

Set objNewMail = Server.CreateObject("iismail.iismail.1")

MailServer = strMailServer

objNewMail.Server = strMailServer

objNewMail.addRecipient(strRecipients)

objNewMail.From = strSender

objNewMail.Subject = strSubject

objNewMail.body = strMessage

on error resume next '## Ignore Errors

objNewMail.Send

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

 

case "jmail"

Set objNewMail = Server.CreateObject("Jmail.smtpmail")

objNewMail.ServerAddress = strMailServer

objNewMail.AddRecipient strRecipients

objNewMail.Sender = strSender

objNewMail.Subject = strSubject

objNewMail.body = strMessage

objNewMail.priority = 3

on error resume next '## Ignore Errors

objNewMail.execute

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

 

case "jmail4"

Set objNewMail = Server.CreateObject("Jmail.Message")

'objNewMail.MailServerUserName = "myUserName"

'objNewMail.MailServerPassword = "MyPassword"

objNewMail.From = strSender

objNewMail.FromName = strFromName

objNewMail.AddRecipient strRecipients, strRecipientsName

objNewMail.Subject = strSubject

objNewMail.Body = strMessage

on error resume next '## Ignore Errors

objNewMail.Send(strMailServer)

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

 

case "mdaemon"

Set gMDUser = Server.CreateObject("MDUserCom.MDUser")

mbDllLoaded = gMDUser.LoadUserDll

if mbDllLoaded = False then

response.write "Could not load MDUSER.DLL! Program will exit." & "<br />"

else

Set gMDMessageInfo = Server.CreateObject("MDUserCom.MDMessageInfo")

gMDUser.InitMessageInfo gMDMessageInfo

gMDMessageInfo.To = strRecipients

gMDMessageInfo.From = strSender

gMDMessageInfo.Subject = strSubject

gMDMessageInfo.MessageBody = strMessage

gMDMessageInfo.Priority = 0

gMDUser.SpoolMessage gMDMessageInfo

mbDllLoaded = gMDUser.FreeUserDll

end if

if Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

end if

 

case "ocxmail"

Set objNewMail = Server.CreateObject("ASPMail.ASPMailCtrl.1")

recipient = strRecipients

sender = strSender

subject = strSubject

message = strMessage

mailserver = strMailServer

on error resume next '## Ignore Errors

result = objNewMail.SendMail(mailserver, recipient, sender, subject, message)

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

 

case "ocxqmail"

Set objNewMail = Server.CreateObject("ocxQmail.ocxQmailCtrl.1")

mailServer = strMailServer

FromName = strFromName

FromAddress = strSender

priority = ""

returnReceipt = ""

toAddressList = strRecipients

ccAddressList = ""

bccAddressList = ""

attachmentList = ""

messageSubject = strSubject

messageText = strMessage

on error resume next '## Ignore Errors

objNewMail.Q mailServer, _

fromName, _

fromAddress, _

priority, _

returnReceipt, _

toAddressList, _

ccAddressList, _

bccAddressList, _

attachmentList, _

messageSubject, _

messageText

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

 

case "sasmtpmail"

Set objNewMail = Server.CreateObject("SoftArtisans.SMTPMail")

objNewMail.FromName = strFromName

objNewMail.FromAddress = strSender

objNewMail.AddRecipient strRecipientsName, strRecipients

'objNewMail.AddReplyTo strSender

objNewMail.BodyText = strMessage

objNewMail.organization = strForumTitle

objNewMail.Subject = strSubject

objNewMail.RemoteHost = strMailServer

on error resume next

SendOk = objNewMail.SendMail

If not(SendOk) <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & objNewMail.Response & "</li>"

End if

 

case "smtp"

Set objNewMail = Server.CreateObject("SmtpMail.SmtpMail.1")

objNewMail.MailServer = strMailServer

objNewMail.Recipients = strRecipients

objNewMail.Sender = strSender

objNewMail.Subject = strSubject

objNewMail.Message = strMessage

on error resume next '## Ignore Errors

objNewMail.SendMail2

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

 

case "vsemail"

Set objNewMail = CreateObject("VSEmail.SMTPSendMail")

objNewMail.Host = strMailServer

objNewMail.From = strSender

objNewMail.SendTo = strRecipients

objNewMail.Subject = strSubject

objNewMail.Body = strMessage

on error resume next '## Ignore Errors

objNewMail.Connect

objNewMail.Send

objNewMail.Disconnect

If Err <> 0 Then

Err_Msg = Err_Msg & "<li>Your request was not sent due to the following error: " & Err.Description & "</li>"

End if

end select

 

Set objNewMail = Nothing

 

on error goto 0

 

Depois vou catar mais alguns q tem aki em casa ae posto aki

Até mais