butterfly8528
دوشنبه 30 آبان 1390, 06:01 صبح
سلام دوست عزیز .
کد های زیر رو در یک Module کپی کنید :
' ************************************************** ************************************
' Subclassed Multilined text boxes (for transparency effect)
' ************************************************** ************************************
'
' Author: G. D. Sever (aka The Hand)
' Date: Sept, 2002
'
' Description: This module allows the user to create a "transparent" effect for
' VB's standard textboxes. It creates brush objects for the textbox
' and then uses them when the textbox draws itself to paint the
' background area.
'
' In its current incarnation, we simply use the picture which is on
' the textboxes' form, however this can me modified in the CreateBGBrush
' subroutine to use whatever image you wish. In addition, you could do
' additional processing in WM_ERASEBKGND section of NewTxtBoxProc, such
' as adding a logo, text, horizontal lines, etc.
'
' Terms of use: You are welcome to use this code in your projects and modify it
' to suit your needs. However if you wish to publish code from
' this module, either in part or as a whole, as part of your
' modified project, you must give us credit for those pieces
' which are ours and obtain our permission.
'
' ************************************************** ************************************
' Visit EliteVB.com for more high-powered API and subclassing solutions!
' ************************************************** ************************************
Option Explicit
' APIs to install our subclassing routines
Private Const GWL_WNDPROC = (-4)
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
' These APIs are used to create a pattern brush for each textbox...
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 Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
' Messages which we will be processing in our subclassing routines
Private Const WM_COMMAND As Long = &H111
Private Const WM_CTLCOLOREDIT As Long = &H133
Private Const WM_DESTROY As Long = &H2
Private Const WM_ERASEBKGND As Long = &H14
Private Const WM_HSCROLL As Long = &H114
Private Const WM_VSCROLL As Long = &H115
' A rectangle.
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' APIs used to keep track of brush handles and process addresses
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
' APIs used in our subclassing routine to create the "transparent" effect.
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function WindowFromDC Lib "user32" (ByVal hdc As Long) As Long
Public Function makeTransparentTextbox(aTxt As TextBox)
' Make sure we don't have any typos in our subclassing procedures.
NewWindowProc 0, 0, 0, 0
NewTxtBoxProc 0, 0, 0, 0
' Create a background brush for this textbox, which we will used to give
' the textbox an APPEARANCE of transparency
CreateBGBrush aTxt
' Subclass the textbox's form, IF NOT ALREADY subclassed
If GetProp(GetParent(aTxt.hwnd), "OrigProcAddr") = 0 Then
SetProp GetParent(aTxt.hwnd), "OrigProcAddr", SetWindowLong(GetParent(aTxt.hwnd), GWL_WNDPROC, AddressOf NewWindowProc)
End If
' Subclass the textbox, IF NOT ALREADY subclassed
If GetProp(aTxt.hwnd, "OrigProcAddr") = 0 Then
SetProp aTxt.hwnd, "OrigProcAddr", SetWindowLong(aTxt.hwnd, GWL_WNDPROC, AddressOf NewTxtBoxProc)
End If
End Function
Private Sub CreateBGBrush(aTxtBox As TextBox)
Dim screenDC As Long ' The screen's device context.
Dim imgLeft As Long ' The X location inside the image which we are going to copy from.
Dim imgTop As Long ' The Y location inside the image which we are going to copy from.
Dim picDC As Long ' A temporary DC to pull the form's picture into
Dim picBmp As Long ' the 1x1 bitmap which is created with picDC
Dim aTempBmp As Long ' A temporary bitmap we'll use to create the pattern brush for our textbox
Dim aTempDC As Long ' the temporary device context used to hold aTempBmp
Dim txtWid As Long ' The form's width
Dim txtHgt As Long ' the form's height.
Dim solidBrush As Long ' Solid brush used to color in the bitmap... incase the textbox
' gets sized outside the dimensions of the picture
Dim aRect As RECT ' Rectangle to fill in with solid brush
If aTxtBox.Parent.Picture Is Nothing Then Exit Sub
' Get our form's dimensions, in pixels
txtWid = aTxtBox.Width / Screen.TwipsPerPixelX
txtHgt = aTxtBox.Height / Screen.TwipsPerPixelY
' Get the location within the bitmap picture we're copying from
imgLeft = aTxtBox.Left / Screen.TwipsPerPixelX
imgTop = aTxtBox.Top / Screen.TwipsPerPixelY
' Get the screen's device context
screenDC = GetDC(0)
' Create a device context to hold the form's picture.
picDC = CreateCompatibleDC(screenDC)
picBmp = SelectObject(picDC, aTxtBox.Parent.Picture.Handle)
' Create a temporary bitmap to blt the underlying image onto
aTempDC = CreateCompatibleDC(screenDC)
aTempBmp = CreateCompatibleBitmap(screenDC, txtWid, txtHgt)
DeleteObject SelectObject(aTempDC, aTempBmp)
' create a brush the color of BUTTON_FACE
solidBrush = CreateSolidBrush(GetSysColor(15))
aRect.Right = txtWid
aRect.Bottom = txtHgt
' Fill in the area
FillRect aTempDC, aRect, solidBrush
' clean up our resource
DeleteObject solidBrush
' Transfer the image
BitBlt aTempDC, 0, 0, txtWid, txtHgt, picDC, imgLeft, imgTop, vbSrcCopy
' Check to make sure that a brush hasn't already been made for this one
If GetProp(aTxtBox.hwnd, "CustomBGBrush") <> 0 Then
' If so, then delete it and free its memory before storing the new one's handle.
DeleteObject GetProp(aTxtBox.hwnd, "CustomBGBrush")
End If
' Create a pattern brush from our bitmap and store its handle against
' the textbox's handle
SetProp aTxtBox.hwnd, "CustomBGBrush", CreatePatternBrush(aTempBmp)
' Clean up our temporary DC and bitmap resources
DeleteDC aTempDC
DeleteObject aTempBmp
' Replace the original 1x1 bitmap, releasing the form's picture
SelectObject picDC, picBmp
' Clean up our picture DC and the 1x1 bitmap that was created with it
DeleteDC picDC
DeleteObject picBmp
' Release the screen's DC back to the system... forgetting to do this
' causes a nasty memory leak.
ReleaseDC 0, screenDC
End Sub
Private Function NewWindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' ************************************************** ****
' SUBCLASSING ROUTINE FOR THE TEXTBOX'S >>>>PARENT<<<<
' ************************************************** ****
Dim origProc As Long ' The original process address for the window.
Dim isSubclassed As Long ' Whether a certain textbox is subclassed or not.
' I've gotten in the habit of passing 0 values to the subclassing functions before
' actually installing them, just to make sure that I don't have any typos or other
' problems which can be easily detected. As such, if there is a hwnd of 0, its not
' a "valid" message, so we'll just exit right away.
If hwnd = 0 Then Exit Function
' Get the original process address which we stored earlier.
origProc = GetProp(hwnd, "OrigProcAddr")
If origProc <> 0 Then
If (uMsg = WM_CTLCOLOREDIT) Then
' Check to see if our window has a stored value for the original
' process address. If so, we're subclassing this one.
isSubclassed = (GetProp(WindowFromDC(wParam), "OrigProcAddr") <> 0)
If isSubclassed Then
' Invoke the default process... This will set the font, font color
' and other stuff we don't really want to fool with.
CallWindowProc origProc, hwnd, uMsg, wParam, lParam
' Make the words print transparently
SetBkMode wParam, 1
' Return the handle to our custom brush rather than that which
' the default process would have returned.
NewWindowProc = GetProp(WindowFromDC(wParam), "CustomBGBrush")
Else
' The textbox in question isn't subclassed, so we aren't going
' to do anything out of the ordinary. Just invoke the default proc.
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
ElseIf uMsg = WM_COMMAND Then
' Check to see if our window has a stored value for the original
' process address. If so, we're subclassing this one.
isSubclassed = (GetProp(lParam, "OrigProcAddr") <> 0)
If isSubclassed Then
' We are going lock the window from updating while we invalidate
' and redraw it. This prevents flickering.
LockWindowUpdate GetParent(lParam)
' Force windows to redraw the window.
InvalidateRect lParam, 0&, 1&
UpdateWindow lParam
End If
' Invoke the default process
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
If isSubclassed Then LockWindowUpdate 0&
ElseIf uMsg = WM_DESTROY Then
' The window is being destroyed... time to unhook our process so we
' don't cause a big fat error which crashes the application.
' Install the default process address again
SetWindowLong hwnd, GWL_WNDPROC, origProc
' Invoke the default process
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
' Remove our stored value since we don't need it anymore
RemoveProp hwnd, "OrigProcAddr"
Else
' We're not concerned about this particular message, so we'll just
' let it go on its merry way.
NewWindowProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
Else
' A catch-all in case something freaky happens with the process addresses.
NewWindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End If
End Function
Private Function NewTxtBoxProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' *********************************************
' SUBCLASSING ROUTINE FOR THE >>>>TEXTBOX<<<<
' *********************************************
Dim aRect As RECT
Dim origProc As Long
Dim aBrush As Long
If hwnd = 0 Then Exit Function
' Get the original process address which we stored earlier.
origProc = GetProp(hwnd, "OrigProcAddr")
If origProc <> 0 Then
' We're subclassing! Which is silly, 'cause otherwise we wouldn't be in
' this function, however we double check the process address just in case.
If uMsg = WM_ERASEBKGND Then
' We're going to get our custom brush for this textbox and fill the
' textbox's background area with it...
aBrush = GetProp(hwnd, "CustomBGBrush")
If aBrush <> 0 Then
' Get the area dimensions to fill
GetClientRect hwnd, aRect
' Fill it with our custom brush
FillRect wParam, aRect, aBrush
' Tell windows that we took care of the "erasing"
NewTxtBoxProc = 1
Else
' Something happened to our custom brush :-\ We'll just invoke
' the default process
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
ElseIf uMsg = WM_HSCROLL Or uMsg = WM_VSCROLL Then
' We are scrolling, either horizontally or vertically. This requires
' us to totally repaint the background area... so we'll lock the
' window updates so we don't see any of the freaky flickering
LockWindowUpdate GetParent(hwnd)
' Invoke the default process so the user actually get's the scroll
' they want
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
' Force window to repaint itself
InvalidateRect hwnd, 0&, 1&
UpdateWindow hwnd
' Release the update lock
LockWindowUpdate 0&
ElseIf uMsg = WM_DESTROY Then
' The textbox's parent is closing / destroying, so we need to
' unhook our subclassing routine ... or bad things happen
' Clean up our brush object... muy importante!!!
aBrush = GetProp(hwnd, "CustomBGBrush")
' Delete the brush object, freeing its resource.
DeleteObject aBrush
' Remove our values we stored against the textbox's handle
RemoveProp hwnd, "OrigProcAddr"
RemoveProp hwnd, "CustomBGBrush"
' Replace the original process address
SetWindowLong hwnd, GWL_WNDPROC, origProc
' Invoke the default "destroy" process
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
Else
' We're not interested in this message, so we'll just let it truck
' right on thru... invoke the default process
NewTxtBoxProc = CallWindowProc(origProc, hwnd, uMsg, wParam, lParam)
End If
Else
' A catch-all in case something freaky happens with the process addresses.
NewTxtBoxProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End If
End Function
نحوه استفاده :
Private Sub Form_Load()
makeTransparentTextbox txtName
End Sub
موفق باشید :لبخندساده:.
butterfly8528
سه شنبه 01 آذر 1390, 03:26 صبح
سلام دوست عزیز .
به روش زیر میشه تقریبا رنگ پس زمینه هر کنترلی رو که دارای خصوصیات Handle و BackColor باشه رو Transparent کرد .
کد های زیر رو در یک Module کپی کنید :
Global gHookHWND As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PAINTSTRUCT
hdc As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(1 To 32) As Byte
End Type
Private Const GWL_WNDPROC = (-4)
Private Const WM_PAINT = &HF
Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
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 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private pRect As RECT
Public Function SubClassControl(MySSTAB As Object, Pct As Object)
Pct.AutoRedraw = True
Pct.ScaleMode = vbPixels
MySSTAB.BackColor = vbWhite
'Save Grid fontname to use with DC's
SetProp MySSTAB.hwnd, "lpPROC", SetWindowLong(MySSTAB.hwnd, GWL_WNDPROC, AddressOf MySubclassedGrid)
SetProp MySSTAB.hwnd, "PctOBJ", ObjPtr(Pct) 'Save a pointer to PictureBox
SetProp MySSTAB.hwnd, "GridOBJ", ObjPtr(MySSTAB) 'Save a pointer to Control
End Function
Public Sub UnSubClassControl(ByVal hw As Long)
Dim RetVal As Long
RetVal = SetWindowLong(hw, GWL_WNDPROC, GetProp(hw, "lpPROC")) 'unsubclass Control
'Clean up windows database
RemoveProp hw, "lpPROC"
RemoveProp hw, "PctOBJ"
RemoveProp hw, "GridOBJ"
End Sub
Private Function MySubclassedGrid(ByVal hw As Long, ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim PicTEMP As Object
Dim PicBACKGROUND As Object
Dim GridTEMP As Object, GridREAL As Object
gHookHWND = hw
'Make GridTEMP a illegal reference - do not press END - Crash
CopyMemory GridTEMP, GetProp(hw, "GridOBJ"), 4
'Make it legal
Set GridREAL = GridTEMP
'Destroy illegal - no more crash
CopyMemory GridTEMP, 0&, 4
'Same story for PicTEMP
CopyMemory PicTEMP, GetProp(hw, "PctOBJ"), 4
Set PicBACKGROUND = PicTEMP
CopyMemory PicTEMP, 0&, 4
Select Case lMsg
Case Is = WM_PAINT
'We must do all the painting job
Dim controlDC As Long, tempDC As Long, intDC As Long, tempBMP, intBMP As Long
Dim aPS As PAINTSTRUCT
Dim aDC As Long
Dim Altura As Long
Dim tppX, tppY As Long
Dim BackBuffDC, BackBuffBMP As Long
GetClientRect hw, pRect
'Start painting control ...
Call BeginPaint(hw, aPS)
aDC = aPS.hdc 'store painting DC
'Prepare Double buffering ...No flickering
BackBuffDC = CreateCompatibleDC(aDC)
BackBuffBMP = CreateCompatibleBitmap(aDC, pRect.Right, pRect.Bottom)
DeleteObject SelectObject(BackBuffDC, BackBuffBMP)
'This is the big thing ! We are sendind WM_PAINT to our backbuffer
MySubclassedGrid = CallWindowProc(GetProp(hw, "lpPROC"), hw, lMsg, ByVal BackBuffDC, 0&)
With pRect
Call BitBlt(BackBuffDC, tppX, tppY, pRect.Right, pRect.Bottom, _
PicBACKGROUND.hdc, GridREAL.Left, GridREAL.Top, vbSrcAnd)
End With
'We have all the changes into backbuffer. Let's bring in back to control.hDc
With aPS.rcPaint
BitBlt aDC, .Left, .Top, .Right - .Left, .Bottom - .Top, BackBuffDC, .Left, .Top, vbSrcCopy
End With
DeleteDC BackBuffDC
DeleteObject BackBuffBMP
Call EndPaint(hw, aPS)
MySubclassedGrid = 0 'When a function intercepts WM_PAINT it must return 0
Case Else
'Call default windows procedure, stored in windows database in propertie lpPROC
MySubclassedGrid = CallWindowProc(GetProp(hw, "lpPROC"), hw, lMsg, wParam, lParam)
End Select
End Function
نحوه استفاده :
Option Explicit
Private Sub Form_Load()
Dim i As Byte
For i = 1 To 100
If i Mod 2 = 0 Then List1.AddItem "www.arshamsoft.com" Else List1.AddItem "www.barnamenevis.org"
Next i
SubClassControl Check1, Me
SubClassControl Option1, Me
SubClassControl List1, Me
SubClassControl Frame1, Me
SubClassControl Picture1, Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnSubClassControl Check1.hwnd
UnSubClassControl Option1.hwnd
UnSubClassControl List1.hwnd
UnSubClassControl Frame1.hwnd
UnSubClassControl Picture1.hwnd
End Sub
Private Sub List1_Click()
List1.Refresh
End Sub
Private Sub List1_GotFocus()
List1.Refresh
End Sub
Private Sub List1_Scroll()
List1.Refresh
End Sub
Private Sub Option1_GotFocus()
Option1.Refresh
End Sub
Private Sub Option1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Option1.Refresh
End Sub
موفق باشید :لبخندساده: .
vBulletin® v4.2.5, Copyright ©2000-1404, Jelsoft Enterprises Ltd.