hay les va el código....
agrege un cotrol de usuario y en el puse un winsock(wsMail), 5 textbox(txtServidor, txtDe, txtPara, txtAsunto y txtMensaje) y un xpcmdbutton(cmdEnviar)
'Event Declarations:
Event Enviar() 'MappingInfo=cmdEnviar,cmdEnviar,-1,Click
Private Sub cmdEnviar_Click()
RaiseEvent Enviar
wsMail.RemoteHost = txtServidor.Text
wsMail.RemotePort = 25
wsMail.Connect
End Sub
Private Sub UserControl_Resize()
On Local Error Resume Next
txtServidor.Width = UserControl.ScaleWidth - txtServidor.Left * 2
txtDe.Width = UserControl.ScaleWidth - txtServidor.Left * 2
txtPara.Width = UserControl.ScaleWidth - txtServidor.Left * 2
txtAsunto.Width = UserControl.ScaleWidth - txtServidor.Left * 2
txtMensaje.Width = UserControl.ScaleWidth - txtServidor.Left * 2
txtMensaje.Height = UserControl.ScaleHeight - txtMensaje.Top - 540
cmdEnviar.Top = txtMensaje.Top + txtMensaje.Height + 100
cmdEnviar.Left = UserControl.ScaleWidth - cmdEnviar.Width - 100
txStatus.Width = UserControl.ScaleWidth
txStatus.Top = UserControl.ScaleHeight - txStatus.Height
On Local Error Resume Next
End Sub
Private Sub wsMail_DataArrival(ByVal bytesTotal As Long)
' this is the main processing code for
' sending an email message
' the iState variable maintains the current
' state of the protocol exchange so that we
' know what to send next
Dim strData As String
Static iState As Integer
Dim iMsgNum As Integer
Dim szMsg As String
Dim I As Integer
wsMail.GetData strData, vbString
iMsgNum = Val(Left(strData, InStr(strData, " ")))
Select Case iMsgNum
Case 220 ' initial message
wsMail.SendData "HELO " & txtServidor.Text & vbCrLf
txStatus = "Servidor de correo conectado..."
iState = 1
Case 221
If iState = 999 Then
txStatus = "Desconectado del servidor de coreo con errores..."
Else
txStatus = "Desconectado del servidor de coreo..."
End If
iState = 0
Case 250
Select Case iState
Case 1:
wsMail.SendData "MAIL FROM:<" & txtDe.Text & ">" & vbCrLf
'Debug.Print "MAIL FROM:<" & txtMail.Text & ">" & vbCrLf
txStatus = "Enviando comando FROM..."
iState = 2
Case 2:
wsMail.SendData "RCPT TO:<" & txtPara.Text & ">" & vbCrLf
'Debug.Print "RCPT TO:<ocelaya@embzacatecas.com>" & vbCrLf
txStatus = "Enviando comando RCPT..."
iState = 3
Case 3:
wsMail.SendData "DATA" & vbCrLf
'Debug.Print "DATA" & vbCrLf
txStatus = "Enviando comando DATA..."
iState = 4
Case 5:
wsMail.SendData "QUIT" & vbCrLf
'Debug.Print "QUIT" & vbCrLf
txStatus = "Enviando comando Quit para desconecar del servidor de correo..."
iState = 6
wsMail.Close
MsgBox "Su correo ha sido enviado correctamente.", vbInformation + vbOKOnly, "Soporte técnico"
End Select
Case 354
iState = 5
szMsg = txtMensaje.Text + Chr(10)
txStatus = "Sending mail message data..."
wsMail.SendData "Subject: " & txtAsunto.Text & vbCrLf
While szMsg <> ""
wsMail.SendData Left(szMsg, InStr(szMsg, Chr(10)))
'Debug.Print "Sending:" & Left(szMsg, InStr(szMsg, Chr(10)))
szMsg = Mid(szMsg, InStr(szMsg, Chr(10)) + 1)
Wend
wsMail.SendData "." & vbCrLf
Case 500 To 599
wsMail.SendData "QUIT" & vbCrLf
txStatus = "Error al enviar el correo..."
'Debug.Print "Error sending mail... quitting..."
iState = 999
End Select
End Sub
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
UserControl.BackColor() = New_BackColor
PropertyChanged "BackColor"
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=UserControl,UserControl,-1,ForeColor
Public Property Get ForeColor() As OLE_COLOR
ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
UserControl.ForeColor() = New_ForeColor
PropertyChanged "ForeColor"
txtServidor.ForeColor = New_ForeColor
txtDe.ForeColor = New_ForeColor
txtPara.ForeColor = New_ForeColor
txtAsunto.ForeColor = New_ForeColor
txtMensaje.ForeColor = New_ForeColor
lblServidor.ForeColor = New_ForeColor
lblDe.ForeColor = New_ForeColor
lblPara.ForeColor = New_ForeColor
lblAsunto.ForeColor = New_ForeColor
lblMensaje.ForeColor = New_ForeColor
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=UserControl,UserControl,-1,Enabled
Public Property Get Enabled() As Boolean
Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
UserControl.Enabled() = New_Enabled
PropertyChanged "Enabled"
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=UserControl,UserControl,-1,Font
Public Property Get Font() As Font
Set Font = UserControl.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
Set UserControl.Font = New_Font
PropertyChanged "Font"
txtServidor.Font = New_Font
txtDe.Font = New_Font
txtPara.Font = New_Font
txtAsunto.Font = New_Font
txtMensaje.Font = New_Font
lblServidor.Font = New_Font
lblDe.Font = New_Font
lblPara.Font = New_Font
lblAsunto.Font = New_Font
lblMensaje.Font = New_Font
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=UserControl,UserControl,-1,Appearance
Public Property Get Appearance() As Integer
Appearance = UserControl.Appearance
End Property
Public Property Let Appearance(ByVal New_Appearance As Integer)
UserControl.Appearance() = New_Appearance
PropertyChanged "Appearance"
txtServidor.Appearance = New_Appearance
txtDe.Appearance = New_Appearance
txtPara.Appearance = New_Appearance
txtAsunto.Appearance = New_Appearance
txtMensaje.Appearance = New_Appearance
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=UserControl,UserControl,-1,BackStyle
Public Property Get BackStyle() As Integer
BackStyle = UserControl.BackStyle
End Property
Public Property Let BackStyle(ByVal New_BackStyle As Integer)
UserControl.BackStyle() = New_BackStyle
PropertyChanged "BackStyle"
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=UserControl,UserControl,-1,BorderStyle
Public Property Get BorderStyle() As Integer
BorderStyle = UserControl.BorderStyle
End Property
Public Property Let BorderStyle(ByVal New_BorderStyle As Integer)
UserControl.BorderStyle() = New_BorderStyle
PropertyChanged "BorderStyle"
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=UserControl,UserControl,-1,Refresh
Public Sub Refresh()
UserControl.Refresh
End Sub
'Inicializar propiedades para control de usuario
Private Sub UserControl_InitProperties()
Set UserControl.Font = Ambient.Font
End Sub
'Cargar valores de propiedad desde el almacén
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
UserControl.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
UserControl.Enabled = PropBag.ReadProperty("Enabled", Verdadero)
Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
UserControl.Appearance = PropBag.ReadProperty("Appearance", 1)
UserControl.BackStyle = PropBag.ReadProperty("BackStyle", 1)
UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
txtServidor.Text = PropBag.ReadProperty("Servidor", "")
txtDe.Text = PropBag.ReadProperty("De", "")
txtPara.Text = PropBag.ReadProperty("Para", "")
txtAsunto.Text = PropBag.ReadProperty("Asunto", "")
txtMensaje.Text = PropBag.ReadProperty("Mensaje", "")
End Sub
'Escribir valores de propiedad en el almacén
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
Call PropBag.WriteProperty("ForeColor", UserControl.ForeColor, &H80000012)
Call PropBag.WriteProperty("Enabled", UserControl.Enabled, Verdadero)
Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)
Call PropBag.WriteProperty("Appearance", UserControl.Appearance, 1)
Call PropBag.WriteProperty("BackStyle", UserControl.BackStyle, 1)
Call PropBag.WriteProperty("BorderStyle", UserControl.BorderStyle, 0)
Call PropBag.WriteProperty("Servidor", txtServidor.Text, "")
Call PropBag.WriteProperty("De", txtDe.Text, "")
Call PropBag.WriteProperty("Para", txtPara.Text, "")
Call PropBag.WriteProperty("Asunto", txtAsunto.Text, "")
Call PropBag.WriteProperty("Mensaje", txtMensaje.Text, "")
End Sub
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=txtServidor,txtServidor,-1,Text
Public Property Get Servidor() As String
Servidor = txtServidor.Text
End Property
Public Property Let Servidor(ByVal New_Servidor As String)
txtServidor.Text() = New_Servidor
PropertyChanged "Servidor"
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=txtDe,txtDe,-1,Text
Public Property Get De() As String
De = txtDe.Text
End Property
Public Property Let De(ByVal New_De As String)
txtDe.Text() = New_De
PropertyChanged "De"
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=txtPara,txtPara,-1,Text
Public Property Get Para() As String
Para = txtPara.Text
End Property
Public Property Let Para(ByVal New_Para As String)
txtPara.Text() = New_Para
PropertyChanged "Para"
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=txtAsunto,txtAsunto,-1,Text
Public Property Get Asunto() As String
Asunto = txtAsunto.Text
End Property
Public Property Let Asunto(ByVal New_Asunto As String)
txtAsunto.Text() = New_Asunto
PropertyChanged "Asunto"
End Property
'ADVERTENCIA: NO QUITAR NI MODIFICAR LAS SIGUIENTES LINEAS CON COMENTARIOS
'MappingInfo=txtMensaje,txtMensaje,-1,Text
Public Property Get Mensaje() As String
Mensaje = txtMensaje.Text
End Property
Public Property Let Mensaje(ByVal New_Mensaje As String)
txtMensaje.Text() = New_Mensaje
PropertyChanged "Mensaje"
End Property
Autor
En línea
