Zurück zur Homepage

Ländereinstellungen

Sucht man im Internet nach Code, um die Ländereinstellungen mit VB zu ändern, so wird man recht schnell fündig. Die API Funktion SetLocaleInfo macht so etwas. Für jede Einstellung, die geändert werden soll, wie beispielsweise das Dezimaltrennzeichen, gibt es Konstanten. Diese und die geänderte Einstellung werden dann an die Funktion übergeben. Nach der Änderung muss noch eine Message an alle Fenster gesendet werden, die Anwendungen darüber informiert, dass bestimmte Einstellungen verändert wurden. Dazu kann man SendMessage mit der Fensternachricht WM_SETTINGCHANGE benutzen. Das klappt vorzüglich und man kann das im Windowsdialog intl.cpl sofort nachprüfen
(Shell "RUNDLL32.EXE shell32.dll,Control_RunDLL intl.cpl,,")
Die Sache hat nur einen gravierenden Haken.
EXCEL bekommt von der Änderung nichts mit!
Man kann machen, was man will, wenn aus einer Excel-Anwendung die Einstellung geändert wird, bekommt diese Anwendung nichts mit. Excel scheint mit der Codeausführung so beschäftigt zu sein, dass die Fensternachrichten schlichtweg ignoriert werden. Andere Anwendungen wie Word, oder sogar Excel, das in einem anderen Prozessraum läuft, schnallen das sofort. Ich habe die Nachrichten abgehört und festgestellt, dass die eigene Anwendung die Nachricht von der Änderung zwar bekommt, aber nicht reagiert.
Was also tun? Ich habe über Automatisierung Word gestartet und dort den Code ausgeführt, das funzt auch nicht. Ich habe den Windows Scripting Host benutzt und die dort vorhandene Funktion zur Manipulation benutzt, auch das klappt nicht. Ein Manipulieren der Registry mit WSH bringt auch nichts. Der Script verändert zwar die Einstellungen, aber Excel bekommt nichts mit. Erst ein Neustart der Excel Anwendung bringt Abhilfe, das ist aber keine Lösung. Dagegen Word oder Excel gestartet, und den Code dort ausgeführt, ändert die zu manipulierende Excel-Mappe sofort. Man kann sich jetzt zwei Mappen erstellen, die den Code für die Ländereinstellung Deutsch oder Englisch enthalten. Diese kann man mit Shell aufrufen und man hat die gewünschte Funktionalität. Es sind aber immer Vorbereitungen nötig.
Ich habe es hier anders gemacht. Sozusagen von Hinten durchs Auge gestochen. Ein auf dem Rechner vorhandener Windows Scripting Host ist aber Voraussetzung. Es ist aber nicht unbedingt nötig, dass die Erweiterung .vbs mit wscript.exe verknüpft ist. Die meisten Firmenrechner verknüpfen sowieso defaultmäßig mit Notepad. Der hier vorliegende Code macht nun folgendes:
Es wird eine .vbs Datei erzeugt, diese wird im Temp-Verzeichnis abgelegt und ausführt. In der .vbs Datei ist Code, der eine neue Excel Instanz erzeugt, eine neue Mappe anlegt und ein Modul einfügt. Dann wird in dieses Modul via WSH der Code zum Ändern der Ländereinstellungen eingefügt.
Unter XL2002 muss unter
Extras/Optionen/Sicherheit/Schaltfläche "Makrosicherheit"
das Kontrollfeld:
"Zugriff auf Visual Pasic Projekte vertrauen"
aktiviert sein.
Ist das geschehen, wird der Code in der Excel-Datei ausgeführt. Leider gibt es beim Schließen der Mappe immer wieder Probleme. Deshalb wird die ganze Sache noch etwas komplexer. Nachdem Excel die Ländereinstellung geändert hat, wird die Methode OnTime benutzt, um zeitversetzt Code zum Beenden von Excel auszuführen. In der Zwischenzeit hat der Scripting Host Zeit, den Code in der .vbs-Datei fertig abzuarbeiten und es knallt nicht mehr.
Ein kleines selbstgeschriebenes Delphi - Programm zu benutzen wäre aber vermutlich einfacher und eleganter. ;-)

Beispieldatei LaendercodeAendern.xls 16 kB

Private Declare Function ShellExecute Lib "shell32.dll" _
    Alias "ShellExecuteA" (ByVal Fensterzugriffsnummer As Long, _
    ByVal lpOperation_wie_Open_oder_Print As String, _
    ByVal lpDateiname_incl_Pfad As String, _
    ByVal lpZusätzliche_Startparameter As String, _
    ByVal lpArbeitsverzeichnis As String, _
    ByVal nGewünschte_Fenstergröße_der_Anwendung As Long) _
    As Long
