Option Explicit
 
Private Declare Function IsWindow Lib "user32" _
  (ByVal hwnd As Long) As Long
 
Private Declare Function GetDC Lib "user32" _
  (ByVal hwnd As Long) As Long
 
Private Declare Function GetClientRect Lib "user32" _
  (ByVal hwnd As Long, lpRect As RECT) As Long
 
Private Declare Function DrawText Lib "user32" Alias _
  "DrawTextA" _
  (ByVal hdc As Long, ByVal lpStr As String, _
   ByVal nCount As Long, lpRect As RECT, _
   ByVal wFormat As Long) As Long
 
Private Declare Function CreateBrushIndirect Lib "gdi32" _
  (lpLogBrush As LOGBRUSH) 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 FillRect Lib "user32" _
  (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
 
Private Declare Function SetTextColor Lib "GDI32.DLL" _
  (ByVal hdc As Long, ByVal crColor As Long) As Long
 
Private Declare Function DrawEdge Lib "user32" _
  (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, _
   ByVal grfFlags As Long) As Long
 
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Public Enum EnumBorderStyle
    Border_Flat = 1
    Border_Mono
    Border_Bump
    Border_Etched
    Border_Raised
    Border_Sunken
End Enum
 
Public Enum EnumGridLines
    Lines_Nothing = 1
    Lines_Vertical
    Lines_Horizontal
    Lines_Both
End Enum
 
Public Enum EnumAlignment
    Align_Left = 0
    Align_Center
    Align_Right
End Enum
 
Public Enum EnumSize
    Size_Bottom = 1
    Size_Top
    Size_VCenter
End Enum
 
Public Enum EnumWordbreak
    Break_No = 1
    Break_Elipsis
    Break_WordBreak
End Enum
 
'DrawText Konstante
Private Const DT_BOTTOM = &H8
Private Const DT_CENTER = &H1
Private Const DT_END_ELLIPSIS = &H8000
Private Const DT_LEFT = &H0
Private Const DT_NOCLIP = &H100
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TOP = &H0
Private Const DT_MODIFYSTRING = &H10000
Private Const DT_VCENTER = &H4
Private Const DT_WORD_ELLIPSIS = &H40000
Private Const DT_WORDBREAK = &H10
 
'DrawBorder Konstante
Private Const BF_ADJUST = &H2000
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_FLAT = &H4000
Private Const BF_MIDDLE = &H800
Private Const BF_MONO = &H8000
Private Const BF_SOFT = &H1000
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BDR_INNER = &HC
Private Const BDR_OUTER = &H3
Private Const BDR_RAISED = &H5
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKEN = &HA
Private Const BDR_SUNKENINNER = &H8
Private Const BDR_SUNKENOUTER = &H2
Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
 
Private tmphWnd As Long
Private tmphDC As Long
Private tmpRect As RECT
Private tmpWinRect As RECT
Private tmpBorder As EnumBorderStyle
Private tmpLines As EnumGridLines
Private tmpBackColor As Long
Private tmpForeColor As Long
Private tmpContainer As Object
Private tmpHasFocus As Boolean
Private tmpValue As Variant
Private tmpNote As Variant
Private tmpFormula As Variant
Private tmpVarTyp As Long
Private tmpAlign As EnumAlignment
Private tmpSize As EnumSize
Private tmpWordBreak As EnumWordbreak
 
Public Property Get hwnd() As Long
   hwnd = tmphWnd
End Property
 
Public Property Get hdc() As Long
   hdc = tmphDC
End Property
 
Public Property Get Top() As Long
    Top = tmpRect.Top
End Property
 
Public Property Let Top(ByVal vNewValue As Long)
    If tmphWnd = 0 Then Exit Property
    tmpRect.Top = vNewValue
End Property
 
Public Property Get Left() As Long
    Left = tmpRect.Left
End Property
 
Public Property Let Left(ByVal vNewValue As Long)
    If tmphWnd = 0 Then Exit Property
    tmpRect.Left = vNewValue
End Property
 
Public Property Get Width() As Long
    Width = tmpRect.Right
End Property
 
Public Property Let Width(ByVal vNewValue As Long)
    If tmphWnd = 0 Then Exit Property
    tmpRect.Right = vNewValue
End Property
 
Public Property Get Height() As Long
    Height = tmpRect.Bottom
End Property
 
Public Property Let Height(ByVal vNewValue As Long)
    If tmphWnd = 0 Then Exit Property
    tmpRect.Bottom = vNewValue
End Property
 
Public Property Get BorderStyle() As EnumBorderStyle
   BorderStyle = tmpBorder
End Property
 
Public Property Let BorderStyle(ByVal vNewValue As EnumBorderStyle)
   If tmphWnd = 0 Then Exit Property
   tmpBorder = vNewValue
End Property
 
Public Property Get GridLines() As EnumGridLines
   GridLines = tmpLines
End Property
 
Public Property Let GridLines(ByVal vNewValue As EnumGridLines)
   If tmphWnd = 0 Then Exit Property
   tmpLines = vNewValue
End Property
 
Public Sub Resize()
    If tmphWnd = 0 Then Exit Sub
    GetClientRect tmphWnd, tmpWinRect
    DrawCellText
End Sub
 
Public Property Get BackColor() As Long
   BackColor = tmpBackColor
End Property
 
Public Property Let BackColor(ByVal vNewValue As Long)
   tmpBackColor = vNewValue
End Property
 
Public Property Get ForeColor() As Long
   ForeColor = tmpForeColor
End Property
 
Public Property Let ForeColor(ByVal vNewValue As Long)
   tmpForeColor = vNewValue
End Property
 
Public Property Get Container() As Variant
    Set Container = tmpContainer
End Property
 
Public Property Set Container(vNewValue As Variant)
   Dim hResult As Long
 
   On Error Resume Next
   hResult = IsWindow(vNewValue.hwnd)
   If Err .Number > 0 Then
      Err.Clear
      Exit Property
   End If
   On Error GoTo 0
 
   If hResult = 0 Then Exit Property
   tmphWnd = vNewValue.hwnd
   tmphDC = GetDC(tmphWnd)
   GetClientRect tmphWnd, tmpWinRect
   Set tmpContainer = vNewValue
End Property
 
Private Sub Class_Initialize()
   tmphWnd = 0
   tmpBackColor = RGB(255, 255, 255)
   tmpForeColor = 0
   tmpHasFocus = True
End Sub
 
Private Sub Class_Terminate()
   If tmphWnd = 0 Then Exit Sub
   Set tmpContainer = Nothing
End Sub
 
Public Property Get DrawFocus() As Boolean
   DrawFocus = tmpHasFocus
End Property
 
Public Property Let DrawFocus(ByVal vNewValue As Boolean)
   tmpHasFocus = vNewValue
End Property
 
Public Property Get Value() As Variant
   Value = tmpValue
End Property
 
Public Property Let Value(ByVal vNewValue As Variant)
   tmpVarTyp = VarType(vNewValue)
   tmpValue = ""
   Select Case tmpVarTyp
       Case vbInteger: tmpValue = CStr(vNewValue)
       Case vbLong: tmpValue = CStr(vNewValue)
       Case vbSingle: tmpValue = CStr(vNewValue)
       Case vbDouble: tmpValue = CStr(vNewValue)
       Case vbCurrency: tmpValue = CStr(vNewValue)
       Case vbDate: tmpValue = CStr(vNewValue)
       Case vbString: tmpValue = vNewValue
       Case vbBoolean: tmpValue = CStr(vNewValue)
       Case vbByte: tmpValue = CStr(vNewValue)
       Case vbDecimal: tmpValue = CStr(vNewValue)
   End Select
   If tmpValue = "" Then Exit Property
   DrawCellText
End Property
 
Public Property Get CellTyp() As Long
   CellTyp = tmpVarTyp
End Property
 
Public Property Get Formel() As Variant
   Formel = tmpFormula
End Property
 
Public Property Let Formel(ByVal vNewValue As Variant)
   tmpFormula = vNewValue
End Property
 
Public Property Get Note() As Variant
   Note = tmpNote
End Property
 
Public Property Let Note(ByVal vNewValue As Variant)
   tmpNote = vNewValue
End Property
 
Public Property Get Alignment() As EnumAlignment
   Alignment = tmpAlign
End Property
 
Public Property Let Alignment(ByVal vNewValue As EnumAlignment)
   tmpAlign = vNewValue
End Property
 
Public Property Get TextSize() As EnumSize
   TextSize = tmpSize
End Property
 
Public Property Let TextSize(ByVal vNewValue As EnumSize)
   tmpSize = vNewValue
End Property
 
Public Property Get WordBreak() As EnumWordbreak
   WordBreak = tmpWordBreak
End Property
 
Public Property Let WordBreak(ByVal vNewValue As EnumWordbreak)
   tmpWordBreak = vNewValue
End Property
 
Private Sub DrawCellText()
   Dim nFlags As Long
   If tmphWnd = 0 Then Exit Sub
 
   Select Case tmpAlign
      Case Align_Left: nFlags = nFlags Or DT_LEFT
      Case Align_Center: nFlags = nFlags Or DT_CENTER
      Case Align_Right: nFlags = nFlags Or DT_RIGHT
   End Select
 
   Select Case tmpSize
      Case Size_Bottom: nFlags = nFlags Or DT_BOTTOM
      Case Size_Top: nFlags = nFlags Or DT_TOP
      Case Size_VCenter: nFlags = nFlags Or DT_SINGLELINE Or DT_VCENTER
   End Select
 
   Select Case tmpWordBreak
      Case Break_No: nFlags = nFlags Or DT_MODIFYSTRING Or DT_WORD_ELLIPSIS
      Case Break_Elipsis: nFlags = nFlags Or DT_MODIFYSTRING Or DT_WORD_ELLIPSIS
      Case Break_WordBreak: nFlags = nFlags Or DT_WORDBREAK
   End Select
 
   EraseBackground
 
   SetTextColor tmphDC, tmpForeColor
   DrawText tmphDC, tmpValue, Len(tmpValue), tmpRect, nFlags
   DrawCellBorder
End Sub
 
Private Sub DrawCellBorder()
   Dim nFlagsEdge As Long
   Dim nFlagsDraw As Long
 
   If tmphWnd = 0 Then Exit Sub
   If tmpLines = Lines_Nothing Then Exit Sub
   If tmpBorder = Border_Flat Then Exit Sub
 
   Select Case tmpBorder
     Case Border_Mono: nFlagsEdge = 0
     Case Border_Bump: nFlagsEdge = EDGE_BUMP
     Case Border_Etched: nFlagsEdge = EDGE_ETCHED
     Case Border_Raised: nFlagsEdge = EDGE_RAISED
     Case Border_Sunken: nFlagsEdge = EDGE_SUNKEN
   End Select
 
   Select Case tmpLines
     Case Lines_Nothing: nFlagsDraw = BF_FLAT
     Case Lines_Vertical: nFlagsDraw = BF_LEFT Or BF_RIGHT
     Case Lines_Horizontal: nFlagsDraw = BF_TOP Or BF_BOTTOM
     Case Lines_Both: nFlagsDraw = BF_RECT
   End Select
 
   DrawEdge tmphDC, tmpRect, nFlagsEdge, nFlagsDraw
End Sub
 
Private Sub EraseBackground()
   Dim Oldbrush As Long
   Dim hBrush As Long
   Dim lb As LOGBRUSH
 
   lb.lbColor = tmpBackColor
   hBrush = CreateBrushIndirect(lb)
   Oldbrush = SelectObject(tmphDC, hBrush)
   FillRect tmphDC, tmpRect, hBrush
   DeleteObject hBrush
End Sub
 
Public Sub ReDraw()
   DrawCellText
End Sub
 
Public Sub SetNote()
   On Error Resume Next
   tmpContainer.ToolTipText = tmpNote
End Sub
 
Public Sub SetFormula()
   On Error Resume Next
   tmpContainer.ToolTipText = tmpFormula
End Sub