Attribute VB_Name = "ModHtml"
Option Explicit
'                  HTMCODE
'          v.1.1 Daniel Castillo 1998
'Modulo que facilita un poco la generacion de codigo de paginas
'web desde vb
' Los comentarios aqui que comienzan con *1.1 son las
' cosas nuevas en esta version
'
' Constantes publicas
Global Const htm_comillas = """"
Global Const htm_nulo = "&nbsp;"

' Alineaciones genericas (texto e imagenes)
Global Const htm_centro = "center"
Global Const htm_izquierda = "left"
Global Const htm_derecha = "right"
'*1.1 Alineaciones especiales para imagenes
Global Const htm_medio = "middle"
Global Const htm_superior = "top"
Global Const htm_inferiorABS = "absbottom"
Global Const htm_medioABS = "absmiddle"
Global Const htm_textosuperior = "texttop"
Global Const htm_lineabase = "baseline"



' PROCEDIMIENTOS Y FUNCIONES DE INTERES
'
' Sub htm_inicia (fichero As String)
'  Abre el fichero destino para empezar a escribir el codigo
' Sub htm_finaliza
'  cierra el fichero, hay que ponerlo cuando terminemos de crear la pagina
' Sub htm_htm (titulo As String)
'   crea la seccion HTML y Head de la pagina
'   con un titulo
' Sub htm_Body (imagenfondo As String, ColorFondo As Long, ColorTexto As Long, ColorLink As Long, ColorLinkv As Long, MargenIzquierdo As Integer)
'   crea el inicio del body
'   si imagenfondo <>""  pone "imagen" como fondo de la pagina
'   ColorTexto,ColorLink,ColorLinkv y COlorlinka
'    respectivamente el color del texto y de los links (normal, visitado, activo)

' Sub htm_finbody ()
'   finaliza la seccion "body"
' Sub htm_finhtm ()
'   finaliza la seccion "htm"
' Sub htm_codigo (c)
'   permite "insertar" directamente codigo en la pagina sin usar las funciones del modulo
' Sub htm_texto (t)
'   muestra el texto T
' Sub htm_textoalineado (t , alineacion)
'   muestra el texto T alineado (alineacion =htm_centro o htm_derecha o htm_izquierda)
' Function htm_textoalineadoF (t, alineacion) as string
'  *1.1* similar a la anterior, pero en forma de funcion , vale para pasar el texto con formato como parametro de otra rutina o funcion
' Function htm_fuente (t, fuente, size, color As Long) As String
'    para escribir "t" con otra fuente,color y tamaņo
' Function htm_negrita (t) As String
' Function htm_cursiva (t) As String
' Function htm_subrayado (t) As String
'Function htm_vinculo (Vinculo, target, texto) As String
' Function htm_vinculoimagen (Vinculo, imagen) As String
' Function htm_imagen (imagen) As String
' Function htm_imagenAlineadaF (imagen , alineacion) As String
'  *1.1* Inserta una imagen alineada
'  Como son funciones para usarlas "solas" hay que ponerlas
'  o dentro de una tabla o como texto
'    i.e.    htm_texto htm_imagen_alineada (.....
'Sub htm_lineaHorizontal (alto, ancho, color as long, alineacion)
'   el ancho puede ser en porcentaje  por ejemplo "75%"
' Sub htm_Sangria ()
' Sub htm_FinSangria ()
'
'
'Sub htm_tabla (ancho, borde, relleno, espaciado, alineacion)
' inicia una tabla
'Sub htm_tablaX (imagen, colorfondo as long, ancho, borde, relleno, espaciado, alineacion)
'  *1.1* igual que la anterior, pero con una imagen o un color de fondo

' Sub htm_FinTabla ()
' sub htm_TFila ()
' sub htm_FinTFila ()
' sub htm_TCelda (contenido)
' Sub htm_tceldaX (imagen, colorfondo As Long, contenido, numeroceldas)
'   *1.1* igual que la anterior , pero con una imagen o un color de fondo
' con numeroceldas >1 permite combinar celdas (el numero de celdas que pongamos)

' htm_marcador (nombre)
'   *1.1* luego se acceden con  htm_vinculo("#nombre" ....

'
'

'Sub htm_tab2compress (ficheroin, ficheroOut)
'  elimina sangria y saltos de linea no necesarios de un fichero htm
'  el fichero htm resultante es menos legible, pero ocupa un poco menos
'  depende de la estructura de la pagina , pero se puede reducir entre un 10% y un 20% el tamaņo del fichero
'  no es mucho... pero para indices largos...menos dinero pa timofonica ., tamien depende si queremos luego modificar a mano el fichero o no


'________________________________________________________
Dim htm_filenum
Dim htm_Iniciado
Dim htm_sngAct

Sub htm_body(imagenfondo As String, colorfondo As Long, ColorTexto As Long, ColorLink As Long, ColorLinkv As Long, ColorLinka As Long, MargenIzquierdo As Integer)

If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 Print #htm_filenum, htm_sngAct & "<body ";
 If imagenfondo <> "" Then
   Print #htm_filenum, "background=" & htm_comillas & imagenfondo & htm_comillas & " ";
 End If
 Print #htm_filenum, "bgcolor=" & htm_hexa(colorfondo) & " ";
 Print #htm_filenum, "text=" & htm_hexa(ColorTexto) & " ";
 Print #htm_filenum, "link=" & htm_hexa(ColorLink) & " ";
 Print #htm_filenum, "vlink=" & htm_hexa(ColorLinkv) & " ";
 Print #htm_filenum, "alink=" & htm_hexa(ColorLinka) & " ";

 Print #htm_filenum, "leftmargin=" & htm_comillas & MargenIzquierdo & htm_comillas;
 
 Print #htm_filenum, ">"
 htm_pasomas
End If
End Sub

Sub htm_codigo(c)
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 Print #htm_filenum, c
End If
End Sub

Function htm_cursiva(t) As String
  htm_cursiva = "<em>" & t & "</em>"
End Function

Sub htm_finaliza()
 Close (htm_filenum)
End Sub

Sub htm_finbody()
 htm_pasomenos
 htm_codigo htm_sngAct & "</body>"
End Sub

Sub htm_finhtm()
 htm_pasomenos
 htm_codigo "</html>"
End Sub

Sub htm_finsangria()
 htm_pasomenos
 htm_codigo htm_sngAct & "</blockquote>"
End Sub

Sub htm_fintabla()
 htm_pasomenos
 htm_codigo htm_sngAct & "</table>"
 htm_codigo htm_sngAct & "</div>"
End Sub

Sub htm_fintfila()
 htm_pasomenos
 htm_codigo htm_sngAct & "</tr>"
End Sub

Function htm_fuente(t, fuente, size, color As Long) As String
Dim sdum
sdum = "<font color=" & htm_hexa(color)
If fuente & "" <> "" Then
 sdum = sdum & " face=" & htm_comillas & fuente & htm_comillas
End If
If (size <> 0) And (size <> 3) Then
 sdum = sdum & " size=" & htm_comillas & size & htm_comillas
End If

sdum = sdum & ">" & t & "</font>"
htm_fuente = sdum
End Function

Function htm_hexa(N As Long) As String
' ojo, le "da la vuelta" al resultado
' lo que pasa es que el htm toma las componentes de color
' como azul-verde-rojo, en lugar del rojo-verde-azul de
' la sentencia vb RGB
Dim s
s = Hex$(N)
While Len(s) < 6
 s = "0" & s
Wend
s = Right$(s, 2) & Mid$(s, 3, 2) & Left$(s, 2)
s = htm_comillas & "#" & s & htm_comillas
htm_hexa = s
End Function

Sub htm_HL_dynaset2htm(D As Recordset, colortitulo As Long, colorresto As Long)
Dim dc As Recordset 'Dynaset
Set dc = D.Clone()
dc.MoveFirst
Dim k
htm_tabla "100%", 1, 2, 3, htm_centro
 htm_tfila
  For k = 0 To dc.Fields.Count - 1
   htm_tceldax "", colortitulo, (dc.Fields(k).Name), 1, ""
   
  Next
 htm_fintfila
 While Not dc.EOF
  htm_tfila
   For k = 0 To dc.Fields.Count - 1
    htm_tceldax "", colorresto, (dc.Fields(k).Value), 1, ""
   
   Next
  htm_fintfila
  dc.MoveNext
 Wend


dc.Close
End Sub

Sub htm_hl_fichero2htm(fichero, presentacion)
' inserta un fichero de texto plano (max 64 K)
'
' presentacion puede ser
' 0= solo inserta , sin saltos de linea
' 1= inserta saltos de linea "normales"
' 2= inserta cambios de parrafo entre cada linea del fichero

Dim f, texto
f = FreeFile

Open fichero For Input As f
Select Case presentacion
Case 0:
    htm_texto Input$(LOF(f), f)
Case 1:
    htm_codigo "<p>"
    While Not EOF(f)
     Line Input #f, texto
     htm_codigo texto & "<br>"
    Wend
    htm_codigo "</p>"

Case 2:
    While Not EOF(f)
     Line Input #f, texto
     htm_texto texto
    Wend
End Select

Close f

End Sub

Sub htm_hl_grafica(D As Recordset, campoid, campo, colortitulo As Long, colorresto As Long, colorbarras As Long)
' dibuja una grafica de barras con los valores de un campo de un dynaset
' por ejemplo htm_hl_grafica (data1.recordset) , "Nombre" , "Saldo", rgb (100,100,100),rgb(255,255,255),rgb(255,0,0)
'  muestra una grafica con los valores de saldo para cada registro, pone "Nombre" para identificar cada registro

Dim dc As Recordset
Set dc = D.Clone()
Dim max As Double, min As Double, Count, lon
Dim k, ca
dc.MoveFirst
max = dc(campo)
min = max
Count = 0
While Not dc.EOF
  ca = dc(campo)
  If ca > max Then max = ca
  If ca < min Then min = ca
  Count = Count + 1
  dc.MoveNext
Wend
If min > 0 Then min = 0
If max < 0 Then max = 0
lon = max - min
If lon = 0 Then lon = 1
Dim ancho As Double
Const anchomax = 20
dc.MoveFirst
htm_tabla "100%", 1, 0, 0, htm_centro
 htm_tfila
  htm_tceldax "", colortitulo, htm_negrita(campoid), 1, ""
  htm_tceldax "", colortitulo, htm_negrita(campo), 1, ""
  htm_tceldax "", colortitulo, "", 20, ""
 htm_tfila
 While Not dc.EOF
  htm_tfila
   htm_tceldax "", colortitulo, (dc(campoid)), 1, ""
   htm_tceldax "", colortitulo, (dc(campo)), 1, ""
   ca = dc(campo)
   ancho = (ca - min) * anchomax / lon
   
   ancho = Int(ancho)
   For k = 1 To anchomax
    If k <= ancho Then
     htm_tceldax "", colorbarras, "", 1, ""
    Else
     htm_tceldax "", colorresto, "", 1, ""
    End If
   Next
  htm_fintfila
  dc.MoveNext
 Wend

 htm_tfila
  htm_tceldax "", colortitulo, "", 2, ""
  htm_tceldax "", colortitulo, htm_textoalineadoF(Int(min), htm_izquierda), 10, ""
  htm_tceldax "", colortitulo, htm_textoalineadoF(Int(max), htm_derecha), 10, ""
 htm_tfila

dc.Close

End Sub

Sub htm_htm(titulo As String)

If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 Print #htm_filenum, "<html>"
 htm_pasomas
 Print #htm_filenum, "<head>"
 Print #htm_filenum, "<meta http-equiv=" & htm_comillas & "Content-Type" & htm_comillas
 Print #htm_filenum, "content=" & htm_comillas & "text/html; charset=iso-8859-1" & htm_comillas & ">"

 Print #htm_filenum, "<meta name=" & htm_comillas & "GENERATOR" & htm_comillas & " content=" & htm_comillas & "DC-HtmGen98" & htm_comillas & ">"
 Print #htm_filenum, "<title>" & titulo & "</title>"
 Print #htm_filenum, "</head>"

End If
End Sub

Function htm_imagen(imagen) As String
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 htm_imagen = "<img src=" & htm_comillas & imagen & htm_comillas & ">"
End If

End Function

Function htm_imagenAlineadaF(imagen, alineacion) As String
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 Dim dum
 dum = "<img src=" & htm_comillas & imagen & htm_comillas
 dum = dum & " align=" & htm_comillas & alineacion & htm_comillas
 dum = dum & ">"
 htm_imagenAlineadaF = dum
End If

End Function

Sub htm_inicia(fichero As String)
 htm_filenum = FreeFile
 htm_Iniciado = True
 htm_sngAct = ""
 Open fichero For Output As htm_filenum

End Sub

Sub htm_lineahorizontal(alto, ancho, color As Long, alineacion)
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 Print #htm_filenum, htm_sngAct & "<hr ";
 Print #htm_filenum, "align=" & htm_comillas & alineacion & htm_comillas & " ";
 Print #htm_filenum, "size=" & htm_comillas & alto & htm_comillas & " ";
 Print #htm_filenum, "width=" & htm_comillas & ancho & htm_comillas & " ";
 Print #htm_filenum, "color=" & htm_hexa(color);
 Print #htm_filenum, ">"
End If

End Sub

Sub htm_marcador(nombre)
 htm_codigo "<A name=" & htm_comillas & nombre & htm_comillas & ">"
End Sub

Function htm_negrita(t) As String
  htm_negrita = "<strong>" & t & "</strong>"
End Function

Sub htm_pasomas()
  htm_sngAct = htm_sngAct & "  "
End Sub

Sub htm_pasomenos()
 If Len(htm_sngAct) > 2 Then
  htm_sngAct = Left$(htm_sngAct, Len(htm_sngAct) - 2)
 Else
  htm_sngAct = ""
 End If
End Sub

Sub htm_sangria()
 htm_codigo htm_sngAct & "<blockquote>"
 htm_pasomas
End Sub

Function htm_subrayado(t) As String
  htm_subrayado = "<u>" & t & "</u>"
End Function

Sub htm_tab2compress(ficheroin, ficheroout)
' elimina sangria y saltos de linea no necesarios
' el fichero htm resultante es menos legible, pero ocupa un poco menos
Dim fn1, fn2
fn1 = FreeFile
Open ficheroin For Input As #fn1
fn2 = FreeFile
Open ficheroout For Output As #fn2
Dim s
While Not EOF(fn1)
  Line Input #fn1, s
  s = LTrim(RTrim(s))
  Print #fn2, s;
Wend
Close fn1
Close fn2
End Sub

Sub htm_tabla(ancho, borde, relleno, espaciado, alineacion)
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 Print #htm_filenum, htm_sngAct & "<div align=" & htm_comillas & alineacion & htm_comillas & ">"
 Print #htm_filenum, htm_sngAct & "<table border=" & htm_comillas & borde & htm_comillas & " cellpadding=" & htm_comillas & relleno & htm_comillas & " cellspacing=" & htm_comillas & espaciado & htm_comillas & " width=" & htm_comillas & ancho & htm_comillas & ">"
 htm_pasomas
End If
End Sub

Sub htm_tablaX(imagen, colorfondo As Long, ancho, borde, relleno, espaciado, alineacion)
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 Print #htm_filenum, htm_sngAct & "<div aling=" & htm_comillas & alineacion & htm_comillas & ">"
 Print #htm_filenum, htm_sngAct & "<table border=" & htm_comillas & borde & htm_comillas & " cellpadding=" & htm_comillas & relleno & htm_comillas & " cellspacing=" & htm_comillas & espaciado & htm_comillas & " width=" & htm_comillas & ancho & htm_comillas
 If imagen & "" <> "" Then
  Print #htm_filenum, " background=" & htm_comillas & imagen & htm_comillas
 Else
  Print #htm_filenum, " bgcolor=" & htm_hexa(colorfondo);
 End If
 Print #htm_filenum, ">"
 htm_pasomas
End If

End Sub

Sub htm_tCelda(contenido)
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 If contenido & "" = "" Then contenido = "&nbsp;"
 Print #htm_filenum, htm_sngAct & "<td>" & contenido & "</td>"
End If
End Sub

Sub htm_tceldax(imagen, colorfondo As Long, contenido, numeroceldas, ancho)
' Una celda expandida, con mas caracteristicas
' que una celda "normal"
' imagen <>"" incluye una imagen
' color fondo
' numeroceldas>1 para combinar varias celdas en una
' ancho <>"" (por ejemplo "25%" ) para especificar un ancho
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
  Print #htm_filenum, htm_sngAct & "<td";
 If contenido & "" = "" Then contenido = "&nbsp;"
 If imagen & "" <> "" Then
  Print #htm_filenum, " background=" & htm_comillas & imagen & htm_comillas
 Else
  Print #htm_filenum, " bgcolor=" & htm_hexa(colorfondo);
 End If
 If numeroceldas > 1 Then
   Print #htm_filenum, " colspan=" & htm_comillas & numeroceldas & htm_comillas
 End If
 If ancho & "" <> "" Then
   Print #htm_filenum, " width=" & htm_comillas & ancho & htm_comillas
 End If

 Print #htm_filenum, ">"
 Print #htm_filenum, contenido & "</td>"
End If

End Sub

Sub htm_texto(t)
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 If t & "" = "" Then t = "&nbsp;"
 Print #htm_filenum, htm_sngAct & "<p>";
 Print #htm_filenum, t;
 Print #htm_filenum, " </p>"

End If

End Sub

Sub htm_textoalineado(t, alineacion)
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 If t & "" = "" Then t = "&nbsp;"
 Print #htm_filenum, htm_sngAct & "<p align=" & htm_comillas & alineacion & htm_comillas & ">";
 Print #htm_filenum, t;
 Print #htm_filenum, " </p>"

End If

End Sub

Function htm_textoalineadoF(t, alineacion) As String
Dim s
 If t & "" = "" Then t = "&nbsp;"
 s = "<p align=" & htm_comillas & alineacion & htm_comillas & ">"
 s = s & t & " </p>"
 htm_textoalineadoF = s

End Function

Sub htm_tfila()
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 Print #htm_filenum, htm_sngAct & "<tr>"
 htm_pasomas
End If
 
End Sub

Function htm_vinculo(Vinculo, target, texto) As String
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 Dim sdum
 If texto & "" = "" Then texto = "<>"
 sdum = "<a href=" & htm_comillas & Vinculo & htm_comillas
 If target & "" <> "" Then
  sdum = sdum & " target=" & htm_comillas & target & htm_comillas
 End If
 sdum = sdum & ">" & texto & "</a>"
 htm_vinculo = sdum
End If

End Function

Function htm_vinculoimagen(Vinculo, imagen) As String
If Not htm_Iniciado Then
 MsgBox "Fichero htm no iniciado"
Else
 
 htm_vinculoimagen = "<a href=" & htm_comillas & Vinculo & htm_comillas & ">" & htm_imagen(imagen) & "</a>"
End If

End Function


