VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form correo 
   Caption         =   "Correo instantaneo"
   ClientHeight    =   4275
   ClientLeft      =   165
   ClientTop       =   450
   ClientWidth     =   8370
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   4275
   ScaleWidth      =   8370
   Begin VB.CommandButton btn_salir 
      Appearance      =   0  'Flat
      Caption         =   "Salir"
      Height          =   375
      Left            =   6720
      TabIndex        =   9
      Top             =   1080
      Width           =   1455
   End
   Begin VB.CommandButton btn_config 
      Caption         =   "Configuracion"
      Height          =   375
      Left            =   6720
      TabIndex        =   8
      Top             =   120
      Width           =   1455
   End
   Begin MSWinsockLib.Winsock Sck 
      Left            =   7680
      Top             =   3420
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
      RemotePort      =   25
   End
   Begin ComctlLib.ProgressBar Progreso 
      Height          =   255
      Left            =   2520
      TabIndex        =   7
      Top             =   2040
      Width           =   3855
      _ExtentX        =   6800
      _ExtentY        =   450
      _Version        =   327682
      Appearance      =   1
   End
   Begin VB.Timer Retardo 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   7680
      Top             =   2880
   End
   Begin VB.TextBox MensajeEntrante 
      BeginProperty Font 
         Name            =   "Courier"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1635
      Left            =   2520
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   5
      Top             =   2400
      Width           =   4095
   End
   Begin VB.CommandButton Enviar 
      Appearance      =   0  'Flat
      Caption         =   "Enviar"
      Height          =   375
      Left            =   6720
      TabIndex        =   4
      Top             =   600
      Width           =   1455
   End
   Begin VB.TextBox MensajeSaliente 
      BeginProperty Font 
         Name            =   "Courier"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1275
      Left            =   2520
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   2
      Top             =   420
      Width           =   3855
   End
   Begin VB.TextBox Asunto 
      Height          =   285
      Left            =   2520
      TabIndex        =   1
      Top             =   120
      Width           =   3855
   End
   Begin VB.Timer TimeOut 
      Enabled         =   0   'False
      Interval        =   60000
      Left            =   7680
      Top             =   2400
   End
   Begin VB.Image Image1 
      Height          =   3600
      Left            =   120
      Picture         =   "correo.frx":0000
      Top             =   120
      Width           =   1500
   End
   Begin VB.Label Label6 
      Caption         =   "Respuestas del servidor"
      Height          =   195
      Left            =   2520
      TabIndex        =   6
      Top             =   1800
      Width           =   2655
   End
   Begin VB.Label Label5 
      AutoSize        =   -1  'True
      Caption         =   "Mensaje"
      Height          =   195
      Left            =   1800
      TabIndex        =   3
      Top             =   480
      Width           =   600
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      Caption         =   "Asunto"
      Height          =   195
      Left            =   1800
      TabIndex        =   0
      Top             =   180
      Width           =   495
   End
End
Attribute VB_Name = "correo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Option Explicit
Dim RetardoDesconexion As Boolean

Private Sub Acerca_Click()
   frmAbout.Show 1
End Sub

Private Sub btn_config_Click()
   Config.Show 1
   NFich = Cfg.Directorio
   If Right(NFich, 1) = "\" Then
      NFich = Mid(NFich, 1, Len(NFich) - 1)
   End If
   NFich = NFich & "\" & Cfg.FicheroAnexo
End Sub

