Public Sub SetFont( _
ByRef fntThis As StdFont, _
Optional ByVal oColor As OLE_COLOR = vbWindowText, _
Optional ByVal eType As ERECTextTypes = ercTextNormal, _
Optional ByVal bHyperLink As Boolean = False, _
Optional ByVal eRange As ERECSetFormatRange = ercSetFormatSelection _
)
Dim tCF As CHARFORMAT
Dim tCF2 As CHARFORMAT2
Dim tRect As RECT
Dim dwEffects As Long
Dim dwMask As Long
Dim i As Long
Dim int_eventMask As Long
If (m_eVersion = eRICHED32) Then
tCF.cbSize = Len(tCF)
tCF.crTextColor = TranslateColor(oColor)
dwMask = CFM_COLOR
If fntThis.Bold Then
dwEffects = dwEffects Or CFE_BOLD
End If
dwMask = dwMask Or CFM_BOLD
If fntThis.Italic Then
dwEffects = dwEffects Or CFE_ITALIC
End If
dwMask = dwMask Or CFM_ITALIC
If fntThis.Strikethrough Then
dwEffects = dwEffects Or CFE_STRIKEOUT
End If
dwMask = dwMask Or CFM_STRIKEOUT
If fntThis.Underline Then
dwEffects = dwEffects Or CFE_UNDERLINE
End If
dwMask = dwMask Or CFM_UNDERLINE
If bHyperLink Then
dwEffects = dwEffects Or CFE_LINK
End If
dwMask = dwMask Or CFM_LINK
tCF.dwEffects = dwEffects
tCF.dwMask = dwMask Or CFM_FACE Or CFM_SIZE
For i = 1 To Len(fntThis.Name)
tCF.szFaceName(i - 1) = Asc(Mid$(fntThis.Name, i, 1))
Next i
tCF.yHeight = (fntThis.Size * 20)
If (eType = ercTextSubscript) Then
tCF.yOffset = -tCF.yHeight \ 2
End If
If (eType = ercTextSuperscript) Then
tCF.yOffset = tCF.yHeight \ 2
End If
SendMessage m_hWnd, EM_SETCHARFORMAT, eRange, tCF
Else
tCF2.cbSize = Len(tCF2)
tCF2.crTextColor = TranslateColor(oColor)
tCF2.bCharSet = 255
dwMask = CFM_COLOR
If fntThis.Bold Then
dwEffects = dwEffects Or CFE_BOLD
End If
dwMask = dwMask Or CFM_BOLD
If fntThis.Italic Then
dwEffects = dwEffects Or CFE_ITALIC
End If
dwMask = dwMask Or CFM_ITALIC
If fntThis.Strikethrough Then
dwEffects = dwEffects Or CFE_STRIKEOUT
End If
dwMask = dwMask Or CFM_STRIKEOUT
If fntThis.Underline Then
dwEffects = dwEffects Or CFE_UNDERLINE
End If
dwMask = dwMask Or CFM_UNDERLINE
If bHyperLink Then
dwEffects = dwEffects Or CFE_LINK
End If
dwMask = dwMask Or CFM_LINK
tCF2.dwEffects = dwEffects
tCF2.dwMask = dwMask Or CFM_FACE Or CFM_SIZE Or CFM_CHARSET
For i = 1 To Len(fntThis.Name)
tCF2.szFaceName(i - 1) = Asc(Mid$(fntThis.Name, i, 1))
Next i
tCF2.yHeight = (fntThis.Size * 20)
If (eType = ercTextSubscript) Then
tCF2.yOffset = -tCF2.yHeight \ 2
End If
If (eType = ercTextSuperscript) Then
tCF2.yOffset = tCF2.yHeight \ 2
End If
If (eType = ercTextSubscript) Then
tCF2.dwEffects = tCF2.dwEffects Or CFE_SUBSCRIPT
tCF2.dwMask = tCF2.dwMask Or CFM_SUBSCRIPT
End If
If (eType = ercTextSuperscript) Then
tCF2.dwEffects = tCF2.dwEffects Or CFE_SUPERSCRIPT
tCF2.dwMask = tCF2.dwMask Or CFM_SUPERSCRIPT
End If
SendMessage m_hWnd, WM_SETREDRAW, False, 0
SendMessage m_hWnd, EM_SETCHARFORMAT, eRange, tCF2
SendMessage m_hWnd, WM_SETREDRAW, True, 0
InvalidateRect m_hWnd, tRect, True
End If
End Sub