panel3d.ctl

图形界面面板

VERSION 5.00
Begin VB.UserControl Panel3D 
   Alignable       =   -1  'True
   AutoRedraw      =   -1  'True
   BackColor       =   &H00C0C0C0&
   ClientHeight    =   1485
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   3255
   ControlContainer=   -1  'True
   DrawStyle       =   6  'Inside Solid
   PropertyPages   =   "Panel3D.ctx":0000
   ScaleHeight     =   1485
   ScaleWidth      =   3255
   ToolboxBitmap   =   "Panel3D.ctx":0032
   Begin VB.PictureBox picBuffer 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      Height          =   615
      Left            =   270
      ScaleHeight     =   615
      ScaleWidth      =   1530
      TabIndex        =   0
      TabStop         =   0   'False
      Top             =   480
      Visible         =   0   'False
      Width           =   1530
   End
End
Attribute VB_Name = "Panel3D"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Option Explicit

'RichLabel 控制符定义:
'\CR        回车,换行
'\FN?.      字体名,以"."结束
'\FSnn      字体大小
'\BT        粗体
'\BF        取消粗体
'\IT        斜体
'\IF        取消斜体
'\UT        下划线
'\UF        取消下划线
'\DT        删除线
'\DF        取消删除线
'\FCnn      前景色,00-15

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

Private Const cVersion As String = "March,17 1998"

Private mAlign As Integer
Private mLoading As Boolean
Private mCaption As String
Private mRichLabel As String
Private mRLCaption As String
Private mAlignment As PositionConstants
Private mFont3D As Font3DConstants
Private mBackColor As OLE_COLOR
Private mForeColor As OLE_COLOR
Private mBorderColor As OLE_COLOR
Private mShadowColor As OLE_COLOR
Private mFloodColor As OLE_COLOR
Private mEnabled As Boolean
Private mVisible As Boolean
Private mOutLine As Boolean
Private mBevelInner As Control3DConstants
Private mBevelOuter As Control3DConstants
Private mBevelWidth As Integer
Private mBorderWidth As Integer
Private mPercents As Integer
Private mWordBorderDistance As Integer
Private mLinesDistance As Integer

Private L As Integer
Private T As Integer
Private W As Integer
Private H As Integer
Private DisabledColor As Long

Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event Click()
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event Resize()

Private Sub UserControl_InitProperties()
  mLoading = True

  RichLabel = False
  Caption = Extender.Name
  RLCaption = ""
  Alignment = posCenterMiddle

  Set Font = Ambient.Font
  Font3D = f3dRaisedLight

  BackColor = &HC0C0C0
  ForeColor = &H0&
  BorderColor = &HC0C0C0
  ShadowColor = &H808080

  OutLine = False
  BevelInner = c3dNone
  BevelOuter = c3dRaised
  BevelWidth = 1
  BorderWidth = 0
  mPercents = -1
  
  WordBorderDistance = 0
  LinesDistance = 0
  
  Enabled = True
  Visible = True

  mLoading = False
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  mLoading = True

  On Error Resume Next

  mAlign = PropBag.ReadProperty("Align", 0)
  Caption = PropBag.ReadProperty("Caption", Extender.Name)
  RichLabel = PropBag.ReadProperty("RichLabel", False)
  RLCaption = PropBag.ReadProperty("RLCaption", "")
  Alignment = PropBag.ReadProperty("Alignment", posCenterMiddle)

  Set Font = PropBag.ReadProperty("Font", Ambient.Font)
  Font3D = PropBag.ReadProperty("Font3D", f3dRaisedLight)

  BackColor = PropBag.ReadProperty("BackColor", &HC0C0C0)
  ForeColor = PropBag.ReadProperty("ForeColor", &H0&)
  BorderColor = PropBag.ReadProperty("BorderColor", &HC0C0C0)
  ShadowColor = PropBag.ReadProperty("ShadowColor", &H808080)
  FloodColor = PropBag.ReadProperty("FloodColor", &HFF0000)

  OutLine = PropBag.ReadProperty("OutLine", False)
  BevelInner = PropBag.ReadProperty("BevelInner", c3dNone)
  BevelOuter = PropBag.ReadProperty("BevelOuter", c3dRaised)
  BevelWidth = PropBag.ReadProperty("BevelWidth", 1)
  BorderWidth = PropBag.ReadProperty("BorderWidth", 0)

  WordBorderDistance = PropBag.ReadProperty("WordBorderDistance", 0)
  LinesDistance = PropBag.ReadProperty("LinesDistance", 0)
  
  Enabled = PropBag.ReadProperty("Enabled", True)
  Visible = PropBag.ReadProperty("Visible", True)

  UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0)
  Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
  
  mLoading = False
  
  Refresh
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  PropBag.WriteProperty "Version", cVersion
  
  PropBag.WriteProperty "Align", mAlign
  PropBag.WriteProperty "Caption", mCaption
  PropBag.WriteProperty "RichLabel", mRichLabel
  PropBag.WriteProperty "RLCaption", mRLCaption
  PropBag.WriteProperty "Alignment", mAlignment
  
  PropBag.WriteProperty "Font", UserControl.Font
  PropBag.WriteProperty "Font3D", mFont3D
  
  PropBag.WriteProperty "BackColor", mBackColor
  PropBag.WriteProperty "ForeColor", mForeColor
  PropBag.WriteProperty "BorderColor", mBorderColor
  PropBag.WriteProperty "ShadowColor", mShadowColor
  PropBag.WriteProperty "FloodColor", mFloodColor
  
  PropBag.WriteProperty "OutLine", mOutLine
  PropBag.WriteProperty "BevelInner", mBevelInner
  PropBag.WriteProperty "BevelOuter", mBevelOuter
  PropBag.WriteProperty "BevelWidth", mBevelWidth
  PropBag.WriteProperty "BorderWidth", mBorderWidth
  
  PropBag.WriteProperty "WordBorderDistance", mWordBorderDistance
  PropBag.WriteProperty "LinesDistance", mLinesDistance
  
  PropBag.WriteProperty "Enabled", mEnabled
  PropBag.WriteProperty "Visible", mVisible
  
  PropBag.WriteProperty "MousePointer", UserControl.MousePointer
  PropBag.WriteProperty "MouseIcon", MouseIcon
