Sub création_trombinoscope()
ThisWorkbook.Activate
's'assurer qu'il n'existe pas de feuille nommée liste
For Each feuil In ThisWorkbook.Sheets
If feuil.Name = "liste" Then
MsgBox ("le fichier contient déjà une page ""liste""," & Chr(13) & "le trombinoscope ne peut pas être créé")
Exit Sub
End If
Next feuil
'créer un répertoire photos et un répertoire fiches
If Dir(ThisWorkbook.Path & "\photos", vbDirectory) = "" Then MkDir ThisWorkbook.Path & "\photos"
If Dir(ThisWorkbook.Path & "\fiches", vbDirectory) = "" Then MkDir ThisWorkbook.Path & "\fiches"
'créer la feuille liste
Set nouvfeuil = ThisWorkbook.Sheets.Add
nouvfeuil.Name = "liste"
nouvfeuil.Select
ActiveWindow.DisplayGridlines = False
Cells.Locked = False
'créer l'entête
ActiveWorkbook.Names.Add Name:="entêtes", RefersToR1C1:="=liste!R1"
Range("entêtes").Interior.ColorIndex = 34
Range("entêtes").Locked = True
tabcol = Array("nom", "prénom", "activité", "adresse", "bureau", "tel_interne", "tel_public", "fax", "mail")
'créer les différentes colonnes
For col = 1 To 9
Range("entêtes").Cells(col) = tabcol(col - 1)
ActiveWorkbook.Names.Add Name:=tabcol(col - 1), RefersToR1C1:="=liste!C" & col
Columns(col).Borders(xlEdgeLeft).LineStyle = xlContinuous
Columns(col).Borders(xlEdgeTop).LineStyle = xlContinuous
Columns(col).Borders(xlEdgeBottom).LineStyle = xlContinuous
Columns(col).Borders(xlEdgeRight).LineStyle = xlContinuous
Next col
'bouton de mise à jour
Rows(1).RowHeight = 37
ActiveSheet.Buttons.Add(5, 1.5, 600, 20).Select
Selection.OnAction = "mise_à_jour_trombinoscope"
Selection.Characters.Text = "CLIQUER POUR METTRE A JOUR"
'protéger la feuille (sans mot de passe)
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
'créer une image de remplacement en cas de manque de photo
création_pas_de_photo
'mode d'emploi
MsgBox "Les photos doivent être placées dans le répertoire ""photos"" à l'adresse : """ & ThisWorkbook.Path & "\photos""" & Chr(13) & Chr(13) & _
"Elles doivent être nommées ""Nom_Prénom.gif"" ou ""Nom_Prénom.jpg"" (format gif ou jpeg)."
MsgBox ("Il faut remplir les colonnes ""nom"", ""prénom"", ""adresse""... du tableau de la page ""liste"" du présent fichier")
mise_à_jour_trombinoscope
End Sub
Sub mise_à_jour_trombinoscope()
'met à jour toutes les fiches
'---------------------
premlin = Range("entêtes").Row + 1
derlin = Sheets("liste").Columns("A:A").Find("*", Sheets("liste").Cells(1), SearchDirection:=xlPrevious).Row
'---------------------
'mettre la liste à jour
création_liste_html
création_alphabet_html
création_cadres
'---------------------
'créer ou mettre à jour les fiches
For lin = premlin To derlin
création_fiche_html (lin)
Next lin
Cells(1).Select
End Sub
Sub création_alphabet_html()
'crée un alphabet en liens hypertextes
fich = ThisWorkbook.Path & "\alphabet.html"
Open fich For Output As 1
'creation Code
Print #1, "<HTML>" & Chr$(13)
Print #1, "<BODY BGCOLOR='WHITE'>" & Chr$(13)
Print #1, "<table width='100%' border='0' cellspacing='0'>" & Chr$(13)
Print #1, "<TR>" & Chr$(13)
Print #1, "<td height='30' valign='center' align='center' width='150' ><B> J@C </td>"
For lettre = 65 To 90
Print #1, "<td height='30' valign='center'><a href='liste.html#" & Chr(lettre) & "' target='gauche'>" _
& Chr(lettre) & "</a></td>"
Next lettre
Print #1, "</TABLE>" & Chr$(13); "</BODY>" & Chr$(13); "</HTML>" & Chr$(13)
Close
End Sub
Sub création_cadres()
'crée la page d'entrée du trombinoscope, trombino.html avec 3 frames,
'le premier en haut avec l'alphabet
'le second à gauche avec la liste des noms prénoms
'le troisième à droite avec les fiches
fich = ThisWorkbook.Path & "\trombino.html"
Open fich For Output As 1
Print #1, "<HTML>" & Chr$(13)
Print #1, "<FRAMESET rows='15%,85%' framespacing=0>" & Chr$(13)
Print #1, "<FRAME name='haut' src='alphabet.html' frameborder='no' scrolling=no noresize>" & Chr$(13)
Print #1, "<FRAMESET cols='30%,70%'>" & Chr$(13)
Print #1, "<FRAME NAME='gauche' src='liste.html' frameborder='no' noresize>" & Chr$(13)
Print #1, "<FRAME NAME='droite' src='blanc.html' frameborder='1' noresize scrolling=no>" & Chr$(13)
Print #1, "</FRAMESET>" & Chr$(13)
Print #1, "</FRAMESET>" & Chr$(13)
Print #1, "</HTML>" & Chr$(13)
Close
'crée une page blanche
fich = ThisWorkbook.Path & "\blanc.html"
Open fich For Output As 1
Print #1, "<HTML><BODY VALIGN='CENTER' BGCOLOR='WHITE' WIDTH='100%'>" & Chr$(13)
Print #1, "<BR><BR><BR><FONT SIZE=4 color='blue'><CENTER><B>Cliquez sur le nom à gauche" & Chr$(13)
Print #1, "</BODY></HTML>" & Chr$(13)
Close
End Sub
Sub création_fiche_html(lin)
'créer une fiche avec texte et photo
nomprénom = WorksheetFunction.Proper(Sheets("liste").Range("nom").Cells(lin)) & "_" & WorksheetFunction.Proper(Sheets("liste").Range("prénom").Cells(lin))
fich = ThisWorkbook.Path & "\fiches\" & nomprénom & ".html"
Open fich For Output As 1
'---------------------
Print #1, "<HTML>" & Chr$(13) & "<BODY>" & Chr$(13)
Print #1, "<TABLE border='0' width='100%'>" & Chr$(13)
'---------------------
Print #1, "<TR VALIGN='bottom'>" & Chr$(13)
cellvide = "<TD ALIGN='right'><FONT FACE='Arial'> </FONT></TD>" & Chr$(13)
cellvide5 = "<TD ALIGN='right' width='3%'><FONT FACE='Arial'> </FONT></TD>" & Chr$(13)
Print #1, cellvide5
Print #1, "<TD ALIGN='right' width='30%'><FONT FACE='Arial'> </FONT></TD>" & Chr$(13)
Print #1, cellvide5
Print #1, "<TD ALIGN='right' width='61%'><FONT FACE='Arial'> </FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
'---------------------
Print #1, "<TR VALIGN='bottom'>" & Chr$(13)
Print #1, cellvide
'les prénom et nom
Print #1, "<TD ALIGN='left' colspan=3><FONT FACE='Arial' SIZE=+2><B> " & ThisWorkbook.Sheets("liste").Range("prénom").Cells(lin) & " <FONT FACE='Arial' SIZE=+3>" & ThisWorkbook.Sheets("liste").Range("nom").Cells(lin) & "</B></FONT></FONT></FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
'---------------------
Print #1, "<TR VALIGN='bottom'>" & Chr$(13)
Print #1, cellvide
Print #1, "<TD COLSPAN=3 ALIGN='left'><FONT FACE='Arial'>" & ThisWorkbook.Sheets("liste").Range("activité").Cells(lin) & " </FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
'---------------------
Print #1, "<TR> </TR>" & Chr$(13)
'---------------------
Print #1, "<TR>" & Chr$(13)
Print #1, cellvide
'photo
'recherche de l'adresse de la photo
nomprénom = WorksheetFunction.Proper(Sheets("liste").Range("nom").Cells(lin)) & "_" & WorksheetFunction.Proper(Sheets("liste").Range("prénom").Cells(lin))
ph = Dir(ThisWorkbook.Path & "\photos\" & nomprénom & ".jpg")
If ph <> "" Then
photo = ph
Else
ph = Dir(ThisWorkbook.Path & "\photos\" & nomprénom & ".gif")
If ph <> "" Then
photo = ph
Else
photo = "pas_de_photo.gif"
End If
End If
'insertion de la photo
Print #1, "<TD ALIGN='middle' VALIGN='middle' rowspan=8><FONT FACE='Arial'><IMG SRC='../photos/" & photo & "' width='170' hspace='2'></FONT></TD>" & Chr$(13)
Print #1, cellvide
Print #1, cellvide
Print #1, "</TR>" & Chr$(13)
'---------------------
Print #1, "<TR>" & Chr$(13)
Print #1, cellvide
Print #1, cellvide5
'---------------------
'adresse
Print #1, "<TD ALIGN='left' VALIGN='middle'><FONT FACE='Arial'>" & ThisWorkbook.Sheets("liste").Range("adresse").Cells(lin) & " </FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
Print #1, "<TR>" & Chr$(13)
Print #1, cellvide
Print #1, cellvide
'---------------------
'bureau
bureau = ThisWorkbook.Sheets("liste").Range("bureau").Cells(lin)
Print #1, "<TD ALIGN='left' VALIGN='middle'><FONT FACE='Arial'>" & bureau & "</FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
Print #1, "<TR>" & Chr$(13)
Print #1, cellvide & cellvide
'---------------------
'téléphones
Print #1, "<TD ALIGN='left' VALIGN='middle'><FONT FACE='Arial'>téléphone public " & format_tel(ThisWorkbook.Sheets("liste").Range("tel_public").Cells(lin)) & " </FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
Print #1, "<TR>" & Chr$(13)
Print #1, cellvide & cellvide
Print #1, "<TD ALIGN='left' VALIGN='middle'><FONT FACE='Arial'>téléphone interne " & ThisWorkbook.Sheets("liste").Range("tel_interne").Cells(lin) & " </FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
Print #1, "<TR>" & Chr$(13)
Print #1, cellvide & cellvide
'---------------------
'fax et mail
Print #1, "<TD ALIGN='left' VALIGN='middle'><FONT FACE='Arial'>fax " & format_tel(ThisWorkbook.Sheets("liste").Range("fax").Cells(lin)) & " </FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
Print #1, "<TR>" & Chr$(13)
Print #1, cellvide & cellvide
Print #1, "<TD ALIGN='left' VALIGN='middle'><FONT FACE='Arial'>e-mail <A HREF='mailto:" & ThisWorkbook.Sheets("liste").Range("mail").Cells(lin) & "'>" & ThisWorkbook.Sheets("liste").Range("mail").Cells(lin) & " </A></FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
Print #1, "<TR>" & Chr$(13)
Print #1, cellvide & cellvide & cellvide
Print #1, "</TR>" & Chr$(13)
Print #1, "<TR>" & Chr$(13)
For i = 1 To 5
Print #1, cellvide & Chr$(13)
Next i
Print #1, "</TR>" & Chr$(13)
Print #1, "</TABLE>" & Chr$(13)
Print #1, "</HTML>" & Chr$(13) & "</BODY>" & Chr$(13)
Close
End Sub
Function format_tel(txte)
'met les n° de téléphone au bon format
txt = Format(txte, "0000000000")
format_tel = Left(txt, 2) & " " & Mid(txt, 3, 2) & " " & Mid(txt, 5, 2) & " " & Mid(txt, 7, 2) & " " & Right(txt, 2)
End Function
Sub création_liste_html()
'crée la liste des noms en ordre alphabétique, avec des lettres ancres pour faciliter les recherches
'trier les lignes de la liste par ordre alphabétique
premlin = Range("entêtes").Row + 1
derlin = Sheets("liste").Columns("A:A").Find("*", Sheets("liste").Cells(1), SearchDirection:=xlPrevious).Row
Sheets("liste").Rows(premlin & ":" & derlin).Select
ActiveSheet.Unprotect
Selection.Sort Key1:=Range("A:A"), Order1:=xlAscending
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
fich = ThisWorkbook.Path & "\liste.html"
Open fich For Output As 1
Print #1, "<HTML>" & Chr$(13)
Print #1, "<BODY BGCOLOR='WHITE'>" & Chr$(13)
Print #1, "<TABLE border='0' width='100%'>" & Chr$(13)
Print #1, "<TR>" & Chr$(13)
'titres
Print #1, "<TD width='15%'> </TD>" & Chr$(13)
Print #1, "<TD ALIGN='left' width='85%'><FONT SIZE=4><B>nom, prénom</B></FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
Print #1, "<TR> </TR>" & Chr$(13)
'liste
lettre = 65
For lin = premlin To derlin
'inscrire la lettre seule
ret:
If Asc(WorksheetFunction.Proper(Sheets("liste").Cells(lin, 1))) >= lettre Then
Print #1, "<TD> </TD>"
Print #1, "<TD ALIGN='left'><A name='" & Chr(lettre) & "'><FONT SIZE=3><B>" & Chr(lettre) & "</B></A></FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
lettre = lettre + 1
GoTo ret
End If
'inscrire les noms et prénoms avec liens hypertexte
Print #1, "<TD> </TD>"
nomprénom = WorksheetFunction.Proper(Sheets("liste").Cells(lin, 1)) & "_" & WorksheetFunction.Proper(Sheets("liste").Cells(lin, 2))
Print #1, "<TD ALIGN='left'><FONT SIZE=3><B><A HREF='fiches/" & nomprénom & ".html' TARGET='droite'>" & ThisWorkbook.Sheets("liste").Range("nom").Cells(lin) & " " & ThisWorkbook.Sheets("liste").Range("prénom").Cells(lin) & "</A></B></FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
Next lin
For lettre = lettre To Asc("Z")
Print #1, "<TD> </TD>"
Print #1, "<TD ALIGN='left'><A name='" & Chr(lettre) & "'><FONT SIZE=3><B>" & Chr(lettre) & "</B></A></FONT></TD>" & Chr$(13)
Print #1, "</TR>" & Chr$(13)
Next lettre
Print #1, "</TABLE>" & Chr$(13) & "</HTML>" & Chr$(13) & "</BODY>" & Chr$(13)
Close
End Sub
Sub création_pas_de_photo()
Set fichrien = Workbooks.Add
Columns(1).ColumnWidth = 17.43
Cells(1).FormulaR1C1 = "PHOTO NON DISPONIBLE"
Cells(1).Orientation = 47
'crée un graphique vide et y colle une image de la plage
Cells(1).CopyPicture , Format:=xlBitmap
Set gr = ActiveSheet.ChartObjects.Add(0, 0, Cells(1).Width, Cells(1).Height).Chart
With gr
.Paste
.Export ThisWorkbook.Path & "\photos\pas_de_photo.gif", "GIF"
End With
fichrien.Close (False)
End Sub