Convert user entered measurement string to points

[neilt17]

In the PowerPoint format shape box, users can enter measurements followed by a unit - e.g. "cm", "mm", "in", or not enter a unit - in which case the default measurement unit for the system is used (e.g. cm).

I would like to create an input box which accepts measurements in the same way. I've not been able to find a function that could handle the resulting string in PowerPoint VBA - Application.ConvertResult for VBA in Microsoft Visio looks like it could do the job - but that's not in PowerPoint. I could of course use string functions to detect any measurement unit a user has entered: the problem with that however is that I don't know what all the valid measurement abbreviations are for PowerPoint, and this most probably won't work for PowerPoint offered in different languages.

Any ideas?

[albino_pygmy]

Sub Button_Click()Dim stringinput, unit As String
Dim measurement As Double
Dim lpos As Long


'Stores your input into stringinput variable
stringinput = Slide1.TextBox1.Value


'This code finds the position where the space between your number and measurement unit is. It will not work without a space.
lpos = CDbl(InStr(1, stringinput, " "))


'This line takes just only the number out of your string, for example "45 cm"
measurement = Left(stringinput, lpos - 1)


'This line takes the last two characters of your input and stores it as your unit
unit = Right(stringinput, 2)


'Now to do your conversions. The default unit is points. This is one example for using inches.
If UCase(unit) = "IN" Then measurement = measurement * 0.0138889


'And then you can do what you want with your measurement.
End Sub

[John Wilson]

This would work in most cases


Sub getMeasurement() Dim strIn As String
strIn = InputBox("Enter Measurement")
Select Case True
Case LCase(strIn) Like "*c*"
MsgBox "probably " & Val(strIn) & " cm."
Case LCase(strIn) Like "*m*"
MsgBox "probably " & Val(strIn) & " mm."
Case LCase(strIn) Like "*in*"
MsgBox "probably " & Val(strIn) & " in."
End Select
End Sub

[neilt17]

Thank you very much for your replies - and sorry for my slow response!. I've gone for just looking for "cm", "mm", and "in" - and treating everything else as invalid. Where no unit is given, I set it to "cm" or "in" depending on what the user has set on their system. This seems to be the nearest match to what PowerPoint does with measurements in other contexts.

So I have:



' Returns points for strings which specify a unit following a number
' (cm, mm, or in).
' If no unit is contained in the string, then the measurement system for the
' locale is used - i.e. "cm" for metric, or "in" for US/imperial.
' An invalid measurement string returns -1.

Public Function StrToPoints(strMeasurement) As Double


' valid units: mm, cm, in
' we'll use these, and cm (or in) as default if no unit in string
' return -1 if not a valid measure.
' use val to get the numerical bit


' remove everything except numbers and decimal separators
' if characters in there which are not "mm" etc. numbers or dec.points - then not valid.


Dim strNumericChars
strNumericChars = "0123456789" & LocaleGetDecSep()


Dim strNumericString As String
strNumericString = ""


Dim dblPoints As Double


Dim stMeasUnit As String
stMeasUnit = ""


Dim boolNumericFound As Boolean
Dim boolNonNumericFound As Boolean


Dim iChar As Integer
Dim strChar As String

StrToPoints = -1

For iChar = 1 To Len(strMeasurement)
strChar = Mid$(strMeasurement, iChar, 1)
If strChar = " " Then
'ignore spaces;
ElseIf InStr(1, strNumericChars, strChar) > 0 Then
If boolNonNumericFound Then
' Numbers after non-numbers is not allowed
Exit Function
Else
boolNumericFound = True
strNumericString = strNumericString & strChar
End If
Else
If Not boolNumericFound Then
' Non-numbers before numbers is not allowed
Exit Function
Else
boolNonNumericFound = True
stMeasUnit = stMeasUnit & strChar
End If
End If
Next iChar

If Not boolNonNumericFound Then
If LocaleGetMeasure() = 1 Then
stMeasUnit = "in"
Else
stMeasUnit = "cm"
End If
End If

' CDbl will correctly handle the decimal separator according to the user's
' locale.
If strNumericString = "" Then
Exit Function
End If

dblPoints = CDbl(strNumericString)

Select Case stMeasUnit
' valid units: mm, cm, in (nothing else is recognised by ppt)
Case "cm"
dblPoints = cm2Points(dblPoints)
Case "mm"
dblPoints = cm2Points(dblPoints * 0.1)
Case "in"
dblPoints = in2Points(dblPoints)
Case Else
dblPoints = -1
End Select

StrToPoints = dblPoints

End Function

'----------------------------------------------------------
' In another module:

Option Explicit
Option Base 0

' This is based on various sources:

Private Declare Function GetLocaleInfo Lib "kernel32" _
Alias "GetLocaleInfoEx" (ByVal lpLocaleName As String, ByVal LCType As Long, _
ByVal lpLCData As String, ByVal cchData As Integer) As Integer
'Private Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
Private Declare Function GetUserDefaultLocaleName Lib "kernel32" _
(ByVal lpLocaleName As String, ByVal cchLocaleName As Integer) As Integer
' &HD is a long with decimal value 13.
Private Const LOCALE_IMEASURE = &HD ' 0 = metric, 1 = US
Private Const LOCALE_NAME_MAX_LENGTH = &H55
Private Const LOCALE_SDECIMAL = &HE
Private Const MY_DEFAULT_MEASURE = 0 ' default to metric if there's a problem.
' Outputs 0 for metric or 1 for US/imperial
Public Function LocaleGetMeasure() As String
' Initialise strings to a length with * 255 for example
' Passing a null string to either of the kernel32 functions
' will cause a crash.
Dim lpLocaleName As String * 85
Dim strMeasure As String
Dim strBuffer As String * 2
Dim intLen As Integer

strMeasure = MY_DEFAULT_MEASURE

If GetUserDefaultLocaleName(lpLocaleName, LOCALE_NAME_MAX_LENGTH) = 0 Then
LocaleGetMeasure = strMeasure
Exit Function
End If

intLen = GetLocaleInfo(lpLocaleName, LOCALE_IMEASURE, _
strBuffer, Len(strBuffer))
' Trim off extra junk, and final Null character.
If intLen > 1 Then
strMeasure = Left$(strBuffer, intLen - 1)
End If
LocaleGetMeasure = strMeasure
End Function


Public Function LocaleGetDecSep() As String
Dim lpLocaleName As String * 85
'Dim strMeasure As String
Dim strSep As String
Dim strBuffer As String * 2
Dim intLen As Integer
Dim strSepDefault As String

strSepDefault = "."
strSep = strSepDefault

If GetUserDefaultLocaleName(lpLocaleName, LOCALE_NAME_MAX_LENGTH) = 0 Then
LocaleGetDecSep = strSep
Exit Function
End If

intLen = GetLocaleInfo(lpLocaleName, LOCALE_SDECIMAL, _
strBuffer, Len(strBuffer))
' Trim off extra junk, and final Null character.
If intLen > 1 Then
strSep = Left$(strBuffer, intLen - 1)
End If

' won't support multi character separators:
If Len(strSep) > 1 Or Len(strSep) = 0 Then
strSep = strSepDefault
End If

LocaleGetDecSep = strSep

End Function