Enviar email con datos adjuntos

-=Aldo=-
05 de Febrero del 2004
Aqui estoy otra vez con otro problema :-/ Espero que puedan ayudarme. Tengo dentro de mi aplicacion la posibilidad de enviar mail al personal de la facultad, pero no puedo adjuntar un archivo, porque ella al destinatario pero no el dato adjunto sino en el cuerpo del mensaje se llena de unos caracteres rarisimos. Esta parte del codigo no la escribi yo sino que la baje de alguna parte, y a decir verdad muy poco es lo que entiendo. Les paso el codigo a ver si alguien me puede ayudar o si tienen uno terminado les agradecerìa si me pasan el codigo al mail. Gracias Este es el codigo:

Dim Enter ' Voy a utilizar variable global Enter
Private Sub Command1_Click()
Form2.Show
Form2.Text1.Text = Mensaje
Form2.Text2.Text = Situacion
End Sub
Private Sub ArchivoAdjunto()
On Error Resume Next ' Detector de Errores Activado
Destino = "Temporal.uue" ' Determinar el Destino


' Esto que sigue es codificar el Archivo adjunto
' para que lo pueda leer el lector de Mails
' Utilizo la codificacion UUE y aclaro que
' lo de a continuacion no es mio

Open Archivo For Binary As #1
Open Destino For Output As #2
Print #2, "begin 644 " + Archivo
bl& = 45: fl& = LOF(1): bf$ = Space$(bl&)
While fl&
If fl& < bl& Then bl& = fl&: bf$ = Space$(bl&)
Get #1, , bf$: fl& = fl& - bl&
If bl& Mod 3 <> 0 Then bf$ = bf$ + String$(3 - bl& Mod 3, 0)
For i = 1 To bl& Step 3
c1 = Asc(Mid$(bf$, i, 1))
c2 = Asc(Mid$(bf$, i + 1, 1))
c3 = Asc(Mid$(bf$, i + 2, 1))
l$ = l$ + Chr$(c1 4 + 32)
l$ = l$ + Chr$((c1 * 16 + c2 16 And &H3F) + 32)
l$ = l$ + Chr$((c2 * 4 + c3 64 And &H3F) + 32)
l$ = l$ + Chr$((c3 And &H3F) + 32)
Next
Print #2, Chr$(32 + bl&); l$: l$ = ""
Wend
Print #2,: Print #2, "end"
Close #1, #2

' Lo siguiente si es mio

ArchivoUUE = "" ' Inicializo la variable

Open Destino For Input As #1 ' Abro el archivo
Do
For i = 1 To 100 ' Leo 100 Lineas y las envio
Line Input #1, Linea ' Leo Linea por Linea
If Linea = "" Then ' Si la Linea esta vacia
Exit For ' Salirse el For
End If
If Linea = "end" Then ' Si Linea es "end"
ArchivoUUE = ArchivoUUE + Linea & Enter ' Agregarla
Exit For ' Salir del For
End If
ArchivoUUE = ArchivoUUE + Linea & Enter ' Ir almacenando las Lineas
Next
Sock1.SendData ArchivoUUE ' Envio el ArchivoUUE
ArchivoUUE = "" ' Lo dejo en limpio
Loop Until EOF(1) ' Repetir hasta que llegue al final del archivo
Close #1 ' Cierro el Destino
End Sub

Private Sub Agregar_Click()
Com1.FileName = "" ' Borrar anterior archivo
Com1.ShowOpen ' Mostrar dialogo Abrir
Com1.Filter = "(*.*)|*.*"
If Com1.FileName > "" Then ' Si elegiste un Archivo
Archivo = Com1.FileName ' Ponerlo en el TextBox Archivo
Eliminar.Enabled = True ' Poder presionar Eliminar (X)
End If
End Sub

Private Sub Cerrar_Click()
On Error Resume Next ' Detector de Errores Activado
Sock1.Close ' Cerramos la conexion
End ' Finalizamos
End Sub

Private Sub Eliminar_Click()
Archivo = "Ninguno..." ' Indicar que no hay archivo adjunto
Eliminar.Enabled = False ' No poder presionar Eliminar (X)
End Sub
Private Sub Enviar_Click()
On Error Resume Next
If Sock1.State <> 0 Then
MsgBox "!!!ATENCION!!!" + " " + " " + TuNombre.Text + " " + ", " + "" + " la conexión ya está abierta"
Sock1.Close
Screen.MousePointer = 11
End If
Sock1.RemoteHost = Servidor
Sock1.RemotePort = 25
Situacion = ""
Sock1.Connect
Enter = Chr(13) + Chr(10)
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
Sock1.Close
Unload Me
End Sub
Private Sub Resolucion_Click()
Form3.Show
End Sub

