介面開發之Flat3DButton

40Star發表於2020-04-04

自己是否想過重畫控制元件，現在用強大的VB來實現吧。

下例就是簡單的利用VB中的CommandButton改變成Flat3DButton風格。其實就是利用VB的SubClass去處理父視窗的WM_DRAWITEM訊息。

1. 建立一個標準EXE工程，加入Command1和Command2，將Command1的Style屬性設為Graphical。

2. 加入模組，取名SubClass_Flat3DButton，貼進程式碼：

Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Copyright 2002 40Star, All Rights Reserved.
'
'E-Mail      ：40Star@163.com
'Distribution：你可以完全自由隨便的使用這段程式碼，不管你用於任何目的
'              程式在於交流和學習
'              如有任何BUG請和我聯絡
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Private Declare Function GetParent Lib "user32" _
(ByVal hWnd As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias _
        "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex _
        As Long, ByVal dwNewLong As Long) As Long

Private Declare Function CallWindowProc Lib "user32" Alias _
        "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal _
        hWnd As Long, ByVal Msg As Long, ByVal wParam As _
        Long, ByVal lParam As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)

Const GWL_WNDPROC = (-4&)

Dim PrevWndProc&

Private Const WM_DESTROY = &H2
Private Const WM_DRAWITEM = &H2B

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type DRAWITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemAction As Long
    itemState As Long
    hwndItem As Long
    hdc As Long
    rcItem As RECT
    itemData As Long
End Type

' Owner draw constants
Private Const ODT_BUTTON = 4
' Owner draw actions
Private Const ODA_DRAWENTIRE = &H1
Private Const ODA_SELECT = &H2
Private Const ODA_FOCUS = &H4
' Owner draw state
Private Const ODS_SELECTED = &H1
Private Const ODS_GRAYED = &H2
Private Const ODS_DISABLED = &H4
Private Const ODS_CHECKED = &H8
Private Const ODS_FOCUS = &H10

Private Declare Function GetWindowText Lib "user32" Alias _
"GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, _
ByVal cch As Long) As Long

'Various GDI painting-related functions
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
' Color Types
Const CTLCOLOR_MSGBOX = 0
Const CTLCOLOR_EDIT = 1
Const CTLCOLOR_LISTBOX = 2
Const CTLCOLOR_BTN = 3
Const CTLCOLOR_DLG = 4
Const CTLCOLOR_SCROLLBAR = 5
Const CTLCOLOR_STATIC = 6
Const CTLCOLOR_MAX = 8 ' three bits max

Const COLOR_SCROLLBAR = 0
Const COLOR_BACKGROUND = 1
Const COLOR_ACTIVECAPTION = 2
Const COLOR_INACTIVECAPTION = 3
Const COLOR_MENU = 4
Const COLOR_WINDOW = 5
Const COLOR_WINDOWFRAME = 6
Const COLOR_MENUTEXT = 7
Const COLOR_WINDOWTEXT = 8
Const COLOR_CAPTIONTEXT = 9
Const COLOR_ACTIVEBORDER = 10
Const COLOR_INACTIVEBORDER = 11
Const COLOR_APPWORKSPACE = 12
Const COLOR_HIGHLIGHT = 13
Const COLOR_HIGHLIGHTTEXT = 14
Const COLOR_BTNFACE = 15
Const COLOR_BTNSHADOW = 16
Const COLOR_GRAYTEXT = 17
Const COLOR_BTNTEXT = 18
Const COLOR_INACTIVECAPTIONTEXT = 19
Const COLOR_BTNHIGHLIGHT = 20

Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function RoundRect Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

'pen Api
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
' Pen Styles
Const PS_SOLID = 0
Const PS_DASH = 1                    ' -------
Const PS_DOT = 2                     ' .......
Const PS_DASHDOT = 3                 ' _._._._
Const PS_DASHDOTDOT = 4              ' _.._.._
Const PS_NULL = 5
Const PS_INSIDEFRAME = 6
Const PS_USERSTYLE = 7
Const PS_ALTERNATE = 8
Const PS_STYLE_MASK = &HF

Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long

Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Type POINTAPI
x As Long
y As Long
End Type

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_SINGLELINE = &H20
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4

Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, _
    ByVal crColor As Long) As Long

Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, _
    ByVal nBkMode As Long) As Long

Private Const TRANSPARENT = 1

