vbAccelerator - Contents of code file: frmBitmapDialog.frm

VERSION 5.00
Begin VB.Form frmBitmapDialog 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Confirm Registration"
   ClientHeight    =   4020
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   5310
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmBitmapDialog.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4020
   ScaleWidth      =   5310
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdOK 
      Caption         =   "OK"
      Default         =   -1  'True
      Height          =   435
      Left            =   2640
      Style           =   1  'Graphical
      TabIndex        =   9
      Top             =   3420
      Width           =   1275
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "Cancel"
      Height          =   435
      Left            =   4020
      Style           =   1  'Graphical
      TabIndex        =   8
      Top             =   3420
      Width           =   1275
   End
   Begin VB.TextBox txtPhone 
      Appearance      =   0  'Flat
      ForeColor       =   &H00000000&
      Height          =   375
      Left            =   1200
      MultiLine       =   -1  'True
      TabIndex        =   7
      Top             =   2880
      Width           =   4095
   End
   Begin VB.TextBox txtAddress 
      Appearance      =   0  'Flat
      ForeColor       =   &H00000000&
      Height          =   1335
      Left            =   1200
      MultiLine       =   -1  'True
      TabIndex        =   5
      Top             =   1140
      Width           =   4095
   End
   Begin VB.TextBox txtLastName 
      Appearance      =   0  'Flat
      ForeColor       =   &H00000000&
      Height          =   375
      Left            =   1200
      MultiLine       =   -1  'True
      TabIndex        =   3
      Top             =   600
      Width           =   4095
   End
   Begin VB.TextBox txtFirstName 
      Appearance      =   0  'Flat
      ForeColor       =   &H00000000&
      Height          =   375
      Left            =   1200
      MultiLine       =   -1  'True
      TabIndex        =   1
      Top             =   120
      Width           =   4095
   End
   Begin VB.Label lblPhone 
      BackStyle       =   0  'Transparent
      Caption         =   "&Phone"
      ForeColor       =   &H00000000&
      Height          =   315
      Left            =   120
      TabIndex        =   6
      Top             =   2940
      Width           =   915
   End
   Begin VB.Label lblAddress 
      BackStyle       =   0  'Transparent
      Caption         =   "&Address:"
      ForeColor       =   &H00000000&
      Height          =   315
      Left            =   120
      TabIndex        =   4
      Top             =   1200
      Width           =   915
   End
   Begin VB.Label lblLastName 
      BackStyle       =   0  'Transparent
      Caption         =   "&Last Name:"
      ForeColor       =   &H00000000&
      Height          =   315
      Left            =   120
      TabIndex        =   2
      Top             =   660
      Width           =   915
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "&First Name:"
      ForeColor       =   &H00000000&
      Height          =   315
      Left            =   120
      TabIndex        =   0
      Top             =   180
      Width           =   915
   End
End
Attribute VB_Name = "frmBitmapDialog"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private m_cBack() As cTextBoxBackground
Private m_cButtons As cOwnerDrawButton

Implements IOwnerDrawButton

' Functions for drawing the buttons:
Private Type RECT
   left As Long
   tOp As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal
 nBkMode As Long) As Long
    Private Const OPAQUE = 2
    Private Const TRANSPARENT = 1

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 Const DT_BOTTOM = &H8
    Private Const DT_CENTER = &H1
    Private Const DT_LEFT = &H0
    Private Const DT_CALCRECT = &H400
    Private Const DT_WORDBREAK = &H10
    Private Const DT_VCENTER = &H4
    Private Const DT_TOP = &H0
    Private Const DT_TABSTOP = &H80
    Private Const DT_SINGLELINE = &H20
    Private Const DT_RIGHT = &H2
    Private Const DT_NOCLIP = &H100
    Private Const DT_INTERNAL = &H1000
    Private Const DT_EXTERNALLEADING = &H200
    Private Const DT_EXPANDTABS = &H40
    Private Const DT_CHARSTREAM = 4
    Private Const DT_NOPREFIX = &H800
    Private Const DT_WORD_ELLIPSIS = &H40000

Private Type POINTAPI
   x As Long
   y As Long
End Type
   