'Private Sub Base64_Click()
'   Dim Caracter As String * 1
'   Dim Trio(3) As Integer
'   Dim Cont As Integer
'   Dim ContLinea As Integer
'   Dim Cuatro(4) As Integer
'   Dim Base64 As String
'
'   Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
'
'   ContLinea = 0
'   MensajeSaliente = ""
'   MensajeEntrante = ""
'   If Cfg.FicheroAnexo <> "" Then
'      Open NFich For Binary As #3 Len = 3
'      Cont = 0
'      ContTotal = 0
'      Progreso.Max = FileLen(NFich)
'      While Not ContTotal = LOF(3)
'         ContTotal = ContTotal + 1
'         Caracter = Input(1, 3)
'         Cont = Cont + 1
'         Trio(Cont) = Asc(Caracter)
'         'MensajeSaliente = MensajeSaliente + Caracter
'         If Cont = 3 Then
'            Cuatro(1) = Int(Trio(1) / 4)
'            Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16 + Int(Trio(2) / 16)
'            Cuatro(3) = (Trio(2) - (Int(Trio(2) / 16) * 16)) * 4 + Int(Trio(3) / 64)
'            Cuatro(4) = Trio(3) - Int(Trio(3) / 64) * 64
'            MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)
'            MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1)
'            MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(3) + 1, 1)
'            MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(4) + 1, 1)
'            Cont = 0
'            ContLinea = ContLinea + 4
'            If ContLinea = 76 Then
'               MensajeEntrante = MensajeEntrante + vbCrLf
'               ContLinea = 0
'            End If
'         End If
'         DoEvents
'      Wend
'      Select Case Cont
'         Case 1
'            Cuatro(1) = Int(Trio(1) / 4)
'            Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16
'            MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)
'            MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1) + "=="
'         Case 2
'            Cuatro(1) = Int(Trio(1) / 4)
'            Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16 + Int(Trio(2) / 16)
'            Cuatro(3) = (Trio(2) - (Int(Trio(2) / 16) * 16)) * 4
'            MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(1) + 1, 1)
'            MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(2) + 1, 1)
'            MensajeEntrante = MensajeEntrante + Mid(Base64, Cuatro(3) + 1, 1) + "="
'         End Select
'      Close #3
'   End If
'End Sub

Private Sub Configuracion_Click()
   Config.Show 1
   NFich = Cfg.Directorio
   If Right(NFich, 1) = "\" Then
      NFich = Mid(NFich, 1, Len(NFich) - 1)
   End If
   NFich = NFich & "\" & Cfg.FicheroAnexo
End Sub

Private Sub Btn_Salir_Click()
Unload Me
End Sub

Private Sub CrystalActiveXReportViewer1_CloseButtonClicked(UseDefault As Boolean)

End Sub

Private Sub CrystalPrintControl1_Finished(ByVal status As Long, ByVal statusText As String)

End Sub

