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