读书人

Frame控件透明的有关问题请帮助修改

发布时间: 2012-03-16 16:34:56 作者: rapoo

Frame控件透明的问题,请帮助修改代码
首先,我在tabcript上边放了一个frame,为了适应xp视觉效果,希望frame背景色能够透明,在网上找到一段代码。但是出现了两个问题。

1,只有在button点击得情况下才能生效。我希望在formload的情况下出现
2,重复点击的话,背景色又恢复到了原始效果。

因为对api不太熟悉,修改不了。请指点

Option Explicit

Private Sub Form_Load()
'keine Systemfarben
Frame1.BackColor = &HFF&
End Sub

Private Sub Command1_Click()
'Sub in modTransFrame
FrameTransparent Frame1
End Sub
'---------- Ende Formular "Form1 " alias Form1.frm ----------
'--------- Anfang Modul "Module1 " alias Module1.bas ---------
Option Explicit

Public Declare Function GetDC Lib "user32 " (ByVal hwnd As Long) _
As Long

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

Public Declare Function CreateRectRgn Lib "gdi32 " (ByVal X1 _
As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 _
As Long) As Long

Public Declare Function CombineRgn Lib "gdi32 " (ByVal hDestRgn _
As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, _
ByVal nCombineMode As Long) As Long

Public Declare Function GetPixel Lib "gdi32 " (ByVal hDC As Long, _
ByVal x As Long, ByVal y As Long) As Long

Public Declare Function SetWindowRgn Lib "user32 " (ByVal hwnd _
As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Public CtrlDc As Long

Public Function FrameTranz(Ctrl As Frame) As Long
Dim lHoch As Long
Dim lBreit As Long
Dim lTemp As Long
Dim lSkin As Long
Dim lStart As Long
Dim lZeile As Long
Dim lSpalte As Long
Dim lBackColor As Long

lSkin = CreateRectRgn(0, 0, 0, 0)

With Ctrl
' bei Form.ScaleMode = vbTwips
lHoch = .Height / Screen.TwipsPerPixelY
lBreit = .Width / Screen.TwipsPerPixelX

' bei Form.ScaleMode = vbPixels


' lHoch = .Height
' lBreit = .Width

CtrlDc = GetDC(.hwnd)
lBackColor = Ctrl.BackColor

For lZeile = 0 To lHoch - 1
lSpalte = 0
Do While lSpalte < lBreit
Do While lSpalte < lBreit And GetPixel(CtrlDc, lSpalte, _
lZeile) = lBackColor
lSpalte = lSpalte + 1
Loop

If lSpalte < lBreit Then
lStart = lSpalte
Do While lSpalte < lBreit And GetPixel(CtrlDc, lSpalte, _
lZeile) <> lBackColor
lSpalte = lSpalte + 1
Loop

If lSpalte > lBreit Then lSpalte = lBreit
lTemp = CreateRectRgn(lStart, lZeile, lSpalte, lZeile + 1)
Call CombineRgn(lSkin, lSkin, lTemp, 2)
Call DeleteObject(lTemp)
End If
Loop
Next lZeile
End With

FrameTranz = lSkin
End Function

Public Sub FrameTransparent(Ctrl As Frame)
Dim lSkin As Long
Ctrl.Visible = True
lSkin = FrameTranz(Ctrl)
Call SetWindowRgn(Ctrl.hwnd, lSkin, True)
End Sub

[解决办法]
在 form的show事件里面写
FrameTransparent Frame1
[解决办法]
你在程序中加入下面的一句话,就可以解决“2,重复点击的话,背景色又恢复到了原始效果。”

CtrlDc = GetDC(.hwnd)
lBackColor = Ctrl.BackColor

'========避免重复绘制================================================
if GetPixel(CtrlDc, 0, 0) <> lBackColor then exit Function
’==================================================================

因为执行一次透明操作后, GetPixel(CtrlDc, 0, 0) 的颜色就不等于 lBackColor 了。




[解决办法]
至于:1,只有在button点击得情况下才能生效。我希望在formload的情况下出现

是因为在窗体还没有Show之前,系统不会绘制窗体及控件的,可采取一个笨办法:

设置一个 Timer1, 将其Timer1.Enabled = false , Timer1.Interval = 10,然后:

Private Sub Form_Load()
'keine Systemfarben
Frame1.BackColor = &HFF&
Timer1.Enabled = True
End Sub

Private Sub Timer1_Timer()
Command1_Click
Timer1.Enabled = False
End Sub

勉强可以解决以上问题,当然,也许有更好的办法,我还没时间去探究。

读书人网 >VB

热点推荐