Find the current user language - vba

How can I tell the current user language in a vba program?
I need this to show a form in an appropriate language.

My initial code (utilising this vbforum code) assumed that Windows and Excel share a common language - likely but not bulletproof.
updated
The revised code:
Returns the Locale ID (LCID).
Looks up the LCID from this msft link.
Parses the LCID using a regexp to get the language.
Sample output on my machine below
The code will let the user know if there are any errors in accessing the LCID website, or in parsing the country name.
Sub GetXlLang()
Dim lngCode As Long
lngCode = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
MsgBox "Code is: " & lngCode & vbNewLine & GetTxt(lngCode)
End Sub
Function GetTxt(ByVal lngCode) As String
Dim objXmlHTTP As Object
Dim objRegex As Object
Dim objRegMC As Object
Dim strResponse As String
Dim strSite As String
Set objXmlHTTP = CreateObject("MSXML2.XMLHTTP")
strSite = "http://msdn.microsoft.com/en-us/goglobal/bb964664"
On Error GoTo ErrHandler
With objXmlHTTP
.Open "GET", strSite, False
.Send
If .Status = 200 Then strResponse = .ResponseText
End With
On Error GoTo 0
strResponse = Replace(strResponse, "</td><td>", vbNullString)
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Pattern = "><td>([a-zA-Z- ]+)[A-Fa-f0-9]{4}" & lngCode
If .Test(strResponse) Then
Set objRegMC = .Execute(strResponse)
GetTxt = objRegMC(0).submatches(0)
Else
GetTxt = "Value not found from " & strSite
End If
End With
Set objRegex = Nothing
Set objXmlHTTP = Nothing
Exit Function
ErrHandler:
If Not objXmlHTTP Is Nothing Then Set objXmlHTTP = Nothing
GetTxt = strSite & " unable to be accessed"
End Function

dim lang_code as long
lang_code = Application.LanguageSettings.LanguageID(msoLanguageIDUI)

This is another variation of the code posted by brettdj
Sub Test_GetLocale_UDF()
Dim lngCode As Long
lngCode = Application.LanguageSettings.LanguageID(msoLanguageIDUI)
MsgBox "Code Is: " & lngCode & vbNewLine & GetLocale(lngCode)
End Sub
Function GetLocale(ByVal lngCode) As String
Dim html As Object
Dim http As Object
Dim htmlTable As Object
Dim htmlRow As Object
Dim htmlCell As Object
Dim url As String
Set html = CreateObject("htmlfile")
Set http = CreateObject("MSXML2.XMLHTTP")
url = "https://www.science.co.il/language/Locale-codes.php"
On Error GoTo ErrHandler
With http
.Open "GET", url, False
.send
If .Status = 200 Then html.body.innerHTML = .responseText
End With
On Error GoTo 0
Set htmlTable = html.getElementsByTagName("table")(0)
For Each htmlRow In htmlTable.getElementsByTagName("tr")
For Each htmlCell In htmlRow.Children
If htmlCell.innerText = CStr(lngCode) Then
GetLocale = htmlRow.getElementsByTagName("td")(0).innerText
Exit For
End If
Next htmlCell
Next htmlRow
If GetLocale = "" Then GetLocale = "Value Not Found From " & url
Exit Function
ErrHandler:
If Not http Is Nothing Then Set http = Nothing
GetLocale = url & " Unable To Be Accessed"
End Function

Select Case Application.International(xlApplicationInternational.xlCountryCode)
Case 1: Call MsgBox("English")
Case 33: Call MsgBox("French")
Case 49: Call MsgBox("German")
Case 81: Call MsgBox("Japanese")
End Select
Straight out of here: https://bettersolutions.com/vba/macros/region-language.htm
Relevant Documentation: https://learn.microsoft.com/en-us/office/vba/api/excel.xlapplicationinternational