Private Declare Function GetTempPath Lib "kernel32" Alias _
    "GetTempPathA" (ByVal nBufferLength As Long, _
    ByVal lpBuffer As String) As Long
Private Const SW_NORMAL = 1


Public Sub SpracheinstellungEn()
    TrennzeichenÄndern ".", ","
End Sub


Public Sub SpracheinstellungDe()
    TrennzeichenÄndern ",", "."
End Sub

Private Sub TrennzeichenÄndern(Dezimaltrennzeichen As String,  _
      Tausendertrennzeichen As String)
Dim ScriptText As String, Datei As String
Dim Temppfad As String, Länge As Long
On Error Resume Next
Länge = 100
Temppfad = String(Länge + 1, 0)
'Temppfad ermitteln
Länge = GetTempPath(Länge, Temppfad)
Temppfad = Left(Temppfad, Länge)
Datei = Temppfad & "MyLocaleScript.vbs"
'Scripttext erzeugen
ScriptText = ScriptText & "Dim Xl, Wb, VBEObj, mdl,Line"
ScriptText = ScriptText & vbCrLf & _
"Set Xl=CreateObject(""Excel.Application"")"
'ScriptText = ScriptText & vbCrLf & _
"xl.Visible=true"
ScriptText = ScriptText & vbCrLf & _
"Set Wb=xl.Workbooks.Add"
ScriptText = ScriptText & vbCrLf & _
"Set VBEObj = xl.VBE.ActiveVBProject"
ScriptText = ScriptText & vbCrLf & _
"Set mdl = VBEObj.VBComponents.Add(1)"
ScriptText = ScriptText & vbCrLf & _
"mdl.name=""Test"""
'Folgendes wird dann ins Excel-Modul eingefügt
ScriptText = ScriptText & vbCrLf &  _
"Line=""Private Declare Function SetLocaleInfo Lib """"kernel32"""" Alias """
ScriptText = ScriptText & vbCrLf &  _
"Line=Line & """"""SetLocaleInfoA"""" (ByVal Locale As Long, ByVal LCType As Long, ByVal """
ScriptText = ScriptText & vbCrLf & _
"Line=Line & ""lpLCData As string) As Long"""
ScriptText = ScriptText & vbCrLf & "mdl.CodeModule.InsertLines 2, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Private Declare Function SendMessage Lib """"user32"""" """
ScriptText = ScriptText & vbCrLf & _
"Line=Line & ""Alias """"SendMessageA"""" (ByVal hwnd As Long, """
ScriptText = ScriptText & vbCrLf & _
"Line=Line & ""ByVal wMsg As Long, ByVal wParam As Long, """
ScriptText = ScriptText & vbCrLf & _
"Line=Line & ""ByVal lParam As string) As Long"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 3, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Private Declare Function GetSystemDefaultLCID Lib """"kernel32"""" () As Long"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 4, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Private Const LOCALE_SDECIMAL = &HE"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 5, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Private Const LOCALE_USER_DEFAULT = &H400"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 6, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Private Const LOCALE_STHOUSAND = &HF"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 7, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Private Const WM_SETTINGCHANGE = &H1A"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 8, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Private Const HWND_BROADCAST = &HFFFF&"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 9, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Public Sub Aendern()"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 10, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Dim LCID As Long"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 11, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""On Error Resume Next"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 12, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""LCID = GetSystemDefaultLCID()"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 13, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""SetLocaleInfo LCID, LOCALE_SDECIMAL, """"" & Dezimaltrennzeichen & """"""""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 14, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""SetLocaleInfo LCID, LOCALE_STHOUSAND, """"" & Tausendertrennzeichen & """"""""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 15, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""SendMessage HWND_BROADCAST, WM_SETTINGCHANGE, 0&, ByVal 0&"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 16, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Workbooks(1).saved=True"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 17, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""Application.OnTime Now + TimeSerial(0, 0, 1), """"Aus"""""""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 18, Line"
ScriptText = ScriptText & vbCrLf & _
"Line=""End Sub"""
ScriptText = ScriptText & vbCrLf & _
"mdl.CodeModule.InsertLines 19, Line"

ScriptText = ScriptText & vbCrLf & "Line=""Private sub Aus()"""
ScriptText = ScriptText & vbCrLf & "mdl.CodeModule.InsertLines 20, Line"
ScriptText = ScriptText & vbCrLf & "Line=""Application.quit"""
ScriptText = ScriptText & vbCrLf & "mdl.CodeModule.InsertLines 21, Line"
ScriptText = ScriptText & vbCrLf & "Line=""End Sub"""
ScriptText = ScriptText & vbCrLf & "mdl.CodeModule.InsertLines 22, Line"

