home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD170713142001.psc / StatusBar.ctl (.txt) < prev   
Encoding:
Visual Basic Form  |  2001-03-10  |  6.8 KB  |  182 lines
  1. VERSION 5.00
  2. Begin VB.UserControl StatusBar 
  3.    Alignable       =   -1  'True
  4.    ClientHeight    =   3600
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   4800
  8.    ScaleHeight     =   240
  9.    ScaleMode       =   3  'Pixel
  10.    ScaleWidth      =   320
  11.    Begin VB.PictureBox picField 
  12.       BorderStyle     =   0  'Kein
  13.       FillColor       =   &H8000000F&
  14.       ForeColor       =   &H8000000F&
  15.       Height          =   735
  16.       Index           =   2
  17.       Left            =   0
  18.       ScaleHeight     =   49
  19.       ScaleMode       =   3  'Pixel
  20.       ScaleWidth      =   161
  21.       TabIndex        =   3
  22.       Top             =   1800
  23.       Width           =   2415
  24.       Begin VB.Label labField 
  25.          Height          =   375
  26.          Index           =   2
  27.          Left            =   240
  28.          TabIndex        =   4
  29.          Top             =   0
  30.          Width           =   1215
  31.       End
  32.    End
  33.    Begin VB.PictureBox picField 
  34.       AutoRedraw      =   -1  'True
  35.       BorderStyle     =   0  'Kein
  36.       FillColor       =   &H8000000D&
  37.       ForeColor       =   &H80000008&
  38.       Height          =   735
  39.       Index           =   1
  40.       Left            =   0
  41.       ScaleHeight     =   49
  42.       ScaleMode       =   3  'Pixel
  43.       ScaleWidth      =   98
  44.       TabIndex        =   2
  45.       Top             =   960
  46.       Width           =   1470
  47.    End
  48.    Begin VB.PictureBox picField 
  49.       BorderStyle     =   0  'Kein
  50.       FillColor       =   &H8000000F&
  51.       ForeColor       =   &H8000000F&
  52.       Height          =   735
  53.       Index           =   0
  54.       Left            =   0
  55.       ScaleHeight     =   49
  56.       ScaleMode       =   3  'Pixel
  57.       ScaleWidth      =   97
  58.       TabIndex        =   0
  59.       Top             =   120
  60.       Width           =   1455
  61.       Begin VB.Label labField 
  62.          Height          =   375
  63.          Index           =   0
  64.          Left            =   240
  65.          TabIndex        =   1
  66.          Top             =   120
  67.          Width           =   1215
  68.       End
  69.    End
  70. Attribute VB_Name = "StatusBar"
  71. Attribute VB_GlobalNameSpace = False
  72. Attribute VB_Creatable = True
  73. Attribute VB_PredeclaredId = False
  74. Attribute VB_Exposed = False
  75. Private Type RECT
  76.         Left As Long
  77.         Top As Long
  78.         Right As Long
  79.         Bottom As Long
  80. End Type
  81. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  82. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  83. 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
  84. 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
  85. Private m_Status As Double
  86. Private m_Rect As RECT
  87. Private m_StatusText As String
  88. Private Const GWL_EXSTYLE = (-20)
  89. Private Sub picField_Resize(Index As Integer)
  90.     With picField(Index)
  91.         If Index = 1 Then
  92.             UpdateStatus
  93.         Else
  94.             labField(Index).Move 1, 1, .ScaleWidth - 2, .ScaleHeight - 2
  95.         End If
  96.     End With
  97. End Sub
  98. Private Sub UserControl_Initialize()
  99.     'this is just for the thin inset-effect
  100.     For I = 0 To 2
  101.         SetWindowLong picField(I).hWnd, GWL_EXSTYLE, GetWindowLong(picField(I).hWnd, GWL_EXSTYLE) Or &H8000
  102.     Next I
  103. End Sub
  104. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  105.     m_Status = PropBag.ReadProperty("Status", 0)
  106.     m_StatusText = PropBag.ReadProperty("StatusText", "")
  107.     labField(0).Caption = PropBag.ReadProperty("Label1", "")
  108.     labField(2).Caption = PropBag.ReadProperty("Label2", "")
  109.     UpdateStatus
  110. End Sub
  111. Private Sub UserControl_Resize()
  112.         picField(2).Move ScaleWidth - picField(2).Width, 0, picField(2).Width, ScaleHeight
  113.         picField(1).Move picField(2).Left - picField(1).Width - 2, 0, picField(1).Width, ScaleHeight
  114.         picField(0).Move 0, 0, picField(1).Left - 2, ScaleHeight
  115. End Sub
  116. Public Property Get Status() As Double
  117.     Status = m_Status
  118. End Property
  119. Public Property Let Status(ByVal NewStatus As Double)
  120.     m_Status = NewStatus
  121.     If m_Status < 0 Then m_Status = 0
  122.     If m_Status > 100 Then m_Status = 100
  123.     PropertyChanged "Status"
  124.     UpdateStatus
  125. End Property
  126. Public Property Get Label1() As String
  127. Attribute Label1.VB_ProcData.VB_Invoke_Property = ";Text"
  128. Attribute Label1.VB_UserMemId = -517
  129.     Label1 = labField(0).Caption
  130. End Property
  131. Public Property Let Label1(ByVal newValue As String)
  132.     labField(0).Caption = newValue
  133.     labField(0).Refresh
  134.     PropertyChanged "Label1"
  135. End Property
  136. Public Property Get StatusText() As String
  137.     StatusText = m_StatusText
  138. End Property
  139. Public Property Let StatusText(ByVal newValue As String)
  140.     m_StatusText = newValue
  141.     UpdateStatus
  142.     PropertyChanged "StatusText"
  143. End Property
  144. Public Property Get Label2() As String
  145. Attribute Label2.VB_ProcData.VB_Invoke_Property = ";Text"
  146. Attribute Label2.VB_UserMemId = -518
  147.     Label2 = labField(2).Caption
  148. End Property
  149. Public Property Let Label2(ByVal newValue As String)
  150.     labField(2).Caption = newValue
  151.     labField(2).Refresh
  152.     PropertyChanged "Label2"
  153. End Property
  154. Private Sub UpdateStatus()
  155.     Dim X As Long, Y As Long, W As Long, H As Long
  156.     m_Rect.Left = 0
  157.     m_Rect.Top = 0
  158.     m_Rect.Right = picField(1).ScaleWidth
  159.     m_Rect.Bottom = picField(1).ScaleHeight
  160.     X = 2: Y = 2
  161.     W = (picField(1).ScaleWidth - 4) * m_Status / 100
  162.     H = picField(1).ScaleHeight - 4
  163.     picField(1).Cls
  164.     If m_Status > 0 Then picField(1).Line (X, Y)-(W + X - 1, H + Y - 1), &H8000000D, BF
  165.     If Len(m_StatusText) > 0 Then
  166.         'this is to invert the part of the text over the dark StatusBar;
  167.         'it inverts the StatusBar, draws the Text on it, and inverts the
  168.         'Bar again. This way the Bar didn't change, whereas the Text is
  169.         'inverted.
  170.         If m_Status > 0 Then BitBlt picField(1).hdc, X, Y, W, H, picField(1).hdc, 0, 0, vbDstInvert
  171.         DrawText picField(1).hdc, m_StatusText, Len(m_StatusText), m_Rect, &H25
  172.         If m_Status > 0 Then BitBlt picField(1).hdc, X, Y, W, H, picField(1).hdc, 0, 0, vbDstInvert
  173.     End If
  174.     picField(1).Refresh
  175. End Sub
  176. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  177.     Call PropBag.WriteProperty("Status", m_Status, 0)
  178.     Call PropBag.WriteProperty("StatusText", m_StatusText, "")
  179.     Call PropBag.WriteProperty("Label1", labField(0).Caption, "")
  180.     Call PropBag.WriteProperty("Label2", labField(2).Caption, "")
  181. End Sub
  182.