95 Style Status Bar for Windows 3.11
Listing 3 looks like this...
Option Explicit Private mbAlignment As Byte Private mbAutoSize As Byte Private mbBevel As Byte Private mbStyle As Byte Private mbEnabled As Boolean Private mbVisible As Boolean Private mdLeft As Single Private mdMinWidth As Single Private mdWidth As Single Private mdOldLeft As Single Private mdOldWidth As Single Private msKey As String Private msText As String Private mPic As Picture Private mPanel As PictureBox Private mpicParent As Object Private Const gGap = 30 #If Win32 Then Private Declare Function BitBlt Lib "GDI32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long #Else Private Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer #End If Public Property Let Alignment(Value As Byte) Dim RefreshRequired As Boolean If Value < sbrLeft Or Value > sbrRight Then Value = sbrLeft RefreshRequired = mbAlignment <> Value mbAlignment = Value If RefreshRequired Then Refresh End Property Public Property Get Alignment() As Byte Alignment = mbAlignment End Property Public Property Let AutoSize(Value As Byte) Dim RefreshRequired As Boolean If Value < sbrNoAutoSize Or Value > sbrContents Then Value = sbrNoAutoSize RefreshRequired = mbAutoSize <> Value mbAutoSize = Value If RefreshRequired And Not mpicParent Is Nothing Then mpicParent.Refresh End If End Property Public Property Get AutoSize() As Byte AutoSize = mbAutoSize End Property Public Property Let Bevel(Value As Byte) Dim RefreshRequired As Boolean If Value < sbrNoBevel Or Value > sbrRaised Then Value = sbrInset RefreshRequired = mbBevel <> Value mbBevel = Value If RefreshRequired Then Refresh End Property Public Property Get Bevel() As Byte Bevel = mbBevel End Property Private Sub Class_Initialize() Set mPanel = frmStatusRes.picPanel mbAlignment = sbrLeft mbBevel = sbrInset mbEnabled = True mbStyle = sbrText mdOldWidth = 1440 mdOldLeft = gGap mdMinWidth = 1440 mdWidth = 1440 mdLeft = gGap End Sub Private Sub Class_Terminate() Set mPanel = Nothing Set mpicParent = Nothing End Sub Private Sub DrawPanel() Dim nResult As Integer Dim ColorTopLeft As Long Dim ColorBottomRight As Long Dim ForeColor As Long Dim nTextWidth As Single Dim nTextHeight As Single Dim x1 As Single Dim y1 As Single On Error Resume Next If mbEnabled Then ForeColor = vbButtonText Else ForeColor = vbGrayText Select Case mbBevel Case sbrNoBevel ColorTopLeft = vbButtonFace ColorBottomRight = vbButtonFace Case sbrInset ColorTopLeft = vb3DShadow ColorBottomRight = vb3DHighlight Case sbrRaised ColorTopLeft = vb3DHighlight ColorBottomRight = vb3DShadow End Select mPanel.Cls mPanel.ForeColor = ForeColor mPanel.Width = mdWidth mPanel.Height = Height Select Case mbAlignment Case sbrLeft x1 = gGap * 2 Case sbrCenter x1 = mdWidth / 2 - TextWidth / 2 Case sbrRight x1 = mdWidth - TextWidth - gGap * 2 End Select y1 = mPanel.Height / 2 - TextHeight / 2 mPanel.CurrentX = x1: mPanel.CurrentY = y1 mPanel.Print msText mPanel.Line (0, 0)-Step(mPanel.ScaleWidth - 15, 0), ColorTopLeft mPanel.Line (0, 0)-Step(0, mPanel.ScaleHeight - 15), ColorTopLeft mPanel.Line (0, mPanel.ScaleHeight - 15)-Step(mPanel.ScaleWidth - 15, 0), ColorBottomRight mPanel.Line (mPanel.ScaleWidth - 15, 0)-Step(0, mPanel.ScaleHeight - 15), ColorBottomRight 'scrcopy nResult = BitBlt(mpicParent.hDC, mdLeft / Screen.TwipsPerPixelX, Top / Screen.TwipsPerPixelY, mPanel.Width, mPanel.Height, mPanel.hDC, 0, 0, &HCC0020) If Err.Number > 0 Then Err.Clear End Sub Public Property Let Enabled(Value As Boolean) Dim RefreshRequired As Boolean RefreshRequired = mbEnabled <> Value mbEnabled = Value If RefreshRequired Then Refresh End Property Public Property Get Enabled() As Boolean Enabled = mbEnabled End Property Public Property Get Height() As Single If Not mpicParent Is Nothing Then Height = mpicParent.Height - gGap * 2 End If End Property Public Property Let Key(Value As String) msKey = Value End Property Public Property Get Key() As String Key = msKey End Property Public Property Let Left(Value As Single) mdLeft = Value End Property Public Property Get Left() As Single Left = mdLeft End Property Public Property Let MinWidth(Value As Single) mdMinWidth = Value End Property Public Property Get MinWidth() As Single MinWidth = mdMinWidth End Property Public Property Set Parent(Value As Object) Set mpicParent = Value End Property Public Property Get Parent() As Object Set Parent = mpicParent End Property Public Property Set Picture(Value As Picture) Set mPic = Value End Property Public Property Get Picture() As Picture Set Picture = mPic End Property Public Sub Refresh() If Not mpicParent Is Nothing Then If mpicParent.Visible And mpicParent.Enabled And mbVisible Then DrawPanel End If End Sub Public Property Let Style(Value As Byte) Dim RefreshRequired As Boolean If Value < sbrText Or Value > sbrDate Then Value = sbrText RefreshRequired = mbStyle <> Value If Value <> mbStyle Then With frmStatusRes Select Case mbStyle Case sbrCaps Set .CapLock = Nothing Case sbrNum Set .NumLock = Nothing Case sbrIns Set .InsLock = Nothing Case sbrScrl Set .ScrlLock = Nothing Case sbrTime Set .Timer = Nothing Case sbrDate Set .DateTimer = Nothing End Select Select Case Value Case sbrText mbStyle = Value Case sbrCaps If .CapLock Is Nothing Then Set .CapLock = Me msText = "CAPS" mbStyle = Value End If Case sbrNum If .NumLock Is Nothing Then Set .NumLock = Me msText = "NUM" mbStyle = Value End If Case sbrIns If .InsLock Is Nothing Then Set .InsLock = Me msText = "INS" mbStyle = Value End If Case sbrScrl If .ScrlLock Is Nothing Then Set .ScrlLock = Me msText = "SCRL" mbStyle = Value End If Case sbrTime If .Timer Is Nothing Then Set .Timer = Me .Timer1.Enabled = True mbStyle = Value End If Case sbrDate If .DateTimer Is Nothing Then Set .DateTimer = Me .Timer1.Enabled = True mbStyle = Value End If End Select End With End If If RefreshRequired And Not mpicParent Is Nothing Then mpicParent.Refresh End If End Property Public Property Get Style() As Byte Style = mbStyle End Property Public Property Let Text(Value As String) Dim RefreshRequired As Boolean RefreshRequired = msText <> Value msText = Value If mbAutoSize = sbrContents Then mdWidth = mpicParent.TextWidth(msText) + gGap * 4 RefreshRequired = False End If If RefreshRequired Then Refresh End Property Public Property Get Text() As String Text = msText End Property Private Property Get TextWidth() As Single TextWidth = mpicParent.TextWidth(msText) End Property Private Property Get TextHeight() As Single TextHeight = mpicParent.TextHeight(msText) End Property Public Property Get Top() As Single Top = gGap End Property Public Property Let Visible(Value As Boolean) Dim RefreshRequired As Boolean RefreshRequired = mbVisible <> Value mbVisible = Value If RefreshRequired And Not mpicParent Is Nothing Then mpicParent.Refresh End If End Property Public Property Get Visible() As Boolean Visible = mbVisible End Property Public Property Let Width(Value As Single) Dim RefreshRequired As Boolean If Value < mdMinWidth Then Value = mdMinWidth RefreshRequired = mdWidth <> Value mdWidth = Value If RefreshRequired And Not mpicParent Is Nothing Then mpicParent.Refresh End If End Property Public Property Get Width() As Single Width = mdWidth End Property
