Prev: MSCHRT20.ocx compatibility breakdown in latest version?
Next: SendInput and Unicode
From: Schmidt on 29 Jan 2009 13:00

"expvb" <nobody(a)cox.net> schrieb im Newsbeitrag
news:eJ2vt6igJHA.1172(a)TK2MSFTNGP04.phx.gbl...
> "Robert" <robert(a)nowhere.com> wrote in message
> news:u0%23GbphgJHA.564(a)TK2MSFTNGP03.phx.gbl...
> > Follow up to previous "Labels" message.
> >
> > VB6 SP5
> >
> > Is there any Free Labels that allow "unicode"
>
> No, but it's very easy to duplicate a label using DrawTextW
> with DT_WORDBREAK flag to simulate word-wrap.
> You can make your own UniLabel by following these steps:
> ...
Yep - good advice...

Also have put together someting like that, which
supports the Windowless-Mode - and also the
BackStyle=0 mode for transparency.

Not very nice (more a raw starting-base),
but it should work:

Option Explicit

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function DrawTextW Lib "user32" (ByVal hdc As Long, _
ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, _
ByVal wFormat As Long) As Long

Private mCaption As String, mBackColor As Long, NoRedraw As Boolean
Private WithEvents tmrRefresh As VB.Timer 'only needed in DesignMode

Public Property Get Caption() As String
Caption = mCaption
End Property
Public Property Let Caption(ByVal NewValue As String)
mCaption = NewValue
PropertyChanged "Caption"
Refresh
End Property

Public Property Get BackStyle() As Long
BackStyle = UserControl.BackStyle
End Property
Public Property Let BackStyle(ByVal NewValue As Long)
UserControl.BackStyle = NewValue
PropertyChanged "BackStyle"
Refresh
End Property

Public Property Get BackColor() As OLE_COLOR
BackColor = mBackColor
End Property
Public Property Let BackColor(ByVal NewValue As OLE_COLOR)
mBackColor = NewValue
PropertyChanged "BackColor"
Refresh
End Property

Public Sub Refresh()
If Not Ambient.UserMode Then 'timer-decoupled refreshing in designmode
If tmrRefresh Is Nothing Then
Set tmrRefresh = Controls.Add("VB.Timer", "tmrRefresh")
tmrRefresh.Interval = 15
End If
tmrRefresh.Enabled = True

Else 'direct drawing in Run-Mode
Draw
End If
End Sub

Private Sub UserControl_Initialize()
AutoRedraw = True
End Sub
Private Sub UserControl_HitTest(X As Single, Y As Single, HitResult%)
HitResult = vbHitResultHit
End Sub
Private Sub UserControl_Resize()
Refresh
End Sub
Private Sub UserControl_Show()
Refresh
End Sub

Private Sub tmrRefresh_Timer()
tmrRefresh.Enabled = False
Draw
End Sub

Private Sub Draw()
If NoRedraw Then Exit Sub

Cls
Set Picture = Nothing
Set MaskPicture = Nothing

If BackStyle = vbTransparent Then
UserControl.MaskColor = vbMagenta
UserControl.BackColor = vbMagenta
Else
UserControl.BackColor = mBackColor
End If

If Len(mCaption) = 0 Then Exit Sub

Dim Rct As RECT
Rct.Right = ScaleX(ScaleWidth, Extender.Container.ScaleMode, vbPixels)
Rct.Bottom = ScaleY(ScaleHeight, Extender.Container.ScaleMode, vbPixels)
DrawTextW hdc, StrPtr(mCaption), Len(mCaption), Rct, &H10

Set Picture = Image
If BackStyle = vbTransparent Then Set MaskPicture = Picture
End Sub

Private Sub UserControl_InitProperties()
mCaption = Ambient.DisplayName
mBackColor = &H8000000F
BackStyle = vbTransparent
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
NoRedraw = True
BackStyle = PropBag.ReadProperty("BackStyle", 0)
mBackColor = PropBag.ReadProperty("BackColor", &H8000000F)
mCaption = PropBag.ReadProperty("Caption", "")
NoRedraw = False
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "BackStyle", BackStyle
PropBag.WriteProperty "BackColor", mBackColor
PropBag.WriteProperty "Caption", mCaption
End Sub

Olaf



First  |  Prev  | 
Pages: 1 2
Prev: MSCHRT20.ocx compatibility breakdown in latest version?
Next: SendInput and Unicode