ScriptText = ScriptText & vbCrLf & "xl.Run ""Aendern"""
ScriptText = ScriptText & vbCrLf & "set wb=nothing"
ScriptText = ScriptText & vbCrLf & "set xl=nothing"
'vbs - Datei erzeugen
If Dir(Datei) <> "" Then Kill Datei
Open Datei For Binary As #1
    Put #1, , ScriptText
Close
'Ausführen
If Shell("wscript.exe """ & Datei & """") = 0 Then
    ShellExecute 0&, "Open", Datei, vbNullString, vbNullString, SW_NORMAL
End If
End Sub

Erzeugter Scriptcode  (MyLocaleScript.vbs)

Dim Xl, Wb, VBEObj, mdl,Line
Set Xl=CreateObject("Excel.Application")
Set Wb=xl.Workbooks.Add
Set VBEObj = xl.VBE.ActiveVBProject
Set mdl = VBEObj.VBComponents.Add(1)
mdl.name="Test"
Line="Private Declare Function SetLocaleInfo Lib ""kernel32"" Alias "
Line=Line & """SetLocaleInfoA"" (ByVal Locale As Long, ByVal LCType As Long, ByVal "
Line=Line & "lpLCData As string) As Long"
mdl.CodeModule.InsertLines 2, Line
Line="Private Declare Function SendMessage Lib ""user32"" "
Line=Line & "Alias ""SendMessageA"" (ByVal hwnd As Long, "
Line=Line & "ByVal wMsg As Long, ByVal wParam As Long, "
Line=Line & "ByVal lParam As string) As Long"
mdl.CodeModule.InsertLines 3, Line
Line="Private Declare Function GetSystemDefaultLCID Lib ""kernel32"" () As Long"
mdl.CodeModule.InsertLines 4, Line

Line="Private Const LOCALE_SDECIMAL = &HE"
mdl.CodeModule.InsertLines 5, Line
Line="Private Const LOCALE_USER_DEFAULT = &H400"
mdl.CodeModule.InsertLines 6, Line
Line="Private Const LOCALE_STHOUSAND = &HF"
mdl.CodeModule.InsertLines 7, Line
Line="Private Const WM_SETTINGCHANGE = &H1A"
mdl.CodeModule.InsertLines 8, Line
Line="Private Const HWND_BROADCAST = &HFFFF&"
mdl.CodeModule.InsertLines 9, Line
Line="Public Sub Aendern()"
mdl.CodeModule.InsertLines 10, Line
Line="Dim LCID As Long"
mdl.CodeModule.InsertLines 11, Line
Line="On Error Resume Next"
mdl.CodeModule.InsertLines 12, Line
Line="LCID = GetSystemDefaultLCID()"
mdl.CodeModule.InsertLines 13, Line
Line="SetLocaleInfo LCID, LOCALE_SDECIMAL, "","""
mdl.CodeModule.InsertLines 14, Line
Line="SetLocaleInfo LCID, LOCALE_STHOUSAND, ""."""
mdl.CodeModule.InsertLines 15, Line
Line="SendMessage HWND_BROADCAST, WM_SETTINGCHANGE, 0&, ByVal 0&"
mdl.CodeModule.InsertLines 16, Line
Line="Workbooks(1).saved=True"
mdl.CodeModule.InsertLines 17, Line
Line="Application.OnTime Now + TimeSerial(0, 0, 1), ""Aus"""
mdl.CodeModule.InsertLines 18, Line
Line="End Sub"
mdl.CodeModule.InsertLines 19, Line
Line="Private sub Aus()"
mdl.CodeModule.InsertLines 20, Line
Line="Application.quit"
mdl.CodeModule.InsertLines 21, Line
Line="End Sub"
mdl.CodeModule.InsertLines 22, Line
xl.Run "Aendern"
set wb=nothing
set xl=nothing

 

Erzeugter Excelcode

Option Explicit
Private Declare Function SetLocaleInfo Lib "kernel32" _
    Alias "SetLocaleInfoA" (ByVal Locale As Long,  _
    ByVal LCType As Long, ByVal lpLCData As String) As Long
Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    ByVal lParam As String) As Long
Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
Private Const LOCALE_SDECIMAL = &HE
Private Const LOCALE_USER_DEFAULT = &H400
Private Const LOCALE_STHOUSAND = &HF
Private Const WM_SETTINGCHANGE = &H1A
Private Const HWND_BROADCAST = &HFFFF&


Public Sub Aendern()
Dim LCID As Long
On Error Resume Next
LCID = GetSystemDefaultLCID()
SetLocaleInfo LCID, LOCALE_SDECIMAL, ","
SetLocaleInfo LCID, LOCALE_STHOUSAND, "."
SendMessage HWND_BROADCAST, WM_SETTINGCHANGE, 0&, ByVal 0&
Workbooks(1).Saved = True
Application.OnTime Now + TimeSerial(0, 0, 1), "Aus"
End Sub


Private Sub Aus()
Application.Quit
End Sub