用戶登錄  |  用戶注冊
首 頁源碼下載網絡學院最新源碼源碼排行屏蔽廣告
當前位置:新興網絡 > 網絡學院 > 編程開發 > Visual Basic

VB 設置控件邊框顏色(如:List、Text、Picture)

減小字體 增大字體 作者:LinHaibo  來源:新興網絡  發布時間:2010-09-27 13:33:52

VB 設置控件邊框顏色,比如:ListBox、TextBox、PictureBox、ComboBox等等….
調用方法:

'setBorderColor (控件句柄,顏色值)
setBorderColor Text1.hWnd, vbRed
附件下載.rar
模塊代碼如下:
VBScript code復制代碼
Option Explicit
Private Type RECTW
    Left                As Long
    Top                 As Long
    Right               As Long
    Bottom              As Long
    Width               As Long
    Height              As Long
End Type

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

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 Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

Private Const WM_DESTROY        As Long = &H2
Private Const WM_PAINT          As Long = &HF
Private Const WM_NCPAINT        As Integer = &H85
Private Const GWL_WNDPROC = (-4)
Private Color As Long

Public Sub setBorderColor(hWnd As Long, Color_ As Long)
    Color = Color_
    If GetProp(hWnd, "OrigProcAddr") = 0 Then
        SetProp hWnd, "OrigProcAddr", SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
    End If
End Sub

Public Sub UnHook(hWnd As Long)
    Dim OrigProc As Long
    OrigProc = GetProp(hWnd, "OrigProcAddr")
    If Not OrigProc = 0 Then
        SetWindowLong hWnd, GWL_WNDPROC, OrigProc
        OrigProc = SetWindowLong(hWnd, GWL_WNDPROC, OrigProc)
        RemoveProp hWnd, "OrigProcAddr"
    End If
End Sub
Private Function OnPaint(OrigProc As Long, hWnd As Long, uMsg As Long, wParam As Long, lParam As Long) As Long
    Dim m_hDC       As Long
    Dim m_wRect     As RECTW
    OnPaint = CallWindowProc(OrigProc, hWnd, uMsg, wParam, lParam)
    Call pGetWindowRectW(hWnd, m_wRect)
    m_hDC = GetWindowDC(hWnd)
    Call pFrameRect(m_hDC, 0, 0, m_wRect.Width, m_wRect.Height)
    Call ReleaseDC(hWnd, m_hDC)
End Function
Private Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim OrigProc As Long
    Dim ClassName As String
    If hWnd = 0 Then Exit Function
    OrigProc = GetProp(hWnd, "OrigProcAddr")
    If Not OrigProc = 0 Then
        If uMsg = WM_DESTROY Then
            SetWindowLong hWnd, GWL_WNDPROC, OrigProc
            WindowProc = CallWindowProc(OrigProc, hWnd, uMsg, wParam, lParam)
            RemoveProp hWnd, "OrigProcAddr"
        Else
            If uMsg = WM_PAINT Or WM_NCPAINT Then

                WindowProc = OnPaint(OrigProc, hWnd, uMsg, wParam, lParam)
            Else
                WindowProc = CallWindowProc(OrigProc, hWnd, uMsg, wParam, lParam)
            End If
        End If
    Else
        WindowProc = DefWindowProc(hWnd, uMsg, wParam, lParam)
    End If
End Function

Private Function pGetWindowRectW(ByVal hWnd As Long, lpRectW As RECTW) As Long
    Dim TmpRect As RECT
    Dim Rtn     As Long
    Rtn = GetWindowRect(hWnd, TmpRect)
    With lpRectW
        .Left = TmpRect.Left
        .Top = TmpRect.Top
        .Right = TmpRect.Right
        .Bottom = TmpRect.Bottom
        .Width = TmpRect.Right - TmpRect.Left
        .Height = TmpRect.Bottom - TmpRect.Top
    End With
    pGetWindowRectW = Rtn
End Function

Private Function pFrameRect(ByVal hDC As Long, ByVal x As Long, y As Long, ByVal Width As Long, ByVal Height As Long) As Long
    Dim TmpRect     As RECT
    Dim m_hBrush    As Long
    With TmpRect
        .Left = x
        .Top = y
        .Right = x + Width
        .Bottom = y + Height
    End With
    m_hBrush = CreateSolidBrush(Color)
    pFrameRect = FrameRect(hDC, TmpRect, m_hBrush)
    DeleteObject m_hBrush
End Function
 

Tags:邊框顏色 設置 VB Text Picture List

作者:LinHaibo
  • 好的評價 如果您覺得此文章好,就請您
      100%(3)
  • 差的評價 如果您覺得此文章差,就請您
      0%(0)

網絡學院評論評論內容只代表網友觀點,與本站立場無關!

   評論摘要(共 0 條,得分 0 分,平均 0 分) 查看完整評論
皮皮麻将官网下载 广西快3基本走试图 (^ω^)MG金钱蛙_最新版 六肖特中比例多少? (★^O^★)MG圣诞大镖客_破解版下载 (★^O^★)MG宝石女王奖金赔率 (★^O^★)MG黄金武士巨额大奖视频 河南快3开奖走势图 六肖中特免费管家婆期期准 (★^O^★)MG超级888游戏 广西快乐双彩开奖公告开奖结果 亿客隆 (^ω^)MG魔术箱客户端下载 网赚网盘是什么 新疆18选7的开奖号码 贵州快三走势图今天 黑进网络彩票平台