' Remplace les accents Windows par des accents HTML
' ==================================================
' Selecting a file in a common file dialog window
Class SelectFile
Private fso, sPath1
Private Sub Class_Initialize()
Set fso = CreateObject("Scripting.FileSystemObject" )
End Sub
Private Sub Class_Terminate()
Set fso = Nothing
End sub
Public Function Browse()
On Error Resume Next
sPath1 = GetPath
Browse = sPath1
End function
Private Function GetPath()
Dim Ftemp, ts, IE, sPath
Ftemp = fso.GetSpecialFolder(2)
Ftemp = Ftemp & "\FileBrowser.html"
Set ts = fso.CreateTextFile(Ftemp, true)
ts.WriteLine "<html>"
ts.WriteLine "<body bgcolor=" & chr(34) & "#F3F3F8" & chr(34) & " text=" & chr(34) & "black" & chr(34) & ">"
ts.WriteLine "<script language=" & chr(34) & "VBScript" & chr(34) & ">"
ts.WriteLine "sub but_onclick()"
ts.WriteLine "status = document.forms(0).elements(0).value"
ts.WriteLine "end sub"
ts.WriteLine "sub butc_onclick()"
ts.WriteLine "status = " & chr(34) & "cancel" & chr(34)
ts.WriteLine "end sub"
ts.WriteLine "</script>"
ts.WriteLine "<div align=" & chr(34) & "center" & chr(34) & ">"
ts.WriteLine "<br>"
ts.WriteLine "<form>"
ts.WriteLine "<input type=" & chr(34) & "file" & chr(34) & "></input>"
ts.WriteLine "<input type=" & chr(34) & "button" & chr(34) & " id=" & chr(34) & "but" & chr(34) & " value=" & chr(34) & "OK" & chr(34) & "></input>"
ts.WriteLine "<br>"
ts.WriteLine "<input type=" & chr(34) & "button" & chr(34) & " id=" & chr(34) & "butc" & chr(34) & " value=" & chr(34) & "CANCEL" & chr(34) & "></input>"
ts.WriteLine "<br> Browse for file, then click OK."
ts.WriteLine "</form>"
ts.WriteLine "</div>"
ts.WriteLine "</body></html>"
ts.Close
Set ts = Nothing
On Error Resume Next
Set IE = Wscript.CreateObject("InternetExplorer.Application" )
IE.Navigate "file:///" & Ftemp
IE.AddressBar = false
IE.menubar = false
IE.ToolBar = false
IE.width = 400
IE.height = 250
IE.resizable = true
IE.visible = true
Do While IE.visible = True
spath = IE.StatusText
If fso.FileExists(spath) = true or spath = "cancel" or IE.visible = false Then
Exit Do
End If
wscript.sleep 500
Loop
IE.visible = False
IE.Quit
Set IE = Nothing
If fso.FileExists(spath) = True Then
GetPath = spath
Else
GetPath = ""
End If
End Function
End Class
' ==================================================
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, f_in, f_out
Dim i
' 1. Select the file that should be changed
Dim select_file_win, file_in, file_out
Set select_file_win = New SelectFile
file_in = select_file_win.Browse
file_out = "aaaa.tmp"
If (file_in <> "" ) Then
file_out = file_in & "_tmp"
End If
Set select_file_win = nothing
' 2. Replace diacritics
Set fso = CreateObject("Scripting.FileSystemObject" )
Set f_in = fso.OpenTextFile(file_in, ForReading)
Set f_out = fso.OpenTextFile(file_out, ForWriting, true)
Do Until f_in.AtEndOfStream
text_line = f_in.ReadLine
new_text_line = ""
For i = 1 To Len(text_line)
c = Mid(text_line, i, 1)
If (c = "ü" ) Then c = "ü"
If (c = "é" ) Then c = "&ecute;"
If (c = "â" ) Then c = "â"
If (c = "ä" ) Then c = "ä"
If (c = "à" ) Then c = "à"
If (c = "ç" ) Then c = "ç"
If (c = "ê" ) Then c = "ê"
If (c = "ë" ) Then c = "ë"
If (c = "è" ) Then c = "è"
If (c = "ï" ) Then c = "ï"
If (c = "î" ) Then c = "î"
If (c = "ô" ) Then c = "ô"
If (c = "ö" ) Then c = "ö"
If (c = "û" ) Then c = "û"
If (c = "ù" ) Then c = "ù"
new_text_line = new_text_line & c
Next
f_out.WriteLine new_text_line
Loop
f_in.Close
f_out.Close
fso.DeleteFile file_in, true
fso.MoveFile file_out, file_in |