Private Sub DrawButton(ByVal hWnd As Long, ByVal hdc As Long, _
rct As RECT, ByVal nState As Long)

   Dim P As POINTAPI
   Dim s As String
   Dim hbr As Long
   Dim hpen As Long

   hbr = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
   SelectObject hdc, hbr
   FillRect hdc, rct, hbr
   DeleteObject hbr

   '畫文字時背景為透明狀
   SetBkMode hdc, TRANSPARENT
   '得到Button的Caption
   s = String$(255, 0)
   GetWindowText hWnd, s, 255
   s = Left$(s, InStr(s, Chr$(0)) - 1)
   '根據Button的Enabled狀態進行重畫
   If (nState And ODS_DISABLED) = ODS_DISABLED Then
      '畫內側3D效果->亮色
      hpen = CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNHIGHLIGHT))
      SelectObject hdc, hpen
      MoveToEx hdc, rct.Left, rct.Top, P
      LineTo hdc, rct.Right, rct.Top
      MoveToEx hdc, rct.Left, rct.Top, P
      LineTo hdc, rct.Left, rct.Bottom
      DeleteObject hpen
      '畫內側3D效果->暗色
      hpen = CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNSHADOW))
      SelectObject hdc, hpen
      MoveToEx hdc, rct.Left, rct.Bottom - 1, P
      LineTo hdc, rct.Right, rct.Bottom - 1
      MoveToEx hdc, rct.Right - 1, rct.Top, P
      LineTo hdc, rct.Right - 1, rct.Bottom
      DeleteObject hpen
      '畫陰影文字
      rct.Left = rct.Left + 1
      rct.Right = rct.Right + 1
      rct.Bottom = rct.Bottom + 1
      rct.Top = rct.Top + 1
      SetTextColor hdc, GetSysColor(COLOR_BTNHIGHLIGHT)
      DrawText hdc, s, Len(s), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
      rct.Left = rct.Left - 1
      rct.Right = rct.Right - 1
      rct.Bottom = rct.Bottom - 1
      rct.Top = rct.Top - 1
      SetTextColor hdc, GetSysColor(COLOR_GRAYTEXT)
      DrawText hdc, s, Len(s), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
      Exit Sub
   End If
   '按下Button時重畫
   If (nState And ODS_SELECTED) = ODS_SELECTED Then
      '畫外圍黑框
      hbr = CreateSolidBrush(GetSysColor(COLOR_BTNTEXT))
      SelectObject hdc, hbr
      FrameRect hdc, rct, hbr
      DeleteObject hbr
      hbr = CreateSolidBrush(GetSysColor(COLOR_BTNSHADOW))
      SelectObject hdc, hbr
      rct.Left = rct.Left + 1
      rct.Right = rct.Right - 1
      rct.Bottom = rct.Bottom - 1
      rct.Top = rct.Top + 1
      FrameRect hdc, rct, hbr
      DeleteObject hbr

      rct.Left = rct.Left + 1
      rct.Right = rct.Right + 1
      rct.Bottom = rct.Bottom + 1
      rct.Top = rct.Top + 1
      SetTextColor hdc, GetSysColor(COLOR_BTNTEXT)
      DrawText hdc, s, Len(s), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
      Exit Sub
   End If
   'Button得到焦點時重畫
   If (nState And ODS_FOCUS) = ODS_FOCUS Then
      '畫外圍黑框
      hbr = CreateSolidBrush(GetSysColor(COLOR_BTNTEXT))
      SelectObject hdc, hbr
      FrameRect hdc, rct, hbr
      DeleteObject hbr
      '畫內側3D效果->亮色
      hpen = CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNHIGHLIGHT))
      SelectObject hdc, hpen
      MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
      LineTo hdc, rct.Right - 1, rct.Top + 1
      MoveToEx hdc, rct.Left + 1, rct.Top + 1, P
      LineTo hdc, rct.Left + 1, rct.Bottom - 1
      DeleteObject hpen
      '畫內側3D效果->暗色
      hpen = CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNSHADOW))
      SelectObject hdc, hpen
      MoveToEx hdc, rct.Left + 1, rct.Bottom - 2, P
      LineTo hdc, rct.Right - 1, rct.Bottom - 2
      MoveToEx hdc, rct.Right - 2, rct.Top + 1, P
      LineTo hdc, rct.Right - 2, rct.Bottom - 1
      DeleteObject hpen

      SetTextColor hdc, GetSysColor(COLOR_BTNTEXT)
      DrawText hdc, s, Len(s), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
   Else
      '畫內側3D效果->亮色
      hpen = CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNHIGHLIGHT))
      SelectObject hdc, hpen
      MoveToEx hdc, rct.Left, rct.Top, P
      LineTo hdc, rct.Right, rct.Top
      MoveToEx hdc, rct.Left, rct.Top, P
      LineTo hdc, rct.Left, rct.Bottom
      DeleteObject hpen
      '畫內側3D效果->暗色
      hpen = CreatePen(PS_SOLID, 1, GetSysColor(COLOR_BTNSHADOW))
      SelectObject hdc, hpen
      MoveToEx hdc, rct.Left, rct.Bottom - 1, P
      LineTo hdc, rct.Right, rct.Bottom - 1
      MoveToEx hdc, rct.Right - 1, rct.Top, P
      LineTo hdc, rct.Right - 1, rct.Bottom
      DeleteObject hpen
      '畫陰影文字
      SetTextColor hdc, GetSysColor(COLOR_BTNTEXT)
      DrawText hdc, s, Len(s), rct, DT_CENTER Or DT_SINGLELINE Or DT_VCENTER
   End If
