Foro de elhacker.net

Option Explicit

' para la conexión a internet usaremos wininet.dll
Private Declare Function InternetGetConnectedState _
    Lib "wininet.dll" ( _
    ByRef lpdwFlags As Long, _
    ByVal dwReserved As Long) As Long

Private Const INTERNET_CONNECTION_MODEM_BUSY As Long = &H8
Private Const INTERNET_RAS_INSTALLED As Long = &H10
Private Const INTERNET_CONNECTION_OFFLINE As Long = &H20
Private Const INTERNET_CONNECTION_CONFIGURED As Long = &H40

' variables locales que usamos con CDO
Private mServidor As String
Private mPara As String
Private mDe As String
Private mAsunto As String
Private mMensaje As String
Private mAdjunto As String
Private mPuerto As Variant
Private mUsuario As String
Private mContraseña
Private mUseAuntentificacion As Boolean
Private mSSL As Boolean
'las salidas que nos puede dar el envio
Public Event Error(Descripcion As String, Numero As Variant)
Public Event EnvioCompleto()

Function Enviar_Backup() As Boolean
    
    ' Variable de objeto Cdo.Message
    Dim oCDO As Object
          
    ' si hay conexion o no, este sería el primer error ya declarado anteriormente
    If InternetGetConnectedState(0&, 0&) = False Then
       RaiseEvent Error("No se puede enviar el correo. " & _
                        "Verificar la conexión a internet si está disponible", 0)
       Exit Function
    End If
    
    
    
    ' el puerto tiene que ser un numero y que no este vacio
    If Not IsNumeric(puerto) Then
       RaiseEvent Error("No se ha indicado el puerto del servidor", 0)
       Exit Function
    End If
    
    ' Crea un Nuevo objeto CDO.Message
    Set oCDO = CreateObject("CDO.Message")
    
    ' Indica el servidor Smtp para poder enviar el Mail ( puede ser el nombre _
      del servidor o su dirección IP )
    oCDO.Configuration.Fields( _
    "http://schemas.microsoft.com/cdo/configuration/smtpserver") = mServidor
    
    oCDO.Configuration.Fields( _
    "http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    
    ' Puerto. Por defecto se usa el puerto 25, _
     en el caso de Gmail se usa el puerto 465
    
    oCDO.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = mPuerto

    
    ' Indica el tipo de autentificación con el servidor de correo _
     El valor 0 no requiere autentificarse, el valor 1 es con autentificación
    oCDO.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/" & _
                "configuration/smtpauthenticate") = Abs(mUseAuntentificacion)
    
    ' Tiempo máximo de espera en segundos para la conexión, 10 es el numero predeterminado pero puedes poner más
    oCDO.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10

    ' Configura las opciones para el login en el SMTP
    If mUseAuntentificacion Then

    ' Id de usuario del servidor Smtp ( en el caso de gmail, _
     debe ser la dirección de correro mas el @gmail.com )
    oCDO.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/sendusername") = mUsuario

    ' Password de la cuenta
    oCDO.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = mContraseña

    ' Indica si se usa SSL para el envío. En el caso de Gmail requiere que esté en True
    oCDO.Configuration.Fields.Item _
        ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = mSSL
    
    End If
    
    ' Estructura del mail
    '''''''''''''''''''''''''''''''''''''''''''''''
    
    ' Dirección del Destinatario
    
    oCDO.To = mPara
    
    ' Dirección del remitente
    oCDO.From = mDe
    
    ' Asunto del mensaje
    oCDO.Subject = mAsunto
    
    ' Cuerpo del mensaje
    oCDO.TextBody = mMensaje
    
    'Ruta del archivo adjunto
    If mAdjunto <> "" Then
        If Len(Dir(mAdjunto)) = 0 Then
            'otro mensaje de error en este caso por no haber especfificado la ruta correcta
            RaiseEvent Error("No se ha encontrado el archivo en la siguiente ruta: ", 0)
            Exit Function
        Else
            'aqui agrega el archivo
            oCDO.AddAttachment (mAdjunto)
        End If
    End If
    
    ' Actualiza los datos antes de enviar
    oCDO.Configuration.Fields.Update
    
    On Error Resume Next
    Screen.MousePointer = vbHourglass
    ' Envía el email
    oCDO.Send
    Screen.MousePointer = 0
    ' aqui comprueba con condicionales que todo se haya realizado correctamente
    If Err.Number = 0 Then
       Enviar_Backup = True
       RaiseEvent EnvioCompleto
    
    ElseIf Err.Number = -2147220973 Then
       RaiseEvent Error("Posible error : nombre del Servidor " & _
                        "incorrecto o número de puerto incorrecto", Err.Number)
    ElseIf Err.Number = -2147220975 Then
       RaiseEvent Error("Posible error : error en el nombre de usuario, " & _
                                                "o en el password ", Err.Number)
    Else
       RaiseEvent Error(Err.Description, Err.Number)
    End If

    ' Descarga la referencia
    If Not oCDO Is Nothing Then
        Set oCDO = Nothing
    End If
    
    Err.Clear
    
    Screen.MousePointer = vbNormal
End Function

'Valores declarados anteriormente sacados de la antigua libreria CDO
Property Get servidor() As String
    servidor = mServidor
End Property
Property Let servidor(value As String)
    mServidor = value
End Property


Property Get para() As String
    para = mPara
End Property
Property Let para(value As String)
    mPara = value
End Property


Property Get de() As String
    de = mDe
End Property
Property Let de(value As String)
    mDe = value
End Property


Property Get Asunto() As String
    Asunto = mAsunto
End Property
Property Let Asunto(value As String)
    mAsunto = value
End Property


Property Get Mensaje() As String
    Mensaje = mMensaje
End Property
Property Let Mensaje(value As String)
    mMensaje = value
End Property


Property Get Adjunto() As String
    Adjunto = mAdjunto
End Property
Property Let Adjunto(value As String)
    mAdjunto = value
End Property


Property Get puerto() As Variant
    puerto = mPuerto
End Property
Property Let puerto(value As Variant)
    mPuerto = value
End Property


Property Get Usuario() As String
    Usuario = mUsuario
End Property
Property Let Usuario(value As String)
    mUsuario = value
End Property


Property Get contraseña() As String
    contraseña = mContraseña
End Property
Property Let contraseña(value As String)
    mContraseña = value
End Property


Property Get UseAuntentificacion() As Boolean
    UseAuntentificacion = mUseAuntentificacion
End Property
Property Let UseAuntentificacion(value As Boolean)
    mUseAuntentificacion = value
End Property


Property Get ssl() As Boolean
    ssl = mSSL
End Property
Property Let ssl(value As Boolean)
    mSSL = value
End Property

'##############
'# Programado #
'# por P4|3L0 #
'##############
Option Explicit
Private WithEvents correo As CDOMail

Private Sub cmdsend_Click()
Set correo = New CDOMail
'aqui usariamos las propiedades del modulo de clase
With correo
    'servidor smtp de gmail
        .servidor = "smtp.gmail.com"
    'puerto smtp de gmail
        .puerto = 465
        .UseAuntentificacion = True
        'gmail y hotmail usan ssl asi que tenemos que activarlo
        .ssl = True
        'tu usuario
        .Usuario = "usuario@gmail.com"
        'tu contraseña
        .contraseña = "tusabras"
        'el asunto de tu mensaje
        .Asunto = "Sin Asunto"
        'adjuntar, si no quieres que se mande nada pon esto como si fuese un comentario
        .Adjunto = "C:\WINDOWS\explorer.exe"
        'desde que usuario lo envias
        .de = "usuario@gmail.com"
        'a quien se lo mandas
        .para = "usuario2@gmail.com"
        'cuerpo del mensaje
        .Mensaje = "Mensaje deseado"
        'despues de haber comprobado todo
        .Enviar_Backup ' manda el mail
        End With
Set correo = Nothing
End Sub
Private Sub correo_EnvioCompleto()
'si no pasa nada y se envia correctamente
    MsgBox "Mensaje enviado", vbInformation, Me.Caption
End Sub

Private Sub correo_Error(Descripcion As String, Numero As Variant)
    'muestra el error y que ha pasado
    MsgBox Descripcion, vbCritical, Numero
    
End Sub

Ejemplo 2
En este otro enlace , podés descargar un ejemplo similar usando CDO pero mediante un módulo de clase : Descargar ( para implementarlo mas fácilmente ) 

'##############
'# Programado #
'# por P4|3L0 #
'##############