愚者の経験

「また今度」はほとんどこない

日別アーカイブ: 6月 21, 2012

WaterMarkクラス

Ajax Toolkit にあった「WaterMark」エクステンド。空白のテキストボックスの上にテキストを出し
入力時に消えるというこの動作はフォームのレイアウト的に魅力です。

これと同じような動作をするクラスを作成してみます。

Option Explicit

Private Type RECT
    rtLeft As Long
    rtTop As Long
    rtRight As Long
    rtBottom As Long
End Type

Private Declare Function GetWindowDC Lib "user32" ( _
                ByVal Hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowRect Lib "user32" ( _
                ByVal Hwnd As Long, _
                ByRef lpRect As RECT) As Long

Private Declare Function DrawText Lib "user32" _
                Alias "DrawTextA" ( _
                ByVal hDC As Long, _
                ByVal lpString As String, _
                ByVal nCount As Long, _
                ByRef lpRect As RECT, _
                ByVal uFormat As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" ( _
                ByVal hDC As Long, _
                ByVal crColor As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" ( _
                ByRef lpLogBrush As LOGBRUSH) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" _
                Alias "CreateFontIndirectA" ( _
                ByRef lpLogFont As LOGFONT) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
                ByVal hDC As Long, _
                ByVal nIndex As Long) As Long
Private Declare Function SelectObject Lib "gdi32" ( _
                ByVal hDC As Long, _
                ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
                ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32" ( _
                ByVal hDC As Long, _
                lpRect As RECT, _
                ByVal hBrush As Long) As Long

Private Const LF_FACESIZE = 32
Private Const FW_NORMAL = 400
Private Type LOGFONT
    lfHeight          As Long
    lfWidth           As Long
    lfEscapement      As Long
    lfOrientation     As Long
    lfWeight          As Long
    lfItalic          As Byte
    lfUnderline       As Byte
    lfStrikeOut       As Byte
    lfExpressionSet   As Byte
    lfOutPrecision    As Byte
    lfClipPrecision   As Byte
    lfQuality         As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type

Private Const DT_SINGLELINE = &H20
Private Const DT_NOCLIP = &H100
Private Const DT_LEFT = &H0
Private Const DT_CENTER = &H1
Private Const DT_RIGHT = &H2
Private Const DT_VCENTER = &H4 Or DT_SINGLELINE
Private Const DT_TOP = &H0
Private Const DT_BOTTOM = &H8 Or DT_SINGLELINE

Private Const POINT_PER_INCH = 72
Private Const LOGPIXELSY = 90

Private pTarget As Control
Private WithEvents txt As TextBox
Private WithEvents cbo As ComboBox
Private WithEvents Parent As Form
Private html As Object

Private TargetRECT As RECT
Private MarkFont As LOGFONT
Private MarkBrush As LOGBRUSH
Private MarkText As String
Private IsMark As Boolean
Private fColor As Long
Private bColor As Long
Private fName()  As Byte
Private hFont As Long
Private hBrush As Long
Private TextFormat As Long

Private Sub Class_Initialize()
    IsMark = False
    MarkText = ""
    Set html = CreateObject("htmlfile")
    Set html.parentWindow.onhelp = Me
End Sub

Private Sub Class_Terminate()
    Set pTarget = Nothing
    Set Parent = Nothing
    Set html.parentWindow.onhelp = Nothing
    Set html = Nothing
    Set cbo = Nothing
    Set txt = Nothing
    DeleteObject hFont
    DeleteObject hBrush
End Sub