End Sub

Private Function SubWndProc(ByVal hWnd As Long, ByVal Msg As Long, _
                            ByVal wParam As Long, ByVal lParam As Long) _
                            As Long
   Dim di As DRAWITEMSTRUCT
   If Msg = WM_DESTROY Then Terminate (hWnd)
   '處理自畫訊息
   If Msg = WM_DRAWITEM Then
      CopyMemory di, ByVal lParam, Len(di)
      '判斷是自畫Button
      If di.CtlType = ODT_BUTTON Then

         DrawButton di.hwndItem, di.hdc, di.rcItem, di.itemState
         '不返回VB的預設Button繪製過程
         SubWndProc = 1
         Exit Function
      End If

   End If
   SubWndProc = CallWindowProc(PrevWndProc, hWnd, Msg, wParam, lParam)
End Function

Public Sub Init(hWnd As Long)
PrevWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf SubWndProc)
End Sub

Public Sub Terminate(hWnd As Long)
Call SetWindowLong(hWnd, GWL_WNDPROC, PrevWndProc)
End Sub
' -- 模組結束 -- '

3. Form1中的程式碼：

Option Explicit

Private Sub Form_Load()
Call Init(Me.hWnd)
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call Terminate(Me.hWnd)
End Sub

4. 結束語

怎麼樣，看到兩個Button之間的不同了麼

本程式在Win2000 + Vb6中除錯通過。

介面開發之Flat3DButton (轉)
2007-12-12
3D
微信開發之JSSDK介面開發（Java）
2017-06-07
JSJava
windows原生開發之介面疑雲
2013-11-22
Windows
微信開發之微信域名防封介面
2020-07-14
iOS開發之模擬介面假資料
2017-12-28
iOS
測試開發之效能篇-JMeter介面測試
2021-11-02
JMeter
瘋狂連連看之開發遊戲介面元件
2011-07-15
開發遊戲元件
介面開發-restful
2022-06-14
REST
API介面開發（一）：介面開發返回結果解決方案
2021-09-09
API
python 開發介面
2020-04-04
Python
用 Django 開發介面
2020-06-02
Django
兩種Oracle應用程式開發介面之簡要分析
2007-06-05
Oracle
測試開發之介面篇-使用K6完成介面自動化測試
2023-04-21
iOS開發之SQLite–C語言介面規範(五)：iOS開發使用SQLite例項
2015-12-29
iOSSQLiteC語言
Linux企業級開發技術（2）——epoll企業級開發之epoll介面
2014-09-23
Linux
【Android開發入門教程】四.使用者介面之Layout
2020-07-22
Android
Solon2 之 Groovy 語言開發後端介面專案
2023-04-08
後端
Android開發優化之——對介面UI的優化（1）
2013-11-27
Android優化UI
Android開發優化之——對介面UI的優化（2）
2013-11-27
Android優化UI
Android開發優化之——對介面UI的優化（3）
2013-11-27
Android優化UI
04.開發REST 介面
2020-06-18
REST
支付寶介面開發
2017-11-23
iOS開發 - 介面尺寸指南
2015-04-30
iOS
API介面開發規範
2024-03-22
API
chatgpt介面開發筆記1:completions介面
2023-04-26
ChatGPT筆記
那些年，我們開發的介面之：QQ登入（OAuth2.0）
2013-08-16
OAuth
Laravel 使用 passport 開發 API 介面
2020-05-25
LaravelPassportAPI
微信開發介面API協議
2019-03-26
API協議
java實現zabbix介面開發
2019-02-20
Java
PayPal支付介面開發java版
2020-11-06
Java
使用Flask開發簡單介面
2022-02-25
Flask
API介面開發簡述示例
2023-02-20
API
使用 Ruby on Rails 開發 Go 介面
2017-10-03
AIGo
微信支付介面開發過程
2017-11-15
智慧手錶開發API介面
2015-03-09
API
銀聯線上Java介面開發
2016-06-13
Java
Python學習之Web開發及圖形使用者介面模組！
2021-05-17
PythonWeb
iOS開發之SQLite–C語言介面規範(四) ：Result Values From A Query
2015-12-28
iOSSQLiteC語言

介面開發之Flat3DButton

相關文章