source: Include/Classes/System/Drawing/Font.ab@ 212

#ifndef _GDIPLUSFONT_H
#define _GDIPLUSFONT_H

#require <GdiPlus.ab>
#require <Classes/System/Drawing/misc.ab>
#require <Classes/System/Drawing/Graphics.ab>

Class FontFamily : End Class
Class FontCollection : End Class

Class Font
Public
'    friend class Graphics

    Sub Font(/*IN*/ hdc As HDC)
        Dim font = 0 As *GpFont
        lastResult = GdipCreateFontFromDC(hdc, font)
        SetNativeFont(font)
    End Sub

    Sub Font(/*IN*/ hdc As HDC, /*IN const*/ ByRef logfont As LOGFONTA)
        Dim font = 0 As *GpFont
        lastResult =GdipCreateFontFromLogfontA(hdc, logfont, font)
        SetNativeFont(font)
    End Sub

    Sub Font(/*IN*/ hdc As HDC, /*IN const*/ ByRef logfont As LOGFONTW)
        Dim font = 0 As *GpFont
        lastResult =GdipCreateFontFromLogfontW(hdc, logfont, font)
        SetNativeFont(font)
    End Sub

    Sub Font(/*IN*/ hdc As HDC, /*IN const*/ hfont As HFONT)
        Dim font = 0 As *GpFont
        If hfont <> 0 Then
            Dim lf As LOGFONTA
            If GetObjectA(hfont, sizeof (LOGFONTA), lf) <> 0 Then
                lastResult = GdipCreateFontFromLogfontA(hdc, lf, font)
            Else
                lastResult = GdipCreateFontFromDC(hdc, font)
            End If
        Else
            lastResult = GdipCreateFontFromDC(hdc, font)
        End If
        SetNativeFont(font)
    End Sub

    Sub Font(/*IN const*/ family As FontFamily, /*IN*/ emSize As Single)
        Font(family, emSize, FontStyleRegular, UnitPoint)
    End Sub

    Sub Font(/*IN const*/ family As FontFamily,
        /*IN*/ emSize As Single, /*IN*/ style As Long)

        Font(family, emSize, style, UnitPoint)
    End Sub

    Sub Font(/*IN const*/ family As FontFamily, /*IN*/ emSize As Single,
        /*IN*/ style As Long, /*IN*/ unit As GraphicsUnit)

        Dim font = 0 As *GpFont
        lastResult = GdipCreateFont(
            family.NativeFamily, emSize, style, unit, font)
        SetNativeFont(font)
    End Sub

    Sub Font(/*IN const*/ familyName As PCWSTR, /*IN*/ emSize As Single)
        Font(familyName, emSize, FontStyleRegular, Unit.Point, ByVal 0)
    End Sub

    Sub Font(/*IN const*/ familyName As String, /*IN*/ emSize As Single)
        Font(familyName, emSize, FontStyleRegular, Unit.Point, ByVal 0)
    End Sub

    Sub Font(/*IN const*/ familyName As PCWSTR, /*IN*/ emSize As Single,
         /*IN*/ style As Long)
        Font(familyName, emSize, style, Unit.Point, ByVal 0)
    End Sub

    Sub Font(/*IN const*/ familyName As String, /*IN*/ emSize As Single,
         /*IN*/ style As Long)
        Font(familyName, emSize, style, Unit.Point, ByVal 0)
    End Sub

    Sub Font(/*IN const*/ familyName As PCWSTR, /*IN*/ emSize As Single,
         /*IN*/ style As Long, /*IN*/ unit As GraphicsUnit)
        Font(familyName, emSize, style, unit, ByVal 0)
    End Sub

    Sub Font(/*IN const*/ familyName As String, /*IN*/ emSize As Single,
         /*IN*/ style As Long, /*IN*/ unit As GraphicsUnit)
        Font(familyName, emSize, style, unit, ByVal 0)
    End Sub

    Sub Font(/*IN const*/ familyName As PCWSTR, /*IN*/ emSize As Single,
        /*IN*/ style As Long, /*IN*/ unit As GraphicsUnit,
        /*IN const*/ ByRef fontCollection As FontCollection)

        nativeFont = 0

        Dim family As FontFamily(familyName, fontCollection)
        Dim nativeFamily = family.NativeFamily As *GpFontFamily

        lastResult = family.GetLastStatus()

        If lastResult <> Ok Then
            nativeFamily = FontFamily.GenericSansSerif()->NativeFamily
            lastResult = FontFamily.GenericSansSerif()->lastResult
            If lastResult <> Ok Then
                Exit Sub
            End If
        End If

        lastResult = GdipCreateFont(
            nativeFamily, emSize, style, unit, nativeFont)

        If lastResult <> Ok Then
            nativeFamily = FontFamily.GenericSansSerif()->NativeFamily
            lastResult = FontFamily.GenericSansSerif()->lastResult
            If lastResult <> Ok Then
                Exit Sub
            End If

            lastResult = GdipCreateFont(
                nativeFamily, emSize, style, unit, nativeFont)
        End If
    End Sub

    Sub Font(/*IN const*/ familyName As String, /*IN*/ emSize As Single,
        /*IN*/ style As Long, /*IN*/ unit As GraphicsUnit,
        /*IN const*/ fontCollection As FontCollection)