VBA Application.LanguageSettings.LanguageID(msoLanguageIDUI) gets only Microsoft Office Access or Microsoft Excel User interface Language. But does not reflect the Windows System display language used for Windows Display, every thing as MsgBox() buttons etc.
If user changes his Windows Display language via Windows Control Panel, this Application level setting will not change. In which case, we can use this Kernel dll function to get the new LCID (Microsoft Language Code IDentifier, 1036=French, 1033=English, ...), with this code in a VBA Module:
Private Declare Function GetUserDefaultUILanguage Lib "kernel32.dll" () As Long
Public Function winGetUserDefaultUILanguage()
winGetUserDefaultUILanguage = GetUserDefaultUILanguage()
End Function
Then you can call the public function winGetUserDefaultUILanguage() every where in your VBA code to get Windows LCID.
The kernel dll function GetUserDefaultUILanguage() will reflect the changement via Windows Display Language ID.
For example, as I've French Windows display language, LCID=1036, my Office is also in French (LCID=1036),
VBA Debugger Console:
Now we switch to English Windows display language via Control Panel (LCID=1033 for English), but my Office language ID remains unchanged (LCID=1036):
VBA Debugger Console:
From LCID, you can further get Language Tag, Language Name from Microsoft API documents here or here.

Related

VBA Outlook attachments post to URL

I have created a macro for outlook which opens up a userform, asks a few questions to select from, and then there's a submit button to send the message and the userform data to a POST url (our ticketing system). I am stuck on the last part of attachments. I can see the attachments list and loop through the attachment item objects, but I don't know which object call to make to send the actual file data to the POST form... all i can see is file size, file name, etc.
Any ideas where i would get the file contents and mime type for adding them to the URL post action as a form var?
Public senderaddress As String
Public thisEmailContent As String
Public thisEmailTEXT As String
Public thisStaffMember As Integer
Public emailAttachments As String
Sub MacroName()
thisStaffMember = 1
Set objItem = GetCurrentItem()
senderaddress = objItem.SenderEmailAddress
thisEmailContent = objItem.HTMLBody
thisEmailTEXT = objItem.Body
emailAttachments = objItem.Attachments
UserformName.Show
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = _
objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = _
objApp.ActiveInspector.CurrentItem
Case Else
End Select
End Function
Then here's the last part of the Userform code where it actually sends the data to our ticket system when the Send Now button is clicked...
Public Function encodeURL(str As String)
Dim ScriptEngine As Object
Dim encoded As String
Set ScriptEngine = CreateObject("scriptcontrol")
ScriptEngine.Language = "JScript"
encoded = ScriptEngine.Run("encodeURIComponent", str)
encodeURL = encoded
End Function
Private Sub SendNow_Click()
Set sendReq = CreateObject("MSXML2.XMLHTTP")
With sendReq
.Open "POST", "https://ticketsystemurl.whatever/outlookinterface.php?action=openticket&fromEmail=" & encodeURL(senderaddress) & "&selectedCustomer=" & encodeURL(CustomerSelect.Value) & "&selectedContact=" & encodeURL(ContactSelect.Value), False
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
.Send ("notifyCustomer=" & NotifyCustomer.Value & "&staffID=" & thisStaffMember & "&emailContent=" & encodeURL(thisEmailContent) & "&emailTEXT=" & encodeURL(thisEmailTEXT) & "&appendTicket=" & AppendToTicket.Value & "&createNewTicket=" & CreateNewTicket.Value & "&selectedTicket=" & encodeURL(SelectTicket.Value) & "&attachments=" & encodeURL(emailAttachments))
End With
Unload Me
End Sub
so far that submits everything except i cant figure out how to populate the post var "attachments" with the actual attachment filedata. Is this even possible?
Outlook would not do that for you. You will need to save the attachment as a file (Attachment.SaveAsFile), the read the contents of that file (Scripting.FileSystemObject object?) to use it in your web request.

VBA Direction API - Invalid Request Only through Code

