Hi,
I was creating a new menu and I wanted to have a decent name and translations.
So I took the lang.xls file and added my menu.
After cliquing "Generate", it said that the files were created at D:\documents. Unfortunately, my "documents" folder is full of crap and I was not able do find the files easily.
I tried to make the "Generate" procedure a bit more user friendly :
Option Explicit
Dim nbFiles As Integer
Dim nbVars As Integer
Sub generateLangFiles()
On Error GoTo 0
'Init
Dim col As Integer
col = 3 'begins with "default"
nbFiles = 0
'Sort before saving
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Check for redundant info
Call checkDupplicate
'Saving
While Cells(1, col) <> ""
Call writeFile(Cells(1, col), col)
nbFiles = nbFiles + 1
col = col + 1
Wend
'Completed
MsgBox "Completed" & _
vbCrLf & " Number of files generated : " & nbFiles & _
vbCrLf & " Number of lignes per file : " & nbVars & _
vbCrLf & " Saved in " & CurDir & "\lang\"
End Sub
Sub writeFile(lang As String, col As Integer)
Dim lig As Integer
Dim filename As String
Dim val As String
Dim ligne As String
If Dir("lang\", vbDirectory) = "" Then
MkDir "lang\"
End If
If lang = "default" Then
filename = "lang\lang.js"
Else
filename = "lang\" & lang & "\lang.js"
If Dir("lang\" & lang, vbDirectory) = "" Then
MkDir "lang\" & lang
End If
End If
If Dir(filename) <> "" Then
Kill filename
End If
Open filename For Output As #1
'Dim fsT
'Set fsT = CreateObject("ADODB.Stream")
'fsT.Type = 2
'fsT.Charset = "utf-8"
'fsT.Open
Print #1, "{"
'fsT.writeText "{"
lig = 2
While Cells(lig, 1) <> ""
val = Cells(lig, col)
If val = "" Then
val = "[" & Cells(lig, 1) & "]"
End If
val = Encode_UTF8(val)
ligne = Cells(lig, 1) & ": """ & val & ""","
'MsgBox ligne
Print #1, ligne
'fsT.writeText ligne
lig = lig + 1
Wend
nbVars = lig - 2
Print #1, "currentLocaleOfFile: """ & lang & """"
'fsT.writeText "currentLocaleOfFile: """ & lang & """"
Print #1, "}"
'fsT.writeText "}"
Close #1
'fsT.SaveToFile filename, 2
End Sub
Public Function Encode_UTF8(astr)
Dim c
Dim n
Dim utftext
utftext = ""
n = 1
Do While n <= Len(astr)
c = AscW(Mid(astr, n, 1))
If c = 34 Or c = 39 Then ' substiitute ' and " with '
utftext = utftext + "'"
ElseIf c < 128 Then
utftext = utftext + Chr(c)
ElseIf ((c >= 128) And (c < 2048)) Then
utftext = utftext + Chr(((c \ 64) Or 192))
utftext = utftext + Chr(((c And 63) Or 128))
ElseIf ((c >= 2048) And (c < 65536)) Then
utftext = utftext + Chr(((c \ 4096) Or 224))
utftext = utftext + Chr((((c \ 64) And 63) Or 128))
utftext = utftext + Chr(((c And 63) Or 128))
Else ' c >= 65536
utftext = utftext + Chr(((c \ 262144) Or 240))
utftext = utftext + Chr(((((c \ 4096) And 63)) Or 128))
utftext = utftext + Chr((((c \ 64) And 63) Or 128))
utftext = utftext + Chr(((c And 63) Or 128))
End If
n = n + 1
Loop
Encode_UTF8 = utftext
End Function
Sub checkDupplicate()
Dim lig As Integer
Dim val As String
Dim stVal As String
Dim lstErr As String
stVal = ""
lstErr = ""
lig = 2
While Cells(lig, 1) <> ""
val = Cells(lig, 1)
If val = stVal Then
lstErr = lstErr & vbCrLf & " => " & val
End If
stVal = val
lig = lig + 1
Wend
If lstErr <> "" Then
MsgBox "Dupplicate values for following data :" & lstErr & vbCrLf & vbCrLf & "Correct and retry."
End
End If
End Sub
It creates a additional "lang" folder witch contains the lang.js and other language folders. Its location is still "D:\documents" (I guess it would be different on english system..).
I am sure this could be done a lot better than I did, but I do not have the time to..
Edit : By the way, it seems that lang.xls is not up to date, some translations vanished and now appear as [something].