VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form Form1
BorderStyle = 3 'Fixed Dialog
Caption = "Jaime Tejedor Gómez --- Proyecto de Fin de Carrera --- 2001"
ClientHeight = 5280
ClientLeft = 45
ClientTop = 330
ClientWidth = 7440
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 5280
ScaleWidth = 7440
StartUpPosition = 3 'Windows Default
Begin MSComDlg.CommonDialog CommonDialog1
Left = 1200
Top = 4080
_ExtentX = 847
_ExtentY = 847
_Version = 393216
CancelError = -1 'True
DialogTitle = "Guardar Como"
End
Begin MSCommLib.MSComm MSComm1
Left = 5280
Top = 3840
_ExtentX = 1005
_ExtentY = 1005
_Version = 393216
DTREnable = -1 'True
Handshaking = 2
InBufferSize = 16384
OutBufferSize = 8192
RThreshold = 1
RTSEnable = -1 'True
BaudRate = 115200
SThreshold = 1
End
Begin VB.DriveListBox Drive1
Height = 315
Left = 120
TabIndex = 13
Top = 1920
Width = 1815
End
Begin VB.FileListBox File1
Height = 2430
Hidden = -1 'True
Left = 3480
System = -1 'True
TabIndex = 12
Top = 2400
Width = 3855
End
Begin VB.DirListBox Dir1
Height = 2340
Left = 120
OLEDropMode = 1 'Manual
TabIndex = 11
Top = 2400
Width = 3255
End
Begin VB.CommandButton Command3
Caption = "Conectar"
Height = 255
Left = 2280
TabIndex = 10
Top = 840
Width = 1095
End
Begin VB.CommandButton Command2
Caption = "Transmitir"
Height = 375
Left = 2160
TabIndex = 9
Top = 1920
Width = 1215
End
Begin VB.Frame Frame2
Caption = "Puerto:"
Height = 735
Left = 2280
TabIndex = 3
Top = 1080
Width = 1095
Begin VB.OptionButton COM2
Caption = "COM2"
Height = 195
Left = 120
TabIndex = 8
Top = 480
Width = 855
End
Begin VB.OptionButton COM1
Caption = "COM1"
Height = 195
Left = 120
TabIndex = 7
Top = 240
Value = -1 'True
Width = 855
End
End
Begin VB.TextBox Text1
Height = 285
Left = 0
TabIndex = 1
Top = 360
Width = 7335
End
Begin VB.Frame Frame1
Caption = "Método:"
Height = 1095
Left = 0
TabIndex = 0
Top = 720
Width = 2055
Begin VB.OptionButton METODO3
Caption = "Sin Compresión"
Height = 255
Left = 120
TabIndex = 6
Top = 720
Width = 1695
End
Begin VB.OptionButton METODO2
Caption = "LZ, diccionario 3K"
Height = 255
Left = 120
TabIndex = 5
Top = 480
Width = 1815
End
Begin VB.OptionButton METODO1
Caption = "LZ, diccionario 6K"
Height = 195
Left = 120
TabIndex = 4
Top = 240
Value = -1 'True
Width = 1815
End
End
Begin VB.Label Label8
Height = 255
Left = 3480
TabIndex = 20
Top = 2040
Width = 3735
End
Begin VB.Label Label7
Height = 255
Left = 3480
TabIndex = 19
Top = 1800
Width = 3855
End
Begin VB.Label Label6
Height = 255
Left = 3480
TabIndex = 18
Top = 1560
Width = 3735
End
Begin VB.Label Label5
Height = 255
Left = 3480
TabIndex = 17
Top = 1320
Width = 3735
End
Begin VB.Label Label4
Height = 255
Left = 3480
TabIndex = 16
Top = 1080
Width = 3735
End
Begin VB.Label Label3
Height = 255
Left = 3480
TabIndex = 15
Top = 840
Width = 3735
End
Begin VB.Label Label1
Caption = "ESTADO: Sin conexión"
Height = 255
Left = 120
TabIndex = 14
Top = 4920
Width = 2415
End
Begin VB.Label Label2
Caption = "Archivo a transmitir:"
Height = 255
Left = 0
TabIndex = 2
Top = 120
Width = 1695
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Funciones para hacer la llamada a los programas MSDOS
' que se usan para la compresión y decompresión
Private Declare Function GetActiveWindow Lib "User32" () As Long
Private Declare Function IsWindow Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function GetForegroundWindow Lib "User32" () As Long
'Variables globales
Dim PackMethod As Integer 'Método de compresión seleccionado
Dim UnpackMethod As Integer 'Método de descompresión del archivo recibido
Dim FileNameSend As String 'Nombre del archivo que se envia
Dim State As Integer 'Estado de recepción de datos
Dim Connected As Boolean 'Indicación de conexión
Dim WorkDrive As Variant 'Unidad de trabajo
Dim WorkDir As Variant 'Directorio de trabajo
Private Sub COM1_Click()
If Connected = False Then
MSComm1.CommPort = 1
End If
End Sub
Private Sub COM2_Click()
If Connected = False Then
MSComm1.CommPort = 2
End If
End Sub
Private Sub Command2_Click()
Dim vr As Long
Dim hWndAct As Long
Dim PackName As String
Dim Temp As String
Dim Zero As Byte
If (Text1.Text = "" Or (Dir(Text1.Text) = "")) Then
MsgBox "Error: No hay archivo seleccionado", vbExclamation, "Error"
Exit Sub
End If
If Connected = False Then
MsgBox "Error: No puedes transmitir sin estar conectado", vbExclamation, "Error"
Exit Sub
End If
Zero = 0
BackupDrive = Drive1.Drive 'Salvar unidad
BackupPath = Dir1.Path ' y directorio
Drive1.Drive = WorkDrive 'Colocarse en la unidad del programa
Dir1.Path = WorkPath ' y en el directorio
Command2.Enabled = False 'Desactivar botón
Open "ENTRADA.ARC" For Binary As #2 'Crear el archivo de entrada
Put #2, , Text1.Text 'Colocando el nombre del archivo
Put #2, , Zero 'Y terminando con un cero
Close #2 'Cerrar archivo ENTRADA.ARC
Drive1.Drive = BackupDrive 'Volver a colocarse la unidad
Dir1.Path = BackupPath ' y directorio anteriores
Label3.Caption = "Comprimiendo"
Label4.Caption = "Tamaño: " + Str(FileLen(Text1.Text))
Label5.Caption = ""
Select Case PackMethod
Case 1
PackName = "LZ6KPA.COM"
Case 2
PackName = "LZ3KPA.COM"
Case 3
PackName = "COPYPA.COM"
End Select
vr = Shell(PackName, vbMinimizedFocus) 'Ejecutar programa en ventana MSDOS minimizada
Do While GetActiveWindow() = hWndAct 'Esperar a que se abra la ventana
vr = DoEvents()
Loop
hWndAct = GetForegroundWindow() 'Tomar ventana
Do While IsWindow(hWndAct) 'Esperar a que se cierre la ventana
vr = DoEvents() ' lo cual indicará que el programa
Loop ' compresor ha terminado
If (Dir("SALIDA.CMP") = "") Then
MsgBox "Error: No se ha creado el archivo de salida", vbExclamation, "Error"
Label3.Caption = ""
Kill "ENTRADA.ARC"
Exit Sub
End If
Kill "ENTRADA.ARC"
Label3.Caption = "Compresión realizada, enviando"
Label5.Caption = "Tamaño comprimido: " + Str(FileLen("SALIDA.CMP"))
Select Case PackMethod
Case 1
MSComm1.Output = Chr(&H20)
Case 2
MSComm1.Output = Chr(&H21)
Case 3
MSComm1.Output = Chr(&H22)
End Select
FileLenght = FileLen("SALIDA.CMP")
D = FileLenght Mod 256
MSComm1.Output = Chr(D)
FileLenght = Int(FileLenght / 256)
D = FileLenght Mod 256
MSComm1.Output = Chr(D)
FileLenght = Int(FileLenght / 256)
D = FileLenght Mod 256
MSComm1.Output = Chr(D)
FileLenght = Int(FileLenght / 256)
D = FileLenght Mod 256
MSComm1.Output = Chr(D)
MSComm1.Output = FileNameSend + Chr(0)
Open "SALIDA.CMP" For Binary Access Read As #4
' Lee el archivo en bloques del tamaño del búfer de transmisión.
Bsize = MSComm1.OutBufferSize
LF& = LOF(4) 'Hallar tamaño del archivo
Do Until EOF(4)
' No lee demasiado al final.
If LF& - Loc(4) <= Bsize Then
Bsize = LF& - Loc(4)
End If
' Lee un bloque de datos.
Temp = Space$(Bsize)
Get #4, , Temp
' Transmite el bloque.
If Temp <> "" Then MSComm1.Output = Temp
Label3.Caption = "Enviando " + Str(Loc(4)) + " bytes"
If Err Then
MsgBox Error$, 48
Exit Do
End If
' Espera a que se envíen todos los datos.
Do
Ret = DoEvents()
Loop Until MSComm1.OutBufferCount = 0
If LF& = Loc(4) Then Get #4, , Temp ' Quita el EOF sin enviarlo
Loop
Close #4
Label3.Caption = "Archivo Enviado"
Kill "SALIDA.CMP"
Command2.Enabled = True 'Desactivar botón
End Sub
Private Sub Command3_Click()
Dim Ping As Byte
On Error Resume Next
Ping = &H31
If Connected = False Then
MSComm1.PortOpen = True
If (MSComm1.PortOpen = False) Then
MsgBox "Error: El Puerto de comunicación está en uso", vbExclamation, "Error"
Exit Sub
End If
Command3.Caption = "Desconectar"
Connected = True
COM1.Enabled = False
COM2.Enabled = False
RThreshold = 1
Label1.Caption = "ESTADO: Conectado"
State = 1
MSComm1.InputLen = 1
MSComm1.Output = Chr(Ping)
Else
MSComm1.PortOpen = False
Connected = False
Command3.Caption = "Conectar"
COM1.Enabled = True
COM2.Enabled = True
Label1.Caption = "ESTADO: Sin Conexión"
End If
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
On Error GoTo DriverError
Dir1.Path = Drive1.Drive
GoTo NoDriverError
DriverError:
MsgBox "Error: Unidad no preparada", vbExclamation, "Error"
Exit Sub
NoDriverError:
End Sub
Private Sub File1_Click()
If Right(Dir1.Path, 1) = "\" Then
Text1.Text = Dir1.Path & File1.FileName
Else
Text1.Text = Dir1.Path & "\" & File1.FileName
End If
FileNameSend = File1.FileName
End Sub
Private Sub Form_Load()
WorkDrive = Drive1.Drive
WorkDir = CurDir
Connected = False
PackMethod = 1
State = 1
End Sub
Private Sub METODO1_Click()
PackMethod = 1
End Sub
Private Sub METODO2_Click()
PackMethod = 2
End Sub
Private Sub METODO3_Click()
PackMethod = 3
End Sub
Public Sub MSComm1_OnComm()
Static Longitud As Long
Static Longitud2 As Long
Static RecFileName As String
Dim RecFilePath As String
Dim RecFileAll As String
Dim Rec As String
Dim D As Long
Dim vr2 As Long
Dim hWndAct2 As Long
Dim UnpackName As String
Select Case MSComm1.CommEvent
Case comEvReceive
Select Case State
Case 0 'Receiving a file of Longitud bytes
Rec = MSComm1.Input
Longitud = Longitud - Len(Rec)
Label6.Caption = "Recibiendo archivo. Recibidos " + Str(Longitud2 - Longitud) + " bytes"
Print #1, Rec;
If Longitud = 0 Then
Close #1
On Error GoTo NoGrabar
CommonDialog1.FileName = RecFileName
CommonDialog1.ShowSave
RecFileName = CommonDialog1.FileName
RecFileAll = RecFileName + Chr(0)
ChDrive (WorkDrive)
ChDir (WorkDir)
Open "SALIDA.ARC" For Binary As #3
Put #3, , RecFileAll
Close #3
Label6.Caption = "Descomprimiendo Archivo"
Select Case UnpackMethod
Case 1
UnpackName = "LZ6KUN.COM"
Case 2
UnpackName = "LZ3KUN.COM"
Case 3
UnpackName = "COPYUN.COM"
End Select
vr2 = Shell(UnpackName, vbMinimizedFocus)
Do While GetActiveWindow() = hWndAct2
vr2 = DoEvents()
Loop
hWndAct2 = GetForegroundWindow()
Do While IsWindow(hWndAct2)
vr2 = DoEvents()
Loop
Label8.Caption = "Descomprimido:" + Str(FileLen(RecFileName))
Kill "SALIDA.ARC"
NoGrabar:
Label6.Caption = "Archivo Recibido"
State = 1
MSComm1.InputLen = 1
Kill "ENTRADA.CMP"
End If
Case 1 'Awaiting an order
Rec = MSComm1.Input
D = Asc(Rec)
Select Case D
Case &H31 'Ping
Rec = Chr(&H35)
MSComm1.Output = Rec
Label1.Caption = "ESTADO: Enlace Establecido"
Case &H20 'File Coming, method 1
State = 2
UnpackMethod = 1
Case &H21 'File Coming, method 2
State = 2
UnpackMethod = 2
Case &H22 'File Coming, method 3
State = 2
UnpackMethod = 3
Case &H35 'Pong
Label1.Caption = "ESTADO: Enlace Establecido"
Case Else
'MsgBox "¡¡¡ERRRORRRR DE COMUNICACIÓN!!!"
Label1.Caption = "ESTADO: Enlace roto"
End Select
Case 2
Rec = MSComm1.Input
D = Asc(Rec)
Longitud = D
State = 3
Case 3
Rec = MSComm1.Input
D = Asc(Rec)
Longitud = Longitud + 256 * D
State = 4
Case 4
Rec = MSComm1.Input
D = Asc(Rec)
Longitud = Longitud + 65536 * D
State = 5
Case 5
Rec = MSComm1.Input
D = Asc(Rec)
Longitud = Longitud + 16777216 * D
Longitud2 = Longitud
State = 6
RecFileName = ""
Label6.Caption = "Recibiendo Archivo"
Label7.Caption = "Comprimido: " + Str(Longitud)
Label8.Caption = ""
Case 6 'Filling Name of Incoming file
RecFileName = RecFileName & MSComm1.Input
If Right(RecFileName, 1) = Chr$(0) Then
Open "ENTRADA.CMP" For Output As #1
State = 0
MSComm1.InputLen = 0
End If
End Select
Case comEvSend
Case comEvCD
EVMsg = "Cambio detectado en DCD"
Case comEvCTS
'EVMsg = "Cambio detectado en CTS"
Case comEvDSR
'EVMsg = "Cambio detectado en DSR"
Case comEvRing
EVMsg = "El teléfono está sonando"
Case comEvEOF
EVMsg = "Fin de fichero"
Case comBreak
EVMsg = "Interrupción detectada"
Case comCTSTO
ERMsg = "Tiempo para CTS sobrepasado"
Case comDSRTO
ERMsg = "Tiempo para DSR sobrepasado"
Case comCDTO
ERMsg = "Tiempo para DCD sobrepasado"
Case comFrame
ERMsg = "Error de trama"
Case comOverrun
ERMsg = "Error de sobreescritura"
Case comRxOver
ERMsg = "Buffer de recepción lleno"
Case comRxParity
ERMsg = "Error de Paridad"
Case comTxFull
ERMsg = "Buffer de transmisión lleno"
Case Else
ERMsg = "Error desconocido"
End Select
If Len(EVMsg) Then
Label1.Caption = EVMsg
EVMsg = ""
ElseIf Len(ERMsg) Then
Beep
vr = MsgBox(ERMsg, 1, "Pulse Cancelar para Salir, Aceptar para Ignorar.")
ERMsg = ""
If vr = 2 Then
MSComm1.PortOpen = False
End If
End If
End Sub
e-REdING. Biblioteca de la Escuela Superior de Ingenieros de Sevilla.
