option explicit
Const HHC="C:\Program Files\HTML Help Workshop\hhc.exe"
Dim G,i,T,C,w
Function B(Msg)
    On Error Resume Next
    Dim a, f, i
    Set a = WScript.CreateObject("Shell.Application")
    Set f = a.BrowseForFolder(&H0&, Msg, &h1&)
    B = f.ParentFolder.ParseName(f.Title).Path
    If Err.Number <> 0 Then
        B = Null
        If f.Title="Desktop" Then B=w.SpecialFolders("Desktop")
        i = InStr(f.Title, ":")
        If i > 0 Then B = Mid(f.Title, i - 1, 2) & "\"
    End If
End Function
Function Recurs(ByVal p)
    Dim f, k, s, t
    Set f = i.GetFolder(p)
    For Each k in f.subFolders
	s = s & Recurs(k)
    Next
    For Each k in f.Files
	t = ucase(k.name)
	if (Right(t,3) = "HTM") or (Right(t,4)="HTML") Then
		s = s & i.BuildPath(k.parentfolder, k.name) & vbCrLf
	End If
    Next
    Recurs = s
End Function
Function Debut(byval k)
    Dim s
    s = InputBox("Rentrez le nom du fichier (sans chemin) du fichier HTML principal")
    if (InStr(ucase(k),ucase(s))=0) Or (Len(s)=0) Then
	MsgBox "Le nom du fichier HTML précisé est invalide"
    Else
    If s<>"" Then
	k = vbCrLf & k
	k = Left(k,InStr(ucase(k),ucase(s))+Len(s))
	s = Len(k)
	While Mid(k,s,1)<>Chr(10)
	    s = s -1
	Wend
	s = Mid(k,s+1)
    End If
    end If
    Debut = s
End Function

If 1=MsgBox("Ce script génère un fichier CHM depuis un répertoire contenant un ensemble de pages HTML.",1) Then
G = B("Choisissez un répertoire contenant votre site")
Set w = CreateObject("WScript.Shell")
If IsNull(G) Then 
    MsgBox "Sélection invalide" 
Else
    Set i = CreateObject("Scripting.FileSystemObject")
    T = Recurs(G)
    G = w.SpecialFolders("Desktop") & "\PCFUN.HHP"
    Set c = i.CreateTextFile(G, -1)
    c.WriteLine("[OPTIONS]")
    c.WriteLine("Compatibility=1.1 or later")
    c.WriteLine("Compiled file=PCFUN.chm")
    c.WriteLine("Default topic=" & Debut(T))
    c.WriteLine("Display compile progress=No")
    c.WriteLine("Language=0x40c Français (standard)")
    c.WriteLine("Title=(c) 1999 JLA")
    c.WriteLine(vbCrLf & "[FILES]")
    c.WriteLine(T)
    c.WriteLine(vbCrLf & "[INFOTYPES]" & vbCrLf)
    c.Close
    Set c = WScript.CreateObject("WScript.Shell")
    'c.Run "notepad.exe " & G,3 ,-1
    c.Run Chr(34) & HHC & Chr(34) & Chr(32) & G,3 ,-1
    i.DeleteFile G
End If
End If