Attribute VB_Name = "Module1"
Option Explicit
Public i As Long
Public j As Long
Public AL As String
Public N1 As String
Public a As Integer
Public A9 As Integer
Public E9 As Integer
Public I9 As Integer
Public O9 As Integer
Public U9 As Integer
Public X9 As Integer
Public ma()
Public mb()
Public mc()
Public md()
Public s1 As Integer
Public suPerficie As Double
Public Sub almacenambiento()
' CancelError es True.
On Error GoTo ErrHandler
' Establece los filtros.
Form1.CommonDialog1.Filter = "Archivos Corelap (*.clp)|*.clp|Archivos de Texto (*.txt)|*.txt|Todo tipo de Archivos (*.*)|*.*"
' Especifique el filtro predeterminado.
Form1.CommonDialog1.FilterIndex = 1
' Presenta el cuadro de diálogo Abrir.
Form1.CommonDialog1.ShowOpen
' Llamada al procedimiento para abrir archivo.
AL = Form1.CommonDialog1.FileName
Module2.Abrir
Exit Sub
ErrHandler:
' El usuario hizo clic en el botón Cancelar.
Exit Sub
End Sub
Public Sub ALMACENAMIENTO2()
'variable contador
Dim c As Long
Dim j As Long
'ALMACENAMIENTO DEL VALOR DE LOS PARÁMETROS DE COMPARACIÓN
A9 = Form2.Text3(0).Text
E9 = Form2.Text3(1).Text
I9 = Form2.Text3(2).Text
O9 = Form2.Text3(3).Text
U9 = Form2.Text3(4).Text
X9 = Form2.Text3(5).Text
'almacenamos valor de la superficie
suPerficie = CDbl(Form2.Text4.Text)
a = CInt(Form2.Text1.Text)
'ESCONDAMOS EL TEXTO Y LOS CUADROS QUE SE VEIAN EN EL LADO DERECHO DEL FORMULARIO
For i = 0 To 5
Form2.Text3(i).Visible = False
Form2.Label5(i).Visible = False
Next
Form2.Command3.Visible = False
Form2.Command4.Visible = False
Form2.Label4.Visible = False
Form2.Label6.Visible = False
Form2.Label9.Visible = False 'INDICACIÓN DE SUPERFICIE
Form2.Text4.Visible = False 'INDICACIÓN DE SUPERFICIE
'COLOQUEMOS LA MATRIZ DONDE SE HARÁ LA COMPARACIÓN ENTRE LOS DEPARTAMENTOS
For i = 1 To a
For j = 1 To i
Form2.Text2(2 * a + c + 1).Left = 4750 + 495 * (a - 1) - 495 * (j - 1)
Form2.Text2(2 * a + c + 1).Top = 2690 + 495 * (a - i)
Form2.Text2(2 * a + c + 1).Visible = True
Form2.Text2(2 * a + c + 1).Width = 495
Form2.Text2(2 * a + c + 1).MaxLength = 1
Form2.Text2(2 * a + c + 1).FontBold = True
If j = i Then
Form2.Text2(2 * a + c + 1).Enabled = False
Form2.Text2(2 * a + c + 1) = ""
Form2.Text2(2 * a + c + 1).BackColor = RGB(265, 0, 0)
End If
c = c + 1
Next
Next
'coloquemos las constantes en un lugar visible
Form2.Label5(6).Caption = "A=" & A9 & ", E=" & E9 & ", I=" & I9 & ", O=" & O9 & ", U=" & U9 & ", X=" & X9
Form2.Label5(6).Top = 1200
Form2.Label5(6).Left = 5300
Form2.Label5(6).Width = 16000
Form2.Label5(6).Visible = True
Form2.Label5(6).Alignment = 0
End Sub
Public Sub subida1()
Dim c As Long
Dim j As Long
'subamos y bajemos todas las columnas
For i = 1 To a
For j = 1 To i
Form2.Text2(2 * a + c + 1).Top = 2690 + 495 * (a - i) - Form2.VScroll1.Value * 495
c = c + 1
Next
Next
Dim ñ As Integer
Dim q As Integer
ñ = 0
q = 0
For i = 1 To a
ñ = ñ + 1
q = q + ñ
Next
For i = 2 * a + 1 To q + 2 * a
If Form2.Text2(i).Left > 4740 And Form2.Text2(i).Top > 2680 Then
Form2.Text2(i).Visible = True
ElseIf Form2.Text2(i).Left < 4740 Or Form2.Text2(i).Top < 2680 Then
Form2.Text2(i).Visible = False
End If
Next
End Sub
Public Sub horizontal()
Dim c As Long
Dim j As Long
'desplacemos todas las columnas
For i = 1 To a
For j = 1 To i
Form2.Text2(2 * a + c + 1).Left = 4750 + 495 * (a - 1) - 495 * (j - 1) - Form2.HScroll1.Value * 495
c = c + 1
Next
Next
Dim ñ As Integer
Dim q As Integer
ñ = 0
q = 0
For i = 1 To a
ñ = ñ + 1
q = q + ñ
Next
For i = 2 * a + 1 To q + 2 * a
If Form2.Text2(i).Left > 4740 And Form2.Text2(i).Top > 2680 Then
Form2.Text2(i).Visible = True
ElseIf Form2.Text2(i).Left < 4740 Or Form2.Text2(i).Top < 2680 Then
Form2.Text2(i).Visible = False
End If
Next
'movimiento de la numeración de los departamentos
For i = 0 To a - 1
Form2.Label7(i).Left = 4750 + 495 * i - Form2.HScroll1.Value * 495
Form2.Label7(i).Visible = True
If Form2.Label7(i).Left < 4740 Then
Form2.Label7(i).Visible = False
End If
Next
End Sub
Private Sub Nuevo()
' CancelError es True.
On Error GoTo ErrHandler
' Establece los filtros.
Form1.CommonDialog1.Filter = "Archivos Corelap (*.clp)|*.clp|Archivos de Texto (*.txt)|*.txt|Todo tipo de Archivos (*.*)|*.*"
' Especifique el filtro predeterminado.
Form1.CommonDialog1.FilterIndex = 1
' Presenta el cuadro de diálogo Abrir.
Form1.CommonDialog1.ShowSave
' Llamada al procedimiento para abrir archivo.
N1 = Form1.CommonDialog1.FileName
'creación del fichero por el usuario
Dim fs
Dim A2
Set fs = CreateObject("Scripting.FileSystemObject")
Set A2 = fs.CreateTextFile(N1, True)
A2.Close
Module1.enregistradomatriz
Exit Sub
ErrHandler:
' El usuario hizo clic en el botón Cancelar.
Exit Sub
End Sub
Public Sub siguiente()
If Form1.SE = True Then
s1 = MsgBox("¿Guardamos las modificaciones en el mismo fichero?", vbYesNo, "Guardar Modificaciones")
If s1 = 7 Then
Nuevo
Else
enregistradomatriz
End If
Else
Module1.Nuevo
End If
End Sub
Public Sub enregistradomatriz()
ReDim ma(a + a + 6, a + 5)
ReDim mb(4, a + 3)
ReDim mc(4, a + 3)
ReDim md(4 + 2 * a, a)
Dim c As Long
Dim TC As Long
Dim rc As Long
Dim ALERTA
'guardo el nombre del departamento y la superficie
For i = 1 To a
ma(1, i) = Form2.Text2(i).Text
ma(2, i) = CDbl(Form2.Text2(a + i).Text)
Next
'guardo el valor de la relación entre departamentos
c = 0
For i = 1 To a
For j = 1 To i
If Form2.Text2(2 * a + c + 1) = "A" Then
ma(2 + a - j + 1, a - i + 1) = A9
ma(2 + a + a - j + 1, a - i + 1) = "A"
ElseIf Form2.Text2(2 * a + c + 1) = "E" Then
ma(2 + a - j + 1, a - i + 1) = E9
ma(2 + a + a - j + 1, a - i + 1) = "E"
ElseIf Form2.Text2(2 * a + c + 1) = "I" Then
ma(2 + a - j + 1, a - i + 1) = I9
ma(2 + a + a - j + 1, a - i + 1) = "I"
ElseIf Form2.Text2(2 * a + c + 1) = "O" Then
ma(2 + a - j + 1, a - i + 1) = O9
ma(2 + a + a - j + 1, a - i + 1) = "O"
ElseIf Form2.Text2(2 * a + c + 1) = "U" Then
ma(2 + a - j + 1, a - i + 1) = U9
ma(2 + a + a - j + 1, a - i + 1) = "U"
ElseIf Form2.Text2(2 * a + c + 1) = "X" Then
ma(2 + a - j + 1, a - i + 1) = X9
ma(2 + a + a - j + 1, a - i + 1) = "X"
End If
c = c + 1
Next
Next
'hagamos el procedimiento para poder calcular el TCR
For i = 1 To a - 1
For j = 1 To i
ma(2 + a - i, 1 + a - j) = ma(3 + a - j, a - i)
Next
Next
'ahora podemos calcular el TCR q incorporaremos a la última columna de la matriz
'hagamos primero cero los elementos de la diagonal pq nos da problemas
For j = 1 To a
ma(j + 2, j) = 0
Next
'ahora TCR para cada departamento
For i = 1 To a
For j = 1 To a
rc = ma(j + 2, i)
TC = TC + rc
ma(a + 3, i) = TC
Next
TC = 0
Next
'almacenemos los valores de ma en md para poder hacer la representación gráfica después
For i = 1 To a
md(1, i) = ma(1, i)
md(2, i) = ma(2, i)
md(3, i) = ma(a + 3, i)
For j = 1 To a
md(3 + j, i) = ma(2 + j, i)
Next
Next
'los valores de las constantes ya han sido almacenados
'****************************************************************
'guardemos los datos del problema en el fichero
If s1 = 6 And Form1.SE = True Then
Open AL For Output As #1 'archivo abienrto
Else
Open N1 For Output As #1 'neuvo archivo
End If
Write #1, a
'valor de la superficie disponible
Write #1, suPerficie
'introduzcamos valor de las relaciones
Write #1, A9
Write #1, E9
Write #1, I9
Write #1, O9
Write #1, U9
Write #1, X9
'introduzcamos el nombre de los departamentos
For i = 1 To a
Write #1, ma(1, i)
Next
'introduzcamos el valor de las superficies
For i = 1 To a
Write #1, CDbl(ma(2, i))
Next
'introduzcamos el valor de la relación entre los departamentos
For i = 1 To a
For j = 1 To i
If i = j Then
Write #1, ""
Else
Write #1, ma(3 + a + a - j, a - i + 1)
End If
Next
Next
Write #1, "Fichero creado para ser utilizado por el programa CORELAP 01"
Write #1, "Benito Fernández Márquez"
Close #1 'en el fichero de texto no se escribe nada más
'**********************************************************************************
'ordenemos la matriz en función del tcr y teniendo en cuenta la superficie
'para ello primero debemos ordenar los departamentos de
'menor a mayor
Dim l As Integer
Dim s As Integer
Dim x As Double
Dim O As Double
For l = 1 To a
x = ma(2, l)
O = l
For s = 1 To a
If x <= ma(2, s) Then
x = ma(2, s)
O = s
End If
Next
mb(3, a + 1 - l) = ma(2, O)
mb(1, a + 1 - l) = ma(1, O)
mb(2, a + 1 - l) = ma(a + 3, O)
ma(2, O) = -1E+42
Next
'ordenemos ahora la matriz en función del tcr (mayor a menor)
For l = 1 To a
x = mb(2, l)
O = l
For s = 1 To a
If x <= mb(2, s) Then
x = mb(2, s)
O = s
End If
Next
mc(3, l) = mb(3, O)
mc(2, l) = mb(2, O)
mc(1, l) = mb(1, O)
mb(2, O) = -1E+42
Next
'For i = 1 To a
'Form3.List1.AddItem mc(2, i) & Space(5) & mc(3, i) & Space(5) & mc(1, i)
'Next
Module1.meterenlista
End Sub
Public Sub meterenlista()
'For i = 1 To a
'Form3.List1.AddItem mc(1, i) & Space(5) & mc(2, i) & Space(5) & mc(3, i)
'Next
'Form3.Show
'metamos en el formulario 4
Form4.Show
End Sub
e-REdING. Biblioteca de la Escuela Superior de Ingenieros de Sevilla.