Public Sub Bind(Target As Control, WaterText As String, _
                Optional FontSize As Variant, _
                Optional FontName As Variant, _
                Optional hTextAlign As Byte = 1, _
                Optional vTextAlign As Byte = 1, _
                Optional FontColor As Long = 10197915)
    Dim hAlign As Long
    Dim vAlign As Long

    Set pTarget = Target

    If (pTarget.ControlType = acTextBox) Then
        Set txt = pTarget
    Else
        Set cbo = pTarget
    End If

    With pTarget
        Set Parent = CodeContextObject
        GetWindowRect Parent.Hwnd, TargetRECT

        Parent.OnCurrent = "[イベント プロシージャ]"
        Parent.OnResize = "[イベント プロシージャ]"
        .OnExit = "[イベント プロシージャ]"
        .OnEnter = "[イベント プロシージャ]"

        fColor = FontColor

        If (IsMissing(FontName) = True) Then
            FontName = .FontName
        End If

        If (IsMissing(FontSize) = True) Then
            FontSize = .FontSize
        End If

        If (Parent.RecordSelectors = False) Then
            TargetRECT.rtLeft = .Left / 15
        Else
            TargetRECT.rtLeft = .Left / 15 + 20
        End If

        If (Parent.PopUp = True) Then
            TargetRECT.rtTop = .Top / 15 + 25
            TargetRECT.rtLeft = TargetRECT.rtLeft + 4
        Else
            TargetRECT.rtTop = .Top / 15
        End If
        TargetRECT.rtRight = TargetRECT.rtLeft + .Width / 15 - 4
        TargetRECT.rtBottom = TargetRECT.rtTop + .Height / 15 - 2

    End With

    MarkText = WaterText

    Dim i As Long
    With MarkFont
        fName() = StrConv(FontName, vbFromUnicode)
        For i = 0 To UBound(fName)
            .lfFaceName(i) = fName(i)
        Next
        .lfWeight = FW_NORMAL
        .lfExpressionSet = 1
        .lfHeight = FontSize * _
                        (GetDeviceCaps(GetWindowDC(Parent.Hwnd), LOGPIXELSY) / POINT_PER_INCH)
        .lfItalic = 0
        .lfStrikeOut = 0
        .lfUnderline = 0
    End With
    hFont = CreateFontIndirect(MarkFont)

    Select Case hTextAlign
        Case 0
            hAlign = DT_CENTER
        Case 1
            hAlign = DT_LEFT
        Case 2
            hAlign = DT_RIGHT
        Case Else
            hAlign = DT_CENTER
    End Select

    Select Case vTextAlign
        Case 0
            vAlign = DT_VCENTER
        Case 1
            vAlign = DT_TOP
        Case 2
            vAlign = DT_BOTTOM
        Case Else
            vAlign = DT_VCENTER
    End Select
    TextFormat = hAlign Or vAlign Or DT_NOCLIP

    Appearance
End Sub

Private Sub Parent_Current()
    Appearance
End Sub

Private Sub Parent_Resize()
    LazyAppearance
End Sub

Public Sub Appearance()
On Error Resume Next
    Dim hDC As Long
    With pTarget
        hDC = GetWindowDC(Parent.Hwnd)
        SetTextColor hDC, fColor
        SelectObject hDC, hFont

        If (Nz(.Value, "") = "") Then
            DrawText hDC, MarkText, -1, TargetRECT, TextFormat
        End If
    End With
End Sub

Private Sub LazyAppearance()
    html.parentWindow.setTimeout "onhelp.Appearance", 0, "VBScript"
End Sub

Private Sub txt_Enter()
    If (Nz(pTarget.Value, "") = "") Then
        DoEvents
    End If
End Sub

Private Sub txt_Exit(Cancel As Integer)
    LazyAppearance
End Sub

Private Sub cbo_Enter()
    If (Nz(pTarget.Value, "") = "") Then
        DoEvents
    End If
End Sub

Private Sub cbo_Exit(Cancel As Integer)
    LazyAppearance
End Sub

最初ExitとEnterイベントでテキストボックス等に直接文字を入れて表示しようとしたら
コントロールソースが数値型の場合に弾かれました…当たり前ですよね。

結局APIのDrowText関数でコントロールの矩形に描画しています。
コントロール内にフォーカスが入った時に再描画がかかるお陰で描画したテキストは
フォーカス時に消えてくれます。

本当は背景色も設定できればいいと思うんですがわかりません…
文字列の透過方法もわかりませんでしたm(__)m
また最小化した後に表示したイベントも順当な方法でつかむことができませんでした。

こんな感じで使います。

Option Explicit

Private WaterMarks() As c_WaterMark

Private Sub Form_Load()
    ReDim WaterMarks(1)

    Set WaterMarks(0) = New c_WaterMark
    Set WaterMarks(1) = New c_WaterMark

    WaterMarks(0).Bind Me.text1, "ID入力"
    WaterMarks(1).Bind Me.text2, "IDなし"

End Sub

WaterMarkのテスト

広告