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