I'm from Brazil and sorry about my english but my error really driving me crazy!
I've already type a Code in VBA using this Directions API just for get the distance from A to B (in km).
Alright, I've talked to IT Security for allow my API Request and was permit and tested.
So today I set my macro to run perfectly and I discovered that my code return a INVALID_REQUEST, but more crazy about that is if I put the URL in the browser I get the response perfectly but when Excel try to run over coding, I get a INVALID_REQUEST from the XML return.
Look my code:
Function gglDirectionsResponse(ByVal strStartLocation, ByVal strEndLocation, ByRef strTravelTime, ByRef strDistance, ByRef strInstructions, Optional ByRef strError = "") As Boolean
On Error GoTo errorHandler
' Helper function to request and process XML generated by Google Maps.
Dim strURL As String
Dim objXMLHttp As Object
Dim objDOMDocument As Object
Dim nodeRoute As Object
Dim lngDistance As Long
Set objXMLHttp = CreateObject("MSXML2.XMLHTTP")
Set objDOMDocument = CreateObject("MSXML2.DOMDocument.6.0")
strStartLocation = Replace(strStartLocation, " ", "+")
strEndLocation = Replace(strEndLocation, " ", "+")
strURL = "https://maps.googleapis.com/maps/api/directions/xml" & _
"?origin=" & strStartLocation & _
"&destination=" & strEndLocation & _
"&key=MY_API_KEY" & _
"&sensor=false" & _
"&units=" & strUnits
'Send XML request
With objXMLHttp
.Open "GET", strURL, False
.setRequestHeader "Content-Type", "application/x-www-form-URLEncoded"
.send
objDOMDocument.LoadXML .responseText
End With
With objDOMDocument
If .SelectSingleNode("//status").Text = "OK" Then
'Get Distance
lngDistance = .SelectSingleNode("/DirectionsResponse/route/leg/distance/value").Text ' Retrieves distance in meters
Select Case strUnits
Case "imperial": strDistance = Round(lngDistance * 0.00062137, 1) 'Convert meters to miles
Case "metric": strDistance = Round(lngDistance / 1000, 1) 'Convert meters to miles
End Select
'Get Travel Time
strTravelTime = .SelectSingleNode("/DirectionsResponse/route/leg/duration/value").Text 'returns in seconds from google
strTravelTime = formatGoogleTime(strTravelTime) 'converts seconds to hh:mm
'Get Directions
For Each nodeRoute In .SelectSingleNode("//route/leg").ChildNodes
If nodeRoute.BaseName = "step" Then
strInstructions = strInstructions & nodeRoute.SelectSingleNode("html_instructions").Text & " - " & nodeRoute.SelectSingleNode("distance/text").Text & vbCrLf
End If
Next
strInstructions = CleanHTML(strInstructions) 'Removes MetaTag information from HTML result to convert to plain text.
Else
strError = .SelectSingleNode("//status").Text
GoTo errorHandler
End If
End With
gglDirectionsResponse = True
GoTo CleanExit
errorHandler:
If strError = "" Then strError = Err.Description
strDistance = -1
strTravelTime = "00:00"
strInstructions = ""
gglDirectionsResponse = False
CleanExit:
Set objDOMDocument = Nothing
Set objXMLHttp = Nothing
End Function
Function getGoogleDistance(ByVal strFrom, ByVal strTo) As String
'Returns the distance between strFrom and strTo
'where strFrom/To are address search terms recognisable by Google
'i.e. Postcode, address etc.
Dim strTravelTime As String
Dim strDistance As String
Dim strError As String
Dim strInstructions As String
If gglDirectionsResponse(strFrom, strTo, strTravelTime, strDistance, strInstructions, strError) Then
getGoogleDistance = strDistance
Else
getGoogleDistance = strError
End If
End Function
So, I just call the function gglDirectionsResponse sending, FROM and TO and the coding do the rest. As I said, I'd test and all works good, and now can't run. What I missing here guys?
The errorHandler is activate when the code try to run the specific line:
With objDOMDocument
If .SelectSingleNode("//status").Text = "OK" Then
Here return INVALID_REQUEST.
Look the URL after loaded:
https://maps.googleapis.com/maps/api/directions/xml?origin=Porto+Nacional-TO&destination=Silvanópolis-TO,+Brasil&key=MY_API_KEY&sensor=false&units=metric
Look the img from browser
browser img, from api url in the code
NOTE: I don't get macro or load or VBA code error, it's a errorHandler to validate the XML return, and the Return appear as invalid_request but browser load with success the same URL in the code.
Please please, somebody help me!
Try setting the request header to:
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT enter code here5.0)"
Don't know if it will work though..
As I commented in the answer before. The problem was found when I wrote the line:
.SelectSingleNode("/").text
*Obviously after .Send command.
this return for me that I send a invalid parameter that contain a non-utf-8 character.
So the code in XML "/" it's like the root structure, and with this, I could get the error_message to understand more correctly the error.
So as I said, I'm from Brazil and our cities have a lot of (', í,á,é,ó ...) so I'd test and get finally the correct status.
And now my problem is how to convert any character, but easily if we compare :D

