<% '================================================== ' Microsoft Server Appliance ' ' Sets language based on browser settings ' ' Copyright (c) Microsoft Corporation. All rights reserved. '================================================== %> <% Dim objLocalMgr Dim iBrowserLangID Dim arrLangDisplayNames,arrLangISONames, arrLangCharSets Dim arrLangCodePages, arrLangIDs Const strLANGIDName = "LANGID" Const ConstDword = 1 on error resume next set objLocalMgr = Server.CreateObject("ServerAppliance.LocalizationManager") If Err.number <> 0 Then If ( Err.number = &H800401F3 ) Then Response.Write("Unable to locate a software component on the Server Appliance. ") Response.Write("The Server Appliance core software components do not appear to be installed correctly.") Else Response.Write("Server.CreateObject(ServerAppliance.LocalizationManager) failed with error code: " + CStr(Hex(Err.Number)) + " " + Err.Description) End If Call SA_TraceOut("SH_TASK", "Server.CreateObject(ServerAppliance.LocalizationManager) failed with error code: " + CStr(Hex(Err.Number)) ) Response.End End If ' ' set the locale EVERYTIME ' This can cause an error if the LCID is not available, in that case we don't touch the locale Call SetLCID() on error goto 0 If Not objLocalMgr.fAutoConfigDone Then Dim strBrowserLang Dim iCurLang, iCurLangID on error resume next iCurLang = objLocalMgr.GetLanguages(arrLangDisplayNames, arrLangISONames, arrLangCharSets, arrLangCodePages, arrLangIDs) iCurLangID = arrLangIDs(iCurLang) 'Err.Clear 'Here getting -2147467259 Error strBrowserLang = getBrowserLanguage() iBrowserLangID = isSupportedLanguage(strBrowserLang) If iBrowserLangID <> 0 Then 'Browser Language and Current Language "LANGID" might be diiferent.. Call ExecuteTask1(Hex(iBrowserLangID), Hex(iCurLangID)) End if If SA_IsDebugEnabled() Then on error goto 0 End If End if ' ' set the code page EVERYTIME ' 'Session.CodePage = objLocalMgr.CurrentCodePage ' Hard coded for Unicode (UTF-8) codepage Session.CodePage = 65001 Set objLocalMgr = Nothing '---------------------------------------------------------------------------- ' ' Function : getBroswerLanguage ' ' Synopsis : Serves in getting Browser Default Language ID ' ' Arguments: None ' ' Returns : ISO 693 name ' '---------------------------------------------------------------------------- Function getBrowserLanguage Err.Clear Dim strAcceptLanguage Dim iPos strAcceptLanguage = Request.ServerVariables("HTTP_ACCEPT_LANGUAGE") iPos = InStr(1, strAcceptLanguage, ",") If iPos > 0 Then strAcceptLanguage = Left(strAcceptLanguage, iPos - 1) End If getBrowserLanguage = LCase(strAcceptLanguage) End Function '---------------------------------------------------------------------------- ' ' Function : isSupportedLanguage ' ' Synopsis : checks whether the given language is supported by framework, ' if yes returns the lang id else returns 0 ' ' Arguments: strBrowserLang(IN) - ISO Name of Language ' ' Returns : Language ID ' '---------------------------------------------------------------------------- Function isSupportedLanguage(strBrowserLang) Err.Clear Dim name Dim iIndex Dim ISOName Dim iLangID iIndex=0 iLangID = 0 ' ' Chinese Hong Kong or Macau selects Chinese traditional ' If ("zh-hk" = strBrowserLang) Or ("zh-mo" = strBrowserLang) Then strBrowserLang = "zh-tw" End If for each ISOName in arrLangISONames If ISOName = strBrowserLang Then iLangID = arrLangIDs(iIndex) Exit for End if iIndex = iIndex + 1 next ' If we did not get a match for the full name try the short name If ((0 = iLangID) AND (Len(strBrowserLang) > 2)) Then iIndex=0 strBrowserLang = Left(strBrowserLang, 2) for each ISOName in arrLangISONames If ISOName = strBrowserLang Then iLangID = arrLangIDs(iIndex) Exit for End if iIndex = iIndex + 1 next End If isSupportedLanguage = iLangID End Function '---------------------------------------------------------------------------- ' ' Function : ExecuteTask1 ' ' Synopsis : Executes the ChangeLanguage task ' ' Arguments: strLangID(IN) - The LANGID as a string ' strCurrentLangID(IN) - The current LANGID as a string ' ' Returns : true/false for success/failure ' '---------------------------------------------------------------------------- Function ExecuteTask1(ByVal strLangID, ByVal strCurrentLangID) Err.Clear on error resume next Dim objTaskContext,objAS,rc Dim objSL Dim sReturnURL Dim sURL Const strMethodName = "ChangeLanguage" Set objTaskContext = CreateObject("Taskctx.TaskContext") If Err.Number <> 0 Then ExecuteTask1 = FALSE Exit Function End If Set objAS = CreateObject("Appsrvcs.ApplianceServices") If Err.Number <> 0 Then ExecuteTask1 = FALSE Exit Function End If objTaskContext.SetParameter "Method Name", strMethodName objTaskContext.SetParameter "LanguageID", strLANGID objTaskContext.SetParameter "AutoConfig", "y" If Err.Number <> 0 Then ExecuteTask1 = FALSE Exit Function End If objAS.Initialize() If Err.Number <> 0 Then ExecuteTask1 = FALSE Exit Function End If rc = objAS.ExecuteTask("ChangeLanguage", objTaskContext) If Err.Number <> 0 Then ExecuteTask1 = FALSE Exit Function End If 'objAS.Shutdown 'If Err.Number <> 0 Then ' If Err.Number <> 438 Then 'error 438 shutdown is not supported.. ' ExecuteTask1 = FALSE ' Exit Function ' End if 'End If Err.Clear Set objTaskContext = Nothing If (strLangID <> strCurrentLangID) Then Set objSL = Server.CreateObject("SetSystemLocale.SetSystemLocale") If Err.Number <> 0 Then 'SA_TraceOut "autoconfiglang.asp", "Create SetSystemLocale.SetSystemLocale failed: " + CStr(Hex(Err.Number)) ExecuteTask1 = FALSE objAS.Shutdown Set objAS = Nothing Exit Function End If objSL.SetLocale strLangID If ( Err.Number <> 0 ) Then 'SA_TraceOut "autoconfiglang.asp", "objSL.SetLocale failed" + CStr(Hex(Err.Number)) ExecuteTask1 = FALSE objAS.Shutdown Set objAS = Nothing Exit Function End If Set objSL = Nothing Call RaiseLangChangeAlert(objAS) End If objAS.Shutdown Set objAS = Nothing ExecuteTask1 = TRUE End Function Private Function RaiseLangChangeAlert(ByRef oAppServices) Err.Clear on error resume next Const SA_ALERT_CLASS = "Microsoft_SA_Resource" Const SA_ALERT_DURATION_ETERNAL = 2147483647 Const SA_ALERT_TYPE_WARNING = 0 Const SA_ALERT_TYPE_FAILURE = 1 Const SA_ALERT_TYPE_INFORMATION = 2 Const SA_ALERT_NORMAL = 0 Const SA_ALERT_SINGLETON = 1 Const AUTOLANGCONFIG_LOG = "AutoLangConfig" Const AUTOLANGCONFIG_ALERT_RestartRequired = 1 Dim rawData Dim nullRepStrings ' ' Raise Alert ' Call oAppServices.RaiseAlertEx(SA_ALERT_TYPE_WARNING, _ AUTOLANGCONFIG_ALERT_RestartRequired, _ AUTOLANGCONFIG_LOG, _ SA_ALERT_CLASS, _ SA_ALERT_DURATION_ETERNAL, _ nullRepStrings, _ rawData, _ SA_ALERT_SINGLETON) End Function %>