Membuat form transparan pada MS visual foxpro

Untuk mempercantik tampilan program dengan menggunakan microsoft visual foxpro maka tampilan form form bisa di permak menjadi form transparan.
untuk membuat form menjadi tranparan masukkan beberapa koding berikut pada form visual foxpro


procedure init
**-----------------

DECLARE SetWindowLong In Win32Api AS _Sol_SetWindowLong Integer, Integer, Integer
DECLARE SetLayeredWindowAttributes In Win32Api AS _Sol_SetLayeredWindowAttributes Integer, String, Integer, Integer

_Sol_SetWindowLong(this.HWnd, -20, 0x00080000)
_Sol_SetLayeredWindowAttributes(this.HWnd, 0, 255, 2)

**-----------------

procedure destroy
**-----------------

CLEAR DLLS _Sol_SetWindowLong
CLEAR DLLS _Sol_SetLayeredWindowAttributes

**-----------------

atur nilai tranparannya dengan koding berikut

**-------------------
nilai_tranparan = 75 &&nilai tingkat tranparan
_Sol_SetLayeredWindowAttributes(this.Parent.HWnd, 0, nilai_tranparan, 2)
**-------------------

koding diatas bisa di letakan pada procedure init form atau di letakkan pada sebuah tombol


untuk sampel form nya bisa di download disini

selain form transparan , saya menemukan coding untuk membuat messagebox transparan dari blog tetangga

berikut potongan koding nya
**-----------------
Local lo_MsgBox

lo_MsgBox = CreateObject( 'cls_MessageBox' )
lo_MsgBox.ShowMsg( 'Test MessageBox', 64, 'MessageBox Title' )

lo_MsgBox.lChangeButton = .T. && Change MessageBox Button
lo_MsgBox.aButtons[1] = '&Good' && 1st button
lo_MsgBox.ShowMsg( 'Test MessageBox', 64, 'MessageBox Title' )

** lo_MsgBox.hWnd = myForm.hWnd && center MessageBox in Form
lo_MsgBox.lTransparent = .T. && transparent MessageBox
lo_MsgBox.nTransValue = 85 && 85% transparent
lo_MsgBox.aButtons[2] = '&Bad' && 2nd button
lo_MsgBox.aButtons[3] = '&Worst' && 3rd button
lo_MsgBox.ShowMsg( 'Test MessageBox', 64+2, 'MessageBox Title' )

lo_MsgBox = Null
Release lo_MsgBox

**********************

Define class cls_MessageBox as Custom
hWnd = 0
pOrgProc = 0
lChangeButton = .F.
lTransparent = .F.
nTransValue = 100 && in percentage, 100% = opaque

Dimension aButtons[3] = .F.

Procedure Init
Declare Long SetLayeredWindowAttributes in User32 ;
Long nhWnd, Long crKey, Short bAlpha, Long dwFlags

Declare Long GetWindowLong in User32 ;
Long nhWnd, Integer nIndex

Declare Long SetWindowLong in User32 ;
Long nhWnd, Integer nIndex, Long dwNewLong

Declare Long GetWindowRect in User32 ;
Long nhWnd, String @O_lpRect

Declare Long SetWindowPos in User32 ;
Long nhWnd, Long hWndInsertAfter, ;
Integer nX, Integer nY, Integer nWidth, Integer nHeight, Long nFlags

Declare Long CallWindowProc in User32 ;
Long lpPrevWndFunc, Long nhWnd, ;
Long uMsg, Long wParam, Long lParam

Declare Long FindWindowEx in User32 ;
Long hWndParent, Long hWndChildAfter, ;
String lpszClass, String lpszWindow

Declare Long SendMessage in User32 as SendMessageStr ;
Long nhWnd, Long uMsg, Long wParam, String @lParam

This.hWnd = _VFP.hWnd
This.pOrgProc = GetWindowLong( _VFP.hWnd, -4 )
EndProc


Procedure ShowMsg( tc_Msg, tn_Type, tc_Title )
BindEvent( 0, 0x06, This, 'WndProc' )
MessageBox( tc_Msg, tn_Type, tc_Title )
UnBindEvents( 0, 0x06 )
EndProc


Procedure CenterWindow( th_WndParent, th_WndChild )
Local ls_Rect

ls_Rect = space( 16 )
** Get container area (parent)
GetWindowRect( th_WndParent, @ls_Rect )
ln_TargetLeft = CToBin( substr( ls_Rect, 1, 4 ), '4rs' )
ln_TargetTop = CToBin( substr( ls_Rect, 5, 4 ), '4rs' )
ln_Right = CToBin( substr( ls_Rect, 9, 4 ), '4rs' ) + 1
ln_Bottom = CToBin( substr( ls_Rect, 13, 4 ), '4rs' ) + 1
ln_Width = ln_Right - ln_TargetLeft
ln_Height = ln_Bottom - ln_TargetTop

** Get contained area (child)
GetWindowRect( th_WndChild, @ls_Rect )
ln_Left = CToBin( substr( ls_Rect, 1, 4 ), '4rs' )
ln_Top = CToBin( substr( ls_Rect, 5, 4 ), '4rs' )
ln_Right = CToBin( substr( ls_Rect, 9, 4 ), '4rs' ) + 1
ln_Bottom = CToBin( substr( ls_Rect, 13, 4 ), '4rs' ) + 1

** Get Left & Top position (XY coordinate)
ln_Left = ((ln_Width - (ln_Right - ln_Left)) / 2) + ln_TargetLeft
ln_Top = (ln_Height - (ln_Bottom - ln_Top)) / 2 + ln_TargetTop
SetWindowPos( th_WndChild, 0, ln_Left,ln_Top, 0,0, BitOr( 0x1, 0x10, 0x400 ))
EndProc


Procedure WndProc( th_Wnd, tn_Msg, t_wParam, t_lParam )
If (tn_Msg == 0x06) and (t_wParam == 0)
Local ln_X, lh_Wnd, lh_WndChild, ln_OldStyle, ln_Transparent

With This
If ( .lTransparent ) and (.nTransValue > 0)
ln_Transparent = int((255 * This.nTransValue) / 100)
SetWindowLong( t_lParam, -20, ;
BitOr( GetWindowLong( t_lParam, -20 ), 0x80000 ))
SetLayeredWindowAttributes( t_lParam, 0, ln_Transparent, 2 )
endif

If ( .lChangeButton )
lh_WndChild = 0
For ln_X = 1 to 3
lh_WndChild = FindWindowEx( t_lParam, lh_WndChild, 'Button', 0 )
If (lh_WndChild == 0)
ln_X = 4
else
If !empty( .aButtons[ ln_X ] )
SendMessageStr( lh_WndChild, 0x0C, 0, .aButtons[ ln_X ] )
endif
endif
Next
endif

.CenterWindow( .hWnd, t_lParam )
EndWith
Return 0
endif

Return CallWindowProc( This.pOrgProc, th_Wnd, tn_Msg, t_wParam, t_lParam )
EndProc

Procedure Destroy
Clear DLLs
EndProc
EndDefine
**-----------------
silahkan di coba2 dan dimodifikasi

sekian

Share this :