VERY strange behavior on createobject("HTMLFILE")!

I don't understand why I'm getting this strange behavior!
When creating and assigning the htmlfile object the function gives back a blank object ("nothing") and when I am running the code line by line it just runs automatically even when I don't press F8 to run the next line...
It gives no error whatsoever!
Any ideas as to what might be happening?
Line where the strange behavior starts: Set htmlObj = CreateObject("HTMLFILE")
Public Function XMLHTTP_Request(Method As String, URL As String, Optional PostData As String, Optional StrCookie As String) As HTMLDocument
Dim oXMLHTTP As Object, htmlObj as object
Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
oXMLHTTP.Open Method, URL, False
oXMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
oXMLHTTP.setRequestHeader "Cookies", StrCookie
On Error GoTo ErrorHandler
oXMLHTTP.send (PostData)
On Error GoTo 0
While oXMLHTTP.ReadyState <> 4: DoEvents: Wend
While oXMLHTTP.Status <> 200: DoEvents: Wend
Set htmlObj = CreateObject("HTMLFILE")
htmlObj.body.innerHTML = oXMLHTTP.responseText
Set XMLHTTP_Request = htmlObj
End Function
Repeated calls to the function will cause multiple calls to the CreateObject function. The oXMLHTTP and htmlObj object vars could be made static or library references could be included and the variable declaration changed to Early Binding.
Early binding requires that the following non-default library references are added through the VBE's Tools ► References command.
Microsoft HTML Object Library
Microsoft Internet Controls
Microsoft XML 6.0 (your own version may vary slightly).
Module1 code sheet:
Option Explicit
Sub main()
Debug.Print Left(XMLHTTP_Request("http//example.com").body.innerText, 512)
End Sub
Public Function XMLHTTP_Request(URL As String, _
Optional Method As String = "POST", _
Optional PostData As String = "", _
Optional StrCookie As String = "") As HTMLDocument
Dim oXMLHTTP As New MSXML2.XMLHTTP60
Dim htmlObj As New HTMLDocument
oXMLHTTP.Open Method, URL, False
oXMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
oXMLHTTP.setRequestHeader "Cookies", StrCookie
oXMLHTTP.send PostData
If oXMLHTTP.Status <> 200 Then Exit Function
htmlObj.body.innerHTML = oXMLHTTP.responseText
Set XMLHTTP_Request = htmlObj
End Function
Running the main() sub procedure will output the first 512 characters of the web page's text to the Immediate window ([Ctrl]+G).

url checker VBA, when redirected, show redirected url