Private Sub Enviar_Click()

   ' Verifico que la configuracion esta completa
   If Cfg.Smtp = "" Or Cfg.De = "" Or Cfg.Para = "" Then
      MsgBox ("Configuración incompleta")
   Else
      ' Inicializo el mensaje
      Cabecera(1) = "HELO Atawalabachala"
      Cabecera(2) = "MAIL FROM: <" & Config.De.Text & ">"
      Cabecera(3) = "RCPT TO: <" & Config.Para.Text & ">"
      Cabecera(4) = "DATA"
      Cabecera(5) = "From: " & Config.De.Text
      Cabecera(6) = "To: " & Config.Para.Text
      Cabecera(7) = "Subject: " & Asunto.Text
      Cabecera(8) = "DATE: "
      Cabecera(9) = "MIME-Version: 1.0"
      Cabecera(10) = "Content-Type: multipart/mixed;"
      Boundary = "----=_NextPart_000_0002_01BD22EE.C1291DA0"
      Cabecera(11) = Chr(9) & "boundary=""" & Boundary & """"
      Cabecera(12) = "X-Priority: 3"
      Cabecera(13) = "X-MSMail - Priority: Normal"
      Cabecera(14) = "X-MimeOLE: Producido por Raul Gimenez V1.0"
      Cabecera(15) = ""
      Cabecera(16) = "Esto es un mensaje multiparte en formato MIME"
      Cabecera(17) = ""
      Cabecera(18) = "--" & Boundary
      Cabecera(19) = "Content-Type: text/plain;"
      Cabecera(20) = Chr(9) & "charset=""x-user-defined"""
      Cabecera(21) = "Content-Transfer-Encoding: 8bit"
      Cabecera(22) = ""
      Cabecera(23) = MensajeSaliente.Text
      Cabecera(24) = ""
      InicioBoundaryAnexo = 24
      Cabecera(25) = "--" & Boundary
      Cabecera(26) = "Content-Type: application/octet-stream;"
      Cabecera(27) = Chr(9) & "Name=""" & Cfg.FicheroAnexo & """"
      Cabecera(28) = "Content-Disposition: attachment;"
      Cabecera(29) = Chr(9) & "filename=""" & Cfg.FicheroAnexo & """"
      Cabecera(30) = "Content-Transfer-Encoding: base64"
      InicioAnexo = 30
      Cabecera(31) = ""
      ' Inicializo la ventana de entrada
      MensajeEntrante = ""
      ' Inicializo la barra de progreso
      Progreso.Value = 0
      If Cfg.FicheroAnexo = "" Then
         Progreso.Max = 500
      Else
         Progreso.Max = FileLen(NFich) * 1.4 + 500
      End If
      ' Inicializo el asunto y el mensaje saliente
      If MensajeSaliente = "" Then MensajeSaliente = "Sin Mensaje"
      If Asunto = "" Then Asunto = "Sin asunto"
      ' Anulo el boton de enviar
      Enviar.Enabled = False
      If Not ConexionEstablecida Then
         ' Si es la primera vez que envio un mensaje ,
         ' establezco la conexión.
         ' El mensaje se enviará en el evento "Connect"
         Sck.Protocol = sckTCPProtocol
         Sck.RemotePort = 25
         Sck.Remotehost = Cfg.Smtp
         Sck.Connect
      Else
         ' Si no es la primera vez, comienzo el envio del mensaje
         ' El resto del mensaje se enviará en el evento "SendComplete"
         ' NOTA: Me salto el comando HELO
         Paso = 2
         EnviarDatos (Cabecera(Paso) & vbCrLf)
         Progreso.Value = 10
      End If
   End If
End Sub

Private Sub Form_Load()
Me.Width = 8490
Me.Height = 4680
CentrarForma Me
Me.Show
   ' Fichero de log
   'Open DirAplicacion & "\correo.log" For Append As #1
   ' Fichero de configuracion
   Open DirAplicacion & "\correo.cfg" For Append As #2
   Close #2
   Open DirAplicacion & "\correo.cfg" For Input As #2
   If EOF(2) Then
      Close #2
      Config.Show 1
   Else
      Input #2, Cfg.Disco, Cfg.Directorio, Cfg.FicheroAnexo, Cfg.AnexoVisible, Cfg.HayAnexo, Cfg.Smtp, Cfg.De, Cfg.Para
      Close #2
   End If
   
   NFich = Cfg.Directorio
   If Right(NFich, 1) = "\" Then
      NFich = Mid(NFich, 1, Len(NFich) - 1)
   End If
   NFich = NFich & "\" & Cfg.FicheroAnexo
   ConexionEstablecida = False
End Sub

Private Sub Form_Terminate()
   'Close #1
End Sub

Private Sub Form_Unload(Cancel As Integer)
   Dim Resultado As Integer
   If Enviar.Enabled = False Then
      Resultado = MsgBox("¿Desea cancelar el envio del mensaje?", vbYesNo)
      If Resultado = vbNo Then
         Cancel = -1
      Else
         'Sck.Close
'         End
      End If
   End If
Call menuhabilitado(True)
End Sub


Private Sub Salir_Click()
   End
End Sub

Private Sub Sck_Connect()
   ConexionEstablecida = True
   Paso = 0
End Sub

Private Sub Sck_DataArrival(ByVal bytesTotal As Long)
   Dim s As String
   Dim c As String * 1
   If Enviar.Enabled = False Then
      ' leo los mensajes que me llegan desde el servidor SMTP.
      Sck.GetData s
      MensajeEntrante.Text = MensajeEntrante.Text & s
      ' Actualizo el fichero de log
      'Print #1, "R: " & s;
      ' Inicializaciones varias
      ' Desactivo el timer para el control del TimeOut.
      TimeOut.Enabled = False
      ' Evaluo el mensaje del servidor SMTP
      c = Left(s, 1)
      If (c = 2 Or c = 3) Then
         Select Case Paso
            Case 0 To 900
               ' Envio la siguiente parte del mensaje
               Paso = Paso + 1
               Progreso.Value = Progreso.Value + 10
               EnviarDatos (Cabecera(Paso) & vbCrLf)
            Case 998, 999
               ' Esta es la respuesta al comando "."
               ' Espero un poco antes de desconectar
               Retardo.Enabled = True
               TimeOut.Enabled = False
               Progreso.Value = Progreso.Max
         End Select
      Else
         Paso = 999
         'Progreso.Value = Progreso.Value + 10
         EnviarDatos ("RSET" & vbCrLf)
      End If
   End If
End Sub

Private Sub Sck_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)
   TimeOut.Enabled = False
   EnviarDatos ("RSET" & vbCrLf)
   MsgBox "(" & Number & ") " & Description
   'Sck.Close
   Enviar.Enabled = True
End Sub

Private Sub Sck_SendComplete()
   Dim Caracter As String * 1
   Dim Trio(3) As Integer
   Dim cont As Integer
   Dim ContLinea As Integer
   Dim Cuatro(4) As Integer
   Dim Pos As Long
   Dim Salir As Boolean
   Dim Base64 As String
   
   Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
   ' Desactivo el timer para el control del TimeOut.
   TimeOut.Enabled = False
   ' Envio la siguiente parte del mensaje
   Select Case Paso
      Case 5 To InicioBoundaryAnexo - 1
            Paso = Paso + 1
            Progreso.Value = Progreso.Value + 10
            EnviarDatos (Cabecera(Paso) & vbCrLf)
      Case InicioBoundaryAnexo To InicioAnexo - 1
         If Cfg.FicheroAnexo <> "" Then
            Paso = Paso + 1
            Progreso.Value = Progreso.Value + 10
            EnviarDatos (Cabecera(Paso) & vbCrLf)
         Else
            ' Envio el mensaje de "cierre"
            Paso = 998
            Progreso.Value = Progreso.Value + 10
            EnviarDatos ("." & vbCrLf)
         End If
      Case InicioAnexo
         If Cfg.FicheroAnexo <> "" Then
            Open NFich For Binary As #3
            ContTotal = 0
            Paso = Paso + 1
            Progreso.Value = Progreso.Value + 10
            EnviarDatos (Cabecera(Paso) & vbCrLf)
         Else
            ' Envio el mensaje de "cierre"
            Paso = 998
            Progreso.Value = Progreso.Value + 10
            EnviarDatos ("." & vbCrLf)
         End If
      Case InicioAnexo + 1
         Salir = False
         cont = 0
         ContLinea = 0
         Cadena = ""
         While ContTotal <> LOF(3) And Not Salir
            Caracter = Input(1, 3)
            ContTotal = ContTotal + 1
            cont = cont + 1
            Trio(cont) = Asc(Caracter)
            If cont = 3 Then
               Cuatro(1) = Int(Trio(1) / 4)
               Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16 + Int(Trio(2) / 16)
               Cuatro(3) = (Trio(2) - (Int(Trio(2) / 16) * 16)) * 4 + Int(Trio(3) / 64)
               Cuatro(4) = Trio(3) - Int(Trio(3) / 64) * 64
               cont = 0
               ContLinea = ContLinea + 4
               Cadena = Cadena & Mid(Base64, Cuatro(1) + 1, 1) & Mid(Base64, Cuatro(2) + 1, 1) & Mid(Base64, Cuatro(3) + 1, 1) & Mid(Base64, Cuatro(4) + 1, 1)
               If ContLinea = 76 Then
                  Salir = True
               End If
            End If
         Wend
         If ContTotal = LOF(3) Then
            Close #3
            Paso = 900
            Select Case cont
               Case 1
                  Cuatro(1) = Int(Trio(1) / 4)
                  Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16
                  Cadena = Cadena & Mid(Base64, Cuatro(1) + 1, 1) & Mid(Base64, Cuatro(2) + 1, 1) & "=="
               Case 2
                  Cuatro(1) = Int(Trio(1) / 4)
                  Cuatro(2) = (Trio(1) - Int(Trio(1) / 4) * 4) * 16 + Int(Trio(2) / 16)
                  Cuatro(3) = (Trio(2) - (Int(Trio(2) / 16) * 16)) * 4
                  Cadena = Cadena & Mid(Base64, Cuatro(1) + 1, 1) & Mid(Base64, Cuatro(2) + 1, 1) & Mid(Base64, Cuatro(3) + 1, 1) & "="
            End Select
         End If
        ' Progreso.Value = Progreso.Value + 76
         EnviarDatos (Cadena & vbCrLf)
      Case 900
         Paso = 901
         ' Envio el mensaje de "cierre"
         Progreso.Value = Progreso.Value + 10
         EnviarDatos (vbCrLf)
      Case 901
         Paso = 902
         ' Envio el mensaje de "cierre"
         Progreso.Value = Progreso.Value + 10
         EnviarDatos ("--" & Boundary & "--" & vbCrLf)
      Case 902
         Paso = 997
         ' Envio el mensaje de "cierre"
         Progreso.Value = Progreso.Value + 10
         EnviarDatos (vbCrLf)
      Case 997
         Paso = 998
         ' Envio el mensaje de "cierre"
         Progreso.Value = Progreso.Value + 10
         EnviarDatos ("." & vbCrLf)
   End Select
End Sub

Private Sub Retardo_Timer()
   ' Despues de enviar el mensaje espero X segundos antes
   ' dar por terminado el envio del mensaje
   Enviar.Enabled = True
   Retardo.Enabled = False
   Progreso.Value = 0
   'Print #1, "------------------------------------"
End Sub

Private Sub TimeOut_Timer()
   Enviar.Enabled = True
   MsgBox "Se agotó el tiempo de espera" & vbCrLf & "Vuelve a intentarlo"
End Sub
