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
勉强可以解决以上问题,当然,也许有更好的办法,我还没时间去探究。