End Sub

Private Sub UserControl_Resize()
  RaiseEvent Resize
  Refresh
End Sub

Public Sub Refresh()
Attribute Refresh.VB_UserMemId = -550
  Dim I As Integer
  Dim N As Integer
  Dim S As Integer
  Dim Length As Integer
  Dim LCap As Integer
  Dim TCap As Integer
  Dim WCap As Integer
  Dim HCap As Integer
  Dim Msg As String
  
  Dim FN As String
  Dim FNLen As Integer
  Dim NextY As Integer
  Dim RowHeight As Integer
  Dim Ch As String
  Dim ChW As Integer
  Dim ChH As Integer
  Dim HCopy As Integer
  
  On Error Resume Next
  
  If mLoading Or (Not mVisible) Then Exit Sub
  
  DisabledColor = IIf(mEnabled, 0, &H808080)
  
  With UserControl
    .Cls
    .BackColor = mBackColor Or DisabledColor
    L = 0
    T = 0
    W = .Width
    H = .Height
    ReduceDrawArea 15 * (IIf(mOutLine, 1, 0) + IIf(mBevelOuter > c3dNone, mBevelWidth, 0) + mBorderWidth + _
      IIf(mBevelInner > c3dNone, mBevelWidth, 0) + WordBorderDistance)
    
    If (W <= 0) Or (H <= 0) Then  'No output
    ElseIf mRichLabel Then    'Rich Label
      With picBuffer
        .Move L, T, W, H
        .FontName = UserControl.FontName
        .FontSize = UserControl.FontSize
        .FontBold = UserControl.FontBold
        .FontItalic = UserControl.FontItalic
        .FontStrikethru = UserControl.FontStrikethru
        .FontUnderline = UserControl.FontUnderline
        .BackColor = UserControl.BackColor Or DisabledColor
        .ForeColor = 0 Or DisabledColor
        .Cls
        NextY = T
        RowHeight = 0
        Msg = mRLCaption
        For I = 1 To Len(Msg)
          Ch = Mid(Msg, I, 1)
          If Ch = "\" Then
            I = I + 1
            Ch = Mid(Msg, I, 1)
            If Ch = "\" Then
              GoTo OutPutCh
            Else
              I = I + 1
              Select Case UCase(Mid(Msg, I - 1, 2))
                Case "CR"
                  HCopy = T + H - NextY
                  If HCopy > RowHeight Then HCopy = RowHeight
                  If HCopy > 0 Then BitBlt UserControl.hDC, L \ 15, NextY \ 15, W \ 15, HCopy \ 15, .hDC, 0, (H - RowHeight) \ 15, &HCC0020
                  .Cls
                  NextY = NextY + RowHeight + LinesDistance * 15
                Case "FN"
                  FN = Mid(Msg, I + 1)
                  N = InStr(FN, ".")
                  If N > 0 Then
                    I = I + N
                    FN = Left(FN, N - 1)
                    FNLen = N - 1
                    For N = 0 To Screen.FontCount - 1
                      If Left(Screen.Fonts(N), FNLen) = FN Then
                        .FontName = Screen.Fonts(N)
                        Exit For
                      End If
                    Next N
                  End If
                Case "FS"
                  .FontSize = Val(Mid(Msg, I + 1, 2))
                  I = I + 2
                Case "BT"
                  .FontBold = True
                Case "BF"
                  .FontBold = False
                Case "IT"
                  .FontItalic = True
                Case "IF"
                  .FontItalic = False
                Case "UT"
                  .FontUnderline = True
                Case "UF"
                  .FontUnderline = False
                Case "DT"
                  .FontStrikethru = True
                Case "DF"
                  .FontStrikethru = False
                Case "FC"
                  N = Val(Mid(Msg, I + 1, 2)) Mod 16
                  .ForeColor = QBColor(N) Or DisabledColor
                  I = I + 2
                Case Else
              End Select
            End If
          Else
