在 普通的文字框 裡加入圖片背景

來源:互聯網
上載者:User
文字框 ------------------------------------------視窗的代碼-------------------

表單:form1

圖片框 picture1

文字框 text1

Private Sub Form_Load()
Set pic = LoadResPicture(102, 0)
Set Picture1.Picture = pic
Dim hdc As Long
hdc = GetDC(Text1.hwnd) '建立一個臨時DC

memDc = CreateCompatibleDC(hdc)
MemBitmap = CreateCompatibleBitmap(hdc, Text1.Width, Text1.Height)
SelectObject memDc, MemBitmap
StretchBlt memDc, 0, 0, Text1.Width, Text1.Height, Picture1.hdc, 0, 0, Text1.Width, Text1.Height, SRCCOPY
ReleaseDC Text1.hwnd, hdc

If memDc = 0 Or MemBitmap = 0 Then
MsgBox "error create dc"
End
End If
Oldproc = SetWindowLong(Text1.hwnd, GWL_WNDPROC, AddressOf winproc)
OldWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf winproc1)
End Sub

Private Sub Form_Unload(Cancel As Integer)
DeleteObject MemBitmap
DeleteDC memDc
SetWindowLong Me.hwnd, GWL_WNDPROC, OldWndProc
SetWindowLong Text1.hwnd, GWL_WNDPROC, Oldproc
End Sub
Private Sub Text1_DblClick()
SendMessage Text1.hwnd, WM_PAINT, 0, 0
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
SendMessage Text1.hwnd, WM_PAINT, 0, 0
End Sub

Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
'選定文本的時候如果文本選頂發生了變化,則通知更
Static Startpos0 As Long, Endpos0 As Long
Dim Startpos As Long, Endpos As Long
If Button = 1 Then
Dim v As Long
v = SendMessage(Text1.hwnd, EM_GETSEL, 0, 0)
Endpos = v \ 65536: Startpos = v Mod 65536 '-->獲得選定文本位置

If Startpos <> Endpos Then '--->發現有選定時候檢查選定是否和上次的相同?不同的話則重畫
If Startpos0 = Startpos And Endpos = Endpos0 Then
Else '---->內容發生變化的時候發送訊息請求重畫
SendMessage Text1.hwnd, WM_PAINT, 0, 0
Startpos0 = Startpos: Endpos0 = Endpos
End If
End If
End If
End Sub


Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
PostMessage Text1.hwnd, WM_PAINT, 0, 0
End Sub

Private Sub Text1_Change()
SendMessage Form1.Text1.hwnd, WM_PAINT, 0, 0
End Sub
--------------------------------------------模組代碼-------------------------------------------------

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public 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
Public 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
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long


Public Const WM_ERASEBKGND = &H14
Public Const EN_VSCROLL = &H602
Public Const WM_COMMAND = &H111
Public Const EN_HSCROLL = &H601
Public Const EN_CHANGE = &H300
Public Const EN_UPDATE = &H400
Public Const EM_GETSEL = &HB0
Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Public Const SRCAND = &H8800C6 ' (DWORD) dest = source AND dest
Public Const SRCPAINT = &HEE0086 ' (DWORD) dest = source OR dest
Public Const SRCERASE = &H440328 ' (DWORD) dest = source AND (NOT dest )
Public Const EM_SCROLL = &HB5
Public Const GWL_WNDPROC = (-4)
Public Const WM_PAINT = &HF


Public memDc As Long
Public MemBitmap As Long
Public OldWndProc As Long
Public Oldproc As Long
Public pic As Picture
Public Function winproc(ByVal hwnd As Long, ByVal msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
With Form1.Text1
If msg = WM_PAINT Then
Debug.Print Token
Dim hdc As Long
winproc = CallWindowProc(Oldproc, Form1.Text1.hwnd, msg, wp, lp)

If wp = 1 Then .Visible = False: .Visible = True

hdc = GetDC(Form1.Text1.hwnd)
BitBlt hdc, 0, 0, Form1.Text1.Width, Form1.Text1.Height, memDc, 0, 0, SRCAND
ReleaseDC Form1.Text1.hwnd, hdc
Exit Function

End If
winproc = CallWindowProc(Oldproc, Form1.Text1.hwnd, msg, wp, lp)
End With
End Function

Public Function winproc1(ByVal hwnd As Long, ByVal msg As Long, ByVal wp As Long, ByVal lp As Long) As Long

If msg = WM_COMMAND Then
Select Case wp \ 65536
Case EN_VSCROLL '---->獲得文字框縱向滾動訊息
SendMessage Form1.Text1.hwnd, WM_PAINT, 1, 0
Case EN_HSCROLL '----->獲得橫向滾動訊息
SendMessage Form1.Text1.hwnd, WM_PAINT, 1, 0
Case EN_UPDATE
SendMessage Form1.Text1.hwnd, WM_PAINT, 0, 0
End Select
End If
winproc1 = CallWindowProc(OldWndProc, hwnd, msg, wp, lp)
End Function
-------------------------------------------------------------------------------------------------------

這樣就可以 在圖片裡加如圖片的背景了。

本程式在 2000/XP 下調試通過。有一個缺點是閃動比較厲害,希望各位大蝦指正。



相關文章

E-Commerce Solutions

Leverage the same tools powering the Alibaba Ecosystem

Learn more >

Apsara Conference 2019

The Rise of Data Intelligence, September 25th - 27th, Hangzhou, China

Learn more >

Alibaba Cloud Free Trial

Learn and experience the power of Alibaba Cloud with a free trial worth $300-1200 USD

Learn more >

聯繫我們

該頁面正文內容均來源於網絡整理,並不代表阿里雲官方的觀點,該頁面所提到的產品和服務也與阿里云無關,如果該頁面內容對您造成了困擾,歡迎寫郵件給我們,收到郵件我們將在5個工作日內處理。

如果您發現本社區中有涉嫌抄襲的內容,歡迎發送郵件至: info-contact@alibabacloud.com 進行舉報並提供相關證據,工作人員會在 5 個工作天內聯絡您,一經查實,本站將立刻刪除涉嫌侵權內容。