I'm quite new to EXCEL VBA's and I'm kinda stuck finding a way to create a MACRO that shows whether a url is still active (200 ok),
or may be redirected, and if so, I want to know to what URL. And when it's not working at all, then return the right code with the reason the URL isn't working.
So at the moment I have a script that actually works but it doesn't return the url to which an url is redirected to.
It only returns (200 OK) when an url is still active, or the url that the original url has been redirected to is still active. So I know which URLs are dead or are redirected to a dead URL.
But I want to take it a step futher.
As the URLs that I want to check are in the "A" column at the moment, and the results return in the "B" column, I want to see the URL to which I've been redirected in the C column, everytime there an URL has been redirected.
I did find some functions online that should do the job but for some reason I can't fit them in my SUB. Like I mentioned before, it's all quite new to me.
This is what I have at the moment:
Sub CheckHyperlinks()
Dim oColumn As Range
Set oColumn = GetColumn() '' replace this with code to get the relevant column
Dim oCell As Range
For Each oCell In oColumn.Cells
If oCell.Hyperlinks.Count > 0 Then
Dim oHyperlink As Hyperlink
Set oHyperlink = oCell.Hyperlinks(1) '' I assume only 1 hyperlink per cell
Dim strResult As String
strResult = GetResult(oHyperlink.Address)
oCell.Offset(0, 1).Value = strResult
End If
Next oCell
End Sub
Private Function GetResult(ByVal strUrl As String) As String
On Error GoTo ErrorHandler
Dim oHttp As New MSXML2.ServerXMLHTTP30
oHttp.Open "HEAD", strUrl, False
oHttp.send
GetResult = oHttp.Status & " " & oHttp.statusText
Exit Function
ErrorHandler:
GetResult = "Error: " & Err.Description
End Function
I hope one of you could help me out.
Its better to use the WinHttp COM object. That will let you "disable" redirect handling. Read this forum post.
The component you need to reference is Microsoft WinHTTP Services.
Public Function GetResult(ByVal strUrl As String, Optional ByRef isRedirect As Boolean, Optional ByRef target As String) As String
Dim oHttp As New WinHttp.WinHttpRequest
oHttp.Option(WinHttpRequestOption_EnableRedirects) = False
oHttp.Open "HEAD", strUrl, False
oHttp.send
GetResult = oHttp.Status & " " & oHttp.statusText
If oHttp.Status = 301 Or oHttp.Status = 302 Then
isRedirect = True
target = oHttp.getResponseHeader("Location")
Else
isRedirect = False
target = Nothing
End If
End Function

html file save restore from vba

I want to re-use a snapshot of a web response for testing an app that needs to do some web-scraping. What I tried to do is just save the response (from Chrome) and reload the the string from the file:
doc.body.innerHtml = StringFromFile
This doesn't work though, although it looks like good html. By not work, I mean data that is in tag "Table"(6) when going through the web is not found. Is there a better way to load the html doc?
The code below is an attempt to both save an existing doc to file and then reuse it. Its worthless but maybe it will help someone set me straight on this.
Cheers
Private Function GetEWhipersTestHtmlDoc() As HTMLDocument
Dim doc As HTMLDocument
Set doc = New HTMLDocument
Dim sText As String
sText = GetStringFromFile(GetFileName("UnconfirmedRelease"))
doc.body.innerHTML = sText
Set GetEWhipersTestHtmlDoc = doc
End Function
Private Function GetFileName(testName As String) As String
GetFileName = ThisWorkbook.path & Application.PathSeparator & _
"Earnings Whispers Test Scenarios" & Application.PathSeparator & testName & ".txt"
Debug.Assert Dir(GetFileName) <> ""
End Function
Private Function SaveHtmlStringToFile(testName As String, sInnerHtml As String) As String
Dim fso As Object
Dim oFile As Object
Dim sPath As String
Set fso = CreateObject("Scripting.FileSystemObject")
sPath = GetFileName(testName)
Set oFile = fso.CreateTextFile(sPath)
oFile.WriteLine sInnerHtml
oFile.Close
End Function
** UPDATE **
Saving doc.body.outerHtml seems to be an upgrade from what I had. The text can turned into the web page using 'code snippet'. I am getting an error when trying to put the saved text back into a new document though:
Err 600, Application-defined or object-defined error
Private Function GetEWhipersTestHtmlDoc() As HTMLDocument
Dim doc As New HTMLDocument
Dim sText As String
' Error Handling
On Error GoTo ErrHandler
sText = GetStringFromFile(GetFileName("UnconfirmedRelease"))
doc.body.outerHTML = sText <---- ** ERROR is Here
Set GetEWhipersTestHtmlDoc = doc
Exit Function
ErrHandler:
Select Case DspErrMsg("blah")
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace
Case Is = vbRetry: Resume 'Try again
Case Is = vbIgnore: 'End routine
End Select
End Function
final update
thanks to Tim and David I got something usable. The only hair of Tim's final solution is that HtmlDocument.Write is restricted as far as VBA is concerned. So to 'fool' the compiler, I needed to declare it as an Object:
Dim doc As Object <--- don't let vba know we want to write to HTMLDoc
Set doc = New HTMLDocument
Dim sText As String
sText = GetStringFromFile(GetFileName("UnconfirmedRelease"))
doc.Open
doc.Write sText <-- no intellisense, but compiles...and works!
doc.Close