#ifdef __STRING_IS_NOT_UNICODE
        Dim oldAlloc = _System_AllocForConvertedString
        _System_AllocForConvertedString = AddressOf (_System_malloc)
        Dim name = ToWCStr(familyName)
        Font(name, emSize, style, unit, fontCollection)
        _System_free(name)
        _System_AllocForConvertedString = oldAlloc
#else
        Font(familyName.Chars, emSize, style, unit, fontCollection)
#endif
    End Sub

    Const Function GetLogFontA(/*IN const*/ g As Graphics, /*OUT*/ ByRef lf As LOGFONTA) As Status
        Dim nativeGraphics As *GpGraphics
        If VarPtr(g) <> 0 Then
            nativeGraphics = g.nativeGraphics
        End If
        Return SetStatus(GdipGetLogFontA(nativeFont, nativeGraphics, lf))
    End Function

    Const Function GetLogFontW(/*IN const*/ g As Graphics, /*OUT*/ ByRef lf As LOGFONTW) As Status
        Dim nativeGraphics As *GpGraphics
        If VarPtr(g) <> 0 Then
            nativeGraphics = g.nativeGraphics
        End If
        Return SetStatus(GdipGetLogFontW(nativeFont, nativeGraphics, lf))
    End Function

    Const Function GetLogFont(/*IN const*/ g As Graphics, /*OUT*/ ByRef lf As LOGFONT) As Status
        Dim nativeGraphics As *GpGraphics
        If VarPtr(g) <> 0 Then
            nativeGraphics = g.nativeGraphics
        End If
#ifdef UNICODE
        Return SetStatus(GdipGetLogFontW(nativeFont, nativeGraphics, lf))
#else
        Return SetStatus(GdipGetLogFontA(nativeFont, nativeGraphics, lf))
#endif
    End Function

    Const Function Clone() As Font
        Dim cloneFont = 0 As *GpFont
        SetStatus(GdipCloneFont(nativeFont, cloneFont))
        Return New Font(cloneFont, lastResult)
    End Function

    Sub ~Font()
        GdipDeleteFont(nativeFont)
    End Sub

    Const Function IsAvailable() As Boolean
        Return nativeFont <> 0
    End Function

    Const Function Style() As Long
        SetStatus(GdipGetFontStyle(nativeFont, Style))
    End Function

    Const Function Size() As Single
        SetStatus(GdipGetFontSize(nativeFont, Size))
    End Function

    Const Function SizeInPoints() As Single

    Const Function Unit() As GraphicsUnit
        SetStatus(GdipGetFontUnit(nativeFont, Unit))
    End Function

    Const Function LastStatus() As Status
        Return lastResult
    End Function

    Const Function Height() As Long
        Return GetHeight() As Long
    End Function

    Const Function GetHeight() As Single
        SetStatus(GdipGetFontHeight(nativeFont, 0, GetHeight))
    End Function

    Const Function GetHeight(/*IN const*/ g As Graphics) As Single
        Dim nativeGraphics As *GpGraphics
        If VarPtr(g) <> 0 Then
            nativeGraphics = g.NativeGraphics
        End If
        SetStatus(GdipGetFontHeight(nativeFont, nativeGraphics, GetHeight))
    End Function

    Const Function GetHeight(/*IN*/ dpi As Single) As Single
        SetStatus(GdipGetFontHeightGivenDPI(nativeFont, dpi, GetHeight))
    End Function