Private Declare Function LineTo Lib "gdi32" ( _
   ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" ( _
   ByVal hDC As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As
    Long

Private Sub cmdCancel_Click()
   Unload Me
End Sub

Private Sub cmdOK_Click()
   Unload Me
End Sub

Private Sub Form_Load()
   
   txtFirstName.Text = "Lord"
   txtLastName.Text = "Lucan"
   txtAddress.Text = "60 Victoria Embankment," & vbCrLf & "Blackfriars," &
    vbCrLf & "London," & vbCrLf & "EC4Y 0JP" & vbCrLf & "UK"
   txtPhone.Text = "(+44 20) 7325 1000"
   
   Dim backNormal As StdPicture
   Dim backLite As StdPicture
   
   Set backNormal = LoadPicture(App.Path & "\back.bmp")
   Set backLite = LoadPicture(App.Path & "\backlite.bmp")
   
   ' Text Boxes:
   Dim textBoxes As New Collection
   Dim i As Long
   For i = 0 To Me.Controls.Count - 1
      If (TypeName(Me.Controls(i)) = "TextBox") Then
         textBoxes.Add (Me.Controls(i))
      End If
   Next i
   ReDim m_cBack(1 To textBoxes.Count + 2) As cTextBoxBackground
   ' The first items are actually attached to text boxes:
   Dim txt As TextBox
   For i = 1 To textBoxes.Count
      Set m_cBack(i) = New cTextBoxBackground
      m_cBack(i).SetBackdrop backLite
      Set txt = textBoxes(i)
      m_cBack(i).TileOffsetX = txt.left \ Screen.TwipsPerPixelX
      m_cBack(i).TileOffsetY = txt.tOp \ Screen.TwipsPerPixelY
      m_cBack(i).Attach txt.hwnd
   Next i
   ' use the last two items for tiling only (not attached):
   ' dark and pale versions of the bitmap
   Set m_cBack(textBoxes.Count + 1) = New cTextBoxBackground
   m_cBack(textBoxes.Count + 1).SetBackdrop backNormal
   Set m_cBack(textBoxes.Count + 2) = New cTextBoxBackground
   m_cBack(textBoxes.Count + 2).SetBackdrop backLite
   
   ' Buttons:
   Set m_cButtons = New cOwnerDrawButton
   m_cButtons.Attach Me
   m_cButtons.AddhWnd cmdOK.hwnd
   m_cButtons.AddhWnd cmdCancel.hwnd

End Sub


Private Sub Form_Paint()
   ' Draw a dark background:
   m_cBack(UBound(m_cBack) - 1).TileArea Me.hDC, 0, 0, _
      Me.ScaleWidth \ Screen.TwipsPerPixelX, _
      Me.ScaleHeight \ Screen.TwipsPerPixelY
   ' Draw a separator line before the buttons:
   m_cBack(UBound(m_cBack)).TileArea Me.hDC, _
      0, cmdCancel.tOp \ Screen.TwipsPerPixelY - 4, _
      Me.ScaleWidth \ Screen.TwipsPerPixelX, 1
End Sub
 
Private Function ControlForHwnd(ByVal lhWnd As Long) As Control
Dim ctl As Control
   For Each ctl In Controls
      On Error Resume Next
      If (ctl.hwnd = lhWnd) Then
         If (Err.Number = 0) Then
            Set ControlForHwnd = ctl
         End If
      End If
      Err.Clear
      On Error GoTo 0
   Next
End Function

Private Property Get IOwnerDrawButton_ButtonContainerhWnd() As Long
   IOwnerDrawButton_ButtonContainerhWnd = Me.hwnd
End Property

Private Property Get IOwnerDrawButton_DoOwnerDraw(ByVal lhWnd As Long) As
 Boolean
   IOwnerDrawButton_DoOwnerDraw = True
End Property

Private Sub IOwnerDrawButton_DrawItem(ByVal lhWnd As Long, ByVal lHDC As Long,
 lLeft As Long, lTop As Long, lRight As Long, lBottom As Long, ByVal bPushed As
 Boolean, ByVal bChecked As Boolean, ByVal bEnabled As Boolean, ByVal bInFocus
 As Boolean, bDoDefault As Boolean)
   '
   bDoDefault = False
     
   Dim xOffset As Long
   Dim yOffset As Long
   Dim tilerIndex As Long
   
   ' draw light button, up
   tilerIndex = UBound(m_cBack)
   If (bPushed) Then
      ' draw dark button, down
      tilerIndex = tilerIndex - 1
   End If
   
   ' store original offsets:
   xOffset = m_cBack(tilerIndex).TileOffsetX
   yOffset = m_cBack(tilerIndex).TileOffsetX
   
   Dim cmd As Control
   Set cmd = ControlForHwnd(lhWnd)
   
   ' create new offsets:
   m_cBack(tilerIndex).TileOffsetX = cmd.left / Screen.TwipsPerPixelX
   m_cBack(tilerIndex).TileOffsetY = cmd.tOp / Screen.TwipsPerPixelY
   If (bPushed) Then
      m_cBack(tilerIndex).TileOffsetX = m_cBack(tilerIndex).TileOffsetX - 1
      m_cBack(tilerIndex).TileOffsetY = m_cBack(tilerIndex).TileOffsetY - 1
   End If
   
   ' Fill background:
   m_cBack(tilerIndex).TileArea lHDC, lLeft, lTop, lRight - lLeft, lBottom -
    lTop
   
   ' Button edge:
   SetBkMode lHDC, TRANSPARENT
   Dim junk As POINTAPI
   MoveToEx lHDC, lLeft, lTop, junk
   LineTo lHDC, lRight - 1, lTop
   LineTo lHDC, lRight - 1, lBottom - 1
   LineTo lHDC, lLeft, lBottom - 1
   LineTo lHDC, lLeft, lTop
   
   ' Draw Text:
   Dim tR As RECT
   tR.left = lLeft
   tR.Right = lRight
   tR.tOp = lTop
   tR.Bottom = lBottom
   If (bPushed) Then
      tR.left = tR.left + 1
      tR.tOp = tR.tOp + 1
      tR.Right = tR.Right + 1
      tR.Bottom = tR.Bottom + 1
   End If
   DrawText lHDC, cmd.Caption, -1, tR, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
   
   ' return offsets:
   m_cBack(tilerIndex).TileOffsetX = xOffset
   m_cBack(tilerIndex).TileOffsetX = yOffset
   
End Sub