Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,853
- Office Version
- 2016
- Platform
- Windows
Hi,
I never noticed that sub/superscript characters couldn't be displayed on userform captions until this was raised on this forum the other day.
here is a little hack that i've managed to put together to simulate sub/superscrips via subclassing the userform.I am hoping this could be expanded to other than just label controls.
here is a workbook demo:
http://www.savefile.com/files/2109591
You will need to add a label control ( with no caption) to your userform and set its caption through the SubSuperScript routinelike: Call SubSuperScript("(a+b)^2^ = a^2^+b^2^+2ab", Me.Label1)
where superscript text is placed between (^ ^ )and subscript chars between (_ _).
The above example will output (a+b)2= a2+b2+2ab with 2 as a superscript char.
code in the userform module:
code in a standard module:
Tested on WinXP excel2003. I would be interested to know if there are any bugs when tested on a other systems.
Regards.
I never noticed that sub/superscript characters couldn't be displayed on userform captions until this was raised on this forum the other day.
here is a little hack that i've managed to put together to simulate sub/superscrips via subclassing the userform.I am hoping this could be expanded to other than just label controls.
here is a workbook demo:
http://www.savefile.com/files/2109591
You will need to add a label control ( with no caption) to your userform and set its caption through the SubSuperScript routinelike: Call SubSuperScript("(a+b)^2^ = a^2^+b^2^+2ab", Me.Label1)
where superscript text is placed between (^ ^ )and subscript chars between (_ _).
The above example will output (a+b)2= a2+b2+2ab with 2 as a superscript char.
code in the userform module:
Code:
Option Explicit
Private Sub UserForm_Activate()
'example 3
Call SubSuperScript("(a+b)^2^ = a^2^+b^2^+2ab", Me.Label1)
End Sub
Private Sub UserForm_Terminate()
Call RemoveSubclass
End Subcode in a standard module:
Code:
Option Explicit
Option Base 1
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lfFaceName As String * 32
End Type
Private oLabel As Object
Private sText As String
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" _
Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long _
, ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private Const WM_MOVE = &H3
Private Const WM_ACTIVATEAPP = &H1C
Private Declare Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hdc As Long, _
ByVal lpsz As String, _
ByVal cbString As Long, _
lpSize As POINTAPI) As Long
Private lOldFont As Long
Private lHwnd As Long
Private lPrevWnd As Long
Private Function CallBack _
(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim textSize As POINTAPI
Dim tPt1 As POINTAPI
Dim sCurString As String
Dim sString As String
Dim sCurChar As String * 1
Dim lDC As Long
Dim lLeft As Long
Dim lTop As Long
Dim lRight As Long
Dim lBottom As Long
Dim i As Long
Dim sglCurTextWidth As Single
sString = sText
Select Case Msg
Case WM_MOVE, WM_ACTIVATEAPP
lDC = GetDC(hwnd)
SetBkMode lDC, 1
For i = 1 To Len(sString)
sCurChar = Mid(sString, i, 1)
If sCurChar <> "_" And sCurChar <> "^" Then
With oLabel
lTop = .Top * 1.3333
lLeft = .Left * 1.3333
lRight = (.Left + .Width) * 1.333
lBottom = (.Top + .Height) * 1.333
End With
tPt1.x = lLeft
GetTextExtentPoint32 lDC, sCurString, _
Len(sCurString), textSize
sglCurTextWidth = textSize.x
Call SetFont(lDC, SmallFont:=True)
On Error Resume Next
WorksheetFunction.Match i, _
AssignSuperSubScriptCharPosToArray(sString), 0
If Err = 0 Then
On Error GoTo 0
TextOut lDC, lLeft + sglCurTextWidth, _
lBottom, sCurChar, Len(sCurChar)
GoTo nxt
End If
On Error Resume Next
WorksheetFunction.Match i, _
AssignSuperSubScriptCharPosToArray(sString, True), 0
If Err = 0 Then
On Error GoTo 0
TextOut lDC, lLeft + sglCurTextWidth, _
lTop, sCurChar, Len(sCurChar)
GoTo nxt
End If
Call SetFont(lDC)
TextOut lDC, lLeft + sglCurTextWidth, _
lTop, sCurChar, Len(sCurChar)
nxt:
SelectObject lDC, lOldFont
sCurString = (sCurString & sCurChar)
End If
Next
ReleaseDC hwnd, lDC
Exit Function
End Select
CallBack = CallWindowProc _
(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function
Private Sub SetFont(DC As Long, Optional SmallFont As Boolean)
Dim uFont As LOGFONT
Dim lFHwnd As Long
With uFont
.lfFaceName = "Arial" & Chr$(0)
If SmallFont Then
.lfHeight = 8 ' change these font params as required
.lfWidth = 7 '
lFHwnd = CreateFontIndirect(uFont)
lOldFont = SelectObject(DC, lFHwnd)
Else
.lfHeight = 14 ' change these font params as required
.lfWidth = 8 '
End If
End With
lFHwnd = CreateFontIndirect(uFont)
lOldFont = SelectObject(DC, lFHwnd)
DeleteObject lFHwnd
End Sub
Sub SubSuperScript(text As String, Label As Object)
Call SuClassForm(text, Label)
End Sub
Private Sub SuClassForm(text As String, Label As Object)
Dim i As Long
Dim dOldtimer As Double
dOldtimer = Timer
Set oLabel = Label
oLabel.AutoSize = True
sText = text
lHwnd = FindWindow(vbNullString, Label.Parent.Caption)
lPrevWnd = SetWindowLong(lHwnd, GWL_WNDPROC, AddressOf CallBack)
Do
i = i + 1
DoEvents
Loop Until Timer - dOldtimer > 0.0001
With Label.Parent
.Move .Left + 1, .Top, .Width, .Height
.Move .Left - 1, .Top, .Width, .Height
End With
End Sub
Private Function AssignSuperSubScriptCharPosToArray _
(text As String, Optional Superscript As Boolean) _
As Long()
Dim ar1() As Long
Dim ar2() As Long
Dim loops
Dim n As Long
Dim i As Long
Dim j As Long
Dim k As Long
On Error Resume Next
If Superscript Then
n = 1
For i = 1 To Len(text)
If Mid(text, i, 1) = "^" Then
ReDim Preserve ar1(n)
ar1(n) = i
n = n + 1
End If
Next
Else
n = 1
For i = 1 To Len(text)
If Mid(text, i, 1) = "_" Then
ReDim Preserve ar1(n)
ar1(n) = i
n = n + 1
End If
Next
End If
For i = 1 To UBound(ar1) Step 2
loops = (ar1(i + 1) - ar1(i)) - 1
For j = 1 To loops
k = k + 1
ReDim Preserve ar2(k)
ar2(k) = ar1(i) + j
Next j
Next i
AssignSuperSubScriptCharPosToArray = (ar2)
End Function
Sub RemoveSubclass()
SetWindowLong lHwnd, GWL_WNDPROC, lPrevWnd
End SubTested on WinXP excel2003. I would be interested to know if there are any bugs when tested on a other systems.
Regards.