'    Const Function FontFamily(/*OUT*/ ByRef family As FontFamily)
'       If VarPtr(family) = 0 Then
'           Return SetStatus(Status.InvalidParameter)
'       End If
'       Dim status = GdipGetFamily(nativeFont, family->nativeFamily)
'       family->SetStatus(status)
'       Return SetStatus(status)
'   End Function

    Const Function Bold() As Boolean
        Dim lf As LOGFONT
        GetLogFont(0, lf)
        Return lf.lfWeight > FW_BOLD
    End Function

    Const Function GdiCharSet() As Byte
        Dim lf As LOGFONT
        GetLogFont(0, lf)
        Return lf.lfCharSet
    End Function

    'Const Function GdiVerticalFont() As Boolean

    Const Function NativeFont() As *GpFont
        Return nativeFont
    End Function

    'Const Function IsSystemFont() As Boolean

    Const Function Italic() As Boolean
        Dim lf As LOGFONT
        GetLogFont(0, lf)
        Return lf.lfItalic <> FALSE
    End Function

    Const Function Name() As String
#ifdef __STRING_IS_NOT_UNICODE
        Dim lf As LOGFONTA
        GetLogFontA(0, lf)
#else
        Dim lf As LOGFONTW
        GetLogFontW(0, lf)
#endif
        Return lf.lfFaceName
    End Function

    'Const Function SizeInPoint() As Boolean

    Const Function NativeFont() As *GpFont
        Return nativeFont
    End Function

    Const Function StrikeOut() As Boolean
        Dim lf As LOGFONT
        GetLogFont(0, lf)
        Return lf.fdwStrikeOut <> FALSE
    End Function

    Const Function Style() As FontStyle
        Dim lf As LOGFONT
        GetLogFont(0, lf)
        Return (((lf.lfWeight > FW_BOLD) And FontStyle.Bold) Or _
            ((lf.lfItatlic <> FALSE) And FontStyle.Italic) Or _
            ((lf.fdwStrikeOut <> FALSE) And FontStyle.Strickeout) Or _
            ((lf.fdwUnderline <> FALSE) And FontStyle.Underline)) As FontStyle
    End Function

    'Const Function SystemFontName() As String

    Const Function Underline() As Boolean
        Dim lf As LOGFONT
        GetLogFont(0, lf)
        Return lf.fdwUnderline <> FALSE
    End Function

    Override Function ToString() As String
        Return Name
    End Function

    Const Function ToHfont() As HFONT
        Dim lf As LOGFONT
        GetLogFont(ByVal 0, lf)
        Return CreateFontIndirect(lf)
    End Function

    Const Sub ToLogFont(ByRef lf As LOGFONT)
        GetLogFont(ByVal 0, lf)
    End Sub

    Const Sub ToLogFont(ByRef lf As LOGFONT, g As Graphics)
        GetLogFont(g, lf)
    End Sub

Private
'   Sub Font(ByRef f As Font)

Protected
    Sub Font(f As *GpFont, status As Status)
        lastResult = status
        SetNativeFont(f)
    End Sub

    Sub SetNativeFont(f As *GpFont)
        nativeFont = f
    End Sub

    Const Function SetStatus(s As Status) As Status
        If s <> Status.Ok Then
            lastResult = s
            Return s
        Else
            Return s
        End If
    End Function

Protected
    nativeFont As *GpFont
    /*mutable*/ lastResult As Status
End Class

#endif