Private Sub Sock1_Connect()
If Titulo = "" Then
Sock1.Close
MsgBox ("Debes poner un título en el Correo")
GoTo fin
End If
On Error Resume Next
Sock1.Tag = 1
Sock1.SendData "HELO" & TuNombre & Enter
fin:
End Sub
Private Sub Sock1_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Sock1.GetData DaTos, vbString
Situacion = Situacion + DaTos
If Mid(DaTos, 1, 9) = "550 Relay" Then
MsgBox "Este Servidor no permite enviar Correos sin cuenta", _
vbOKOnly + vbCritical, "Error"
Sock1.Close
Sock1.Tag = 0
End If
If Sock1.Tag = 1 Then ' Si voy en el paso 1
Sock1.SendData "RSET" & Enter ' Le envio RSET
Sock1.Tag = 2 ' Digo que voy al siguiente paso
GoTo fin ' Ir al final
End If
If Sock1.Tag = 2 Then ' Si voy en el paso 2
Sock1.SendData "MAIL FROM: <" & TuEmail & ">" & Enter ' Le envio MiMail1
Sock1.Tag = 3 ' Digo que voy al siguiente paso
GoTo fin ' Ir al final
End If
If Sock1.Tag = 3 Then ' Si voy en el paso 3
Sock1.SendData "RCPT TO: <" & Para & ">" & Enter ' Le envio ParaMail
If Copia <> "-" Then ' Si tiene para un Mail CC (con copia, creo)
Sock1.SendData "RCPT TO: <" & Copia & ">" & Enter ' Le envio CCMail
End If
Sock1.Tag = 4 ' Digo que voy al siguiente paso
GoTo fin ' Ir al final
End If
If Sock1.Tag = 4 Then ' Si voy en el paso 4
Sock1.SendData "DATA" & Enter ' Aqui le envio DATA (Empieza el mail)
Sock1.Tag = 5 ' Digo que voy al siguiente paso
GoTo fin ' Ir al final
End If
If Sock1.Tag = 5 Then ' Si voy en el paso 5
Sock1.SendData "To: " & Para & Enter ' Le envio para quien va
If Copia <> "-" Then ' Si tiene para un Mail CC (con copia, creo)
Sock1.SendData "CC: " & Copia & Enter ' Le envio para quien va el CC
End If
Sock1.SendData "From: " & Nombre & " <" & TuEmail & ">" & Enter ' El Nombre y MiMail

Sock1.SendData "Subject: " & Titulo & Enter ' El Subject (Titulo)


Sock1.SendData Enter ' Un Enter indica que empieza el Mensaje
Sock1.SendData Mensaje & Enter ' Le envio el Mensaje
If Len(Mensaje) > Len("r") Then 'AÑADIDo
Progre.Value = Format(Now, "ss")
Text1.Text = Progre.Value
End If
Sock1.SendData Mensaje = Form2.Text1.Text
If Archivo <> "Ninguno..." Then ' Si tengo un archivo adjunto
Call ArchivoAdjunto ' Llamo al Procedimiento de Anviar Archivo
End If
Sock1.SendData "." & Enter ' Esto indica fin del mail
Progre = Len(Mensaje) + Len(Archivo)
Sock1.Tag = 6 ' Digo que voy al siguiente paso

GoTo fin ' Ir al final
End If
If Sock1.Tag = 6 Then ' Si voy en el paso 6
Sock1.SendData "QUIT" & Enter ' Le indico que cierre la conexion
Sock1.Tag = 7 ' Digo que voy al ultimo paso
GoTo fin ' Ir al final
End If
If Sock1.Tag = 7 Then ' Si voy en el paso 6
Sock1.Tag = 0 ' Digo que ya se acabo
Sock1.Close ' Cierro la conexion
Screen.MousePointer = 0 ' Poner el mouse normal
MsgBox "Mail enviado", vbOKOnly + vbInformation, "=)" ' Mostar un mensaje
GoTo fin ' Ir al final
End If
fin:
End Sub


Private Sub Sock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
Screen.MousePointer = 0 ' Poner el mouse normal
If Number = 11004 Then ' Si el Numero de error es el 11004
MsgBox "No existe el Servidor", vbOKOnly + vbExclamation, "Error"
GoTo fin ' Ir al final
End If
If Number = 10060 Then ' Si el Numero de error es el 10060
MsgBox "Tiempo agotado para conexion", vbOKOnly + vbExclamation, "Error"
GoTo fin ' Ir al final
End If
If Number = 10065 Then ' Si el Numero de error es el 10065
MsgBox "Sin ruta al Servidor", vbOKOnly + vbExclamation, "Error"
GoTo fin ' Ir al final
End If
MsgBox Number & " - " & Description ' Mostrar mensaje de Error
fin:
End Sub

Private Sub Timer1_Timer()
Label15.Caption = Format(Now, " hh:mm:ss")
On Error Resume Next ' Detector de Errores Activado
Select Case Sock1.State ' Seleccionar el Estado del Socket
Case 0
Estado = "Cerrado"
Case 1
Estado = "Abierto"
Case 2
Estado = "Escuchando..."
Case 3
Estado = "Pendiente"
Case 4
Estado = "Resolviendo Host..."
Case 5
Estado = "Host Resuelto"
Case 6
Estado = "Conectando..."
Case 7
Estado = "Conectado"
Case 8
Estado = "Conexion Cerrada"
Case 9
Estado = "Error"
End Select
End Sub