OutPutCh:
            ChW = .TextWidth(Ch)
            ChH = .TextHeight(Ch)
            If W < ChW Then
              Exit For
            ElseIf W - .CurrentX < ChW Then
              HCopy = T + H - NextY
              If HCopy > RowHeight Then HCopy = RowHeight
              If HCopy > 0 Then BitBlt UserControl.hDC, L \ 15, NextY \ 15, W \ 15, HCopy \ 15, .hDC, 0, (H - RowHeight) \ 15, &HCC0020
              .Cls
              NextY = NextY + RowHeight + LinesDistance * 15
            End If
            If RowHeight < ChH Then RowHeight = ChH
            .CurrentY = H - ChH
            picBuffer.Print Ch;
          End If
        Next I
        HCopy = T + H - NextY
        If HCopy > RowHeight Then HCopy = RowHeight
        If HCopy > 0 Then BitBlt UserControl.hDC, L \ 15, NextY \ 15, W \ 15, HCopy \ 15, .hDC, 0, (H - RowHeight) \ 15, &HCC0020
      End With
    Else  'Panel3D
      If mPercents > 0 Then UserControl.Line (L, T)-Step(W * (mPercents / 100), H), mFloodColor, BF
      
      HCap = .TextHeight(mCaption)
      
      Select Case mAlignment
        Case posLeftTop, posCenterTop, posRightTop
          TCap = T + 30
        Case posLeftMiddle, posCenterMiddle, posRightMiddle
          TCap = T + RoundToPixel((H - HCap) / 2)
        Case posLeftBottom, posCenterBottom, posRightBottom
          TCap = T - 30 + (H - HCap)
      End Select
  
      S = 1
      Length = Len(mCaption)
      Do
        N = InStr(S, mCaption, vbCrLf)
        If N = 0 Then
          Msg = Mid(mCaption, S)
          S = Length + 1
        Else
          Msg = Mid(mCaption, S, N - S)
          S = N + 2
        End If
        If Len(Msg) > 0 Then
          WCap = .TextWidth(Msg)
          Select Case mAlignment
            Case posLeftTop, posLeftMiddle, posLeftBottom
              LCap = L + 30
            Case posCenterTop, posCenterMiddle, posCenterBottom
              LCap = L + RoundToPixel((W - WCap) / 2)
            Case posRightTop, posRightMiddle, posRightBottom
              LCap = L - 30 + (W - WCap)
          End Select
          
          Select Case mFont3D
            Case f3dNormal
              .CurrentX = LCap
              .CurrentY = TCap
              .ForeColor = mForeColor Or DisabledColor
              UserControl.Print Msg
            Case f3dRaisedLight
              For I = 1 To 2
                .CurrentX = LCap + Choose(I, -15, 0)
                .CurrentY = TCap + Choose(I, -15, 0)
                .ForeColor = Choose(I, &HFFFFFF, mForeColor) Or DisabledColor
                UserControl.Print Msg
              Next I
            Case f3dRaisedHeavy
              For I = 1 To 3
                .CurrentX = LCap + Choose(I, -15, 15, 0)
                .CurrentY = TCap + Choose(I, -15, 15, 0)
                .ForeColor = Choose(I, &HFFFFFF, &H808080, mForeColor) Or DisabledColor
                UserControl.Print Msg
              Next I
            Case f3dInsertLight
              For I = 1 To 2
                .CurrentX = LCap + Choose(I, 15, 0)
                .CurrentY = TCap + Choose(I, 15, 0)
                .ForeColor = Choose(I, &HFFFFFF, mForeColor) Or DisabledColor
                UserControl.Print Msg
              Next I
            Case f3dInsertHeavy
              For I = 1 To 3
                .CurrentX = LCap + Choose(I, -15, 15, 0)
                .CurrentY = TCap + Choose(I, -15, 15, 0)
                .ForeColor = Choose(I, &H808080, &HFFFFFF, mForeColor) Or DisabledColor
                UserControl.Print Msg
              Next I
            Case f3dShadowAround
              For I = 1 To 5
                .CurrentX = LCap + Choose(I, 0, 15, 0, -15, 0)
                .CurrentY = TCap + Choose(I, -15, 0, 15, 0, 0)
                .ForeColor = IIf(I = 5, mForeColor, mShadowColor) Or DisabledColor
                UserControl.Print Msg
              Next I
          End Select
        End If
        TCap = TCap + .TextHeight("T")
      Loop Until S > Length
    End If
    
    L = 0
    T = 0
    W = .Width
    H = .Height
    
    If mOutLine Then
      .DrawWidth = 1
      UserControl.Line (L, T)-Step(W - 15, H - 15), &H0&, B
      ReduceDrawArea 15
    End If
  
    Box3D mBevelOuter, mBevelWidth
        
    If mBorderWidth > 0 Then
      .DrawWidth = mBorderWidth
      UserControl.Line (L, T)-Step(W - 15, H - 15), mBorderColor Or DisabledColor, B
      ReduceDrawArea 15 * mBorderWidth
    End If
  
    Box3D mBevelInner, mBevelWidth
    
    .Refresh