Code: Select all | Expand
// Exemplos no FiveWin Brasil:/*
http://fivewin.com.br/index.php?/topic/ ... resolvido/
http://fivewin.com.br/index.php?/topic/ ... resolvido/
*/// By Manuel Mercado#include "FiveWin.ch"#include "TSBrowse.CH"//#include "TSButton.CH"#define CLR_HBROWN nRGB
( 205,
192,
176 )REQUEST DBFCDX
STATIC oWnd, aRedir, nFrom, nDest
//--------------------------------------------------------------------------------------------------------------------//Function Main
() Local oMenu, oIco
SET DATE BRITISH
SET EPOCH
TO Year( Date
() ) -
70 MENU oMenu
MENUITEM "Archivo" MENU MENUITEM "Create &Excel Sheet" ACTION fExcelDbf
( ,, .F.
) MENUITEM "Create &Database" ACTION fExcelDbf
() MENUITEM "E&xit" ACTION oWnd:
End() ENDMENU MENUITEM "E&xit" ACTION oWnd:
End() ENDMENU DEFINE WINDOW oWnd
MENU oMenu
TITLE "From Excel To Dbf or Visceversa" ACTIVATE WINDOW oWnd
MAXIMIZED ON INIT fExcelDbf
()Return Nil//--------------------------------------------------------------------------------------------------------------------//Function fExcelDbf
( cXls, cDbf, lXls
) Local oDlg, aCtl
[ 9 ], lActivate, oFont, nVer, ;
nAvance :=
0 Default cXls := Padr
( "Libro1.xls",
60 ), ;
cDbf := Padr
( "Base1.dbf",
60 ), ;
lXls := .T.
nVer :=
If( lXls,
1,
2 ) lActivate := lXls
DEFINE FONT oFont
NAME "MS Sans Serif" SIZE 0,
-11 DEFINE DIALOG oDlg
FROM 0,
0 TO 202,
380 PIXEL FONT oFont ;
COLORS CLR_BLACK, CLR_HBROWN ;
TITLE "Excel/Database/Excel" oDlg:
nStyle := nOr
( oDlg:
nStyle,
4 ) @
11,
6 SAY aCtl
[ 1 ] PROMPT "Database" OF oDlg ;
FONT oFont
UPDATE ;
COLORS CLR_BLACK, CLR_HBROWN
SIZE 39,
9 PIXEL @
11,
45 GET aCtl
[ 2 ] VAR cDbf
OF oDlg
SIZE 141,
10 PIXEL COLOR CLR_BLACK, CLR_WHITE
FONT oFont ;
ACTION ( cDbf := PadR
( cGetFileName
( .F.
),
60 ), aCtl
[ 2 ]:
Refresh() ) Bitmap
"Find16" @
27,
6 SAY aCtl
[ 3 ] PROMPT "Excel File" OF oDlg ;
FONT oFont
UPDATE ;
COLORS CLR_BLACK, CLR_HBROWN
SIZE 39,
9 PIXEL @
27,
45 GET aCtl
[ 4 ] VAR cXls
OF oDlg
SIZE 141,
10 PIXEL COLOR CLR_BLACK, CLR_WHITE
FONT oFont ;
ACTION ( cXls := PadR
( cGetFileName
(),
60 ), aCtl
[ 4 ]:
Refresh() ) Bitmap
"Find16" @
43,
31 CheckBox aCtl
[ 5 ] VAR lActivate
OF oDlg ;
PROMPT "Abrir Excel" FONT oFont
UPDATE SIZE 50,
16 PIXEL @
39,
82 Radio aCtl
[ 6 ] Var nVer
PROMPT "Xls/Dbf",
"Dbf/Xls" Of oDlg
Size 200,
10 Pixel// ALIGN DT_CENTER ;// COLORS CLR_BLACK, CLR_HBROWN, CLR_WHITE, CLR_GRAY, ;// CLR_BLACK @
66,
36 BUTTON aCtl
[ 7 ] PROMPT "&Ok" OF oDlg ;
ACTION ( If( nVer ==
1, fXls2Dbf
( cXls, cDbf, aCtl
[ 9 ] ), ;
fDbf2Xls
( cXls, cDbf, aCtl
[ 9 ], lActivate
) ), oDlg:
End() ) ;
FONT oFont
SIZE 38,
12 PIXEL @
66,
99 BUTTON aCtl
[ 8 ] PROMPT "&Exit" OF oDlg ;
ACTION oDlg:
End() ;
FONT oFont
SIZE 38,
12 PIXEL @
86,
6 METER aCtl
[ 9 ] VAR nAvance
OF oDlg TOTAL
100 ;
PROMPT "Avance" SIZE 178,
12 PIXEL FONT oFont ;
COLORS CLR_HBROWN, CLR_BLACK ;
BARCOLOR CLR_HBLUE, CLR_YELLOW
ACTIVATE DIALOG oDlg
CENTERED VALID ( oFont:
End(), .T.
)Return Nil//--------------------------------------------------------------------------------------------------------------------//Static Function fXls2Dbf
( cXls, cDbf, oMtr, nTitRow, nDatRow
) Local oExcel, oSheet, nRows, nCols, nRow, nCol, uData, nEle, nStep, ;
nAvance :=
0, ;
aCampos :=
{} Default aRedir :=
{} If Empty
( cXls
) Return Nil EndIf CursorWait
() cXls := UppCap
( StrTran
( Upper
( AllTrim
( cXls
) ),
".XLS" ) +
".XLS" ) Default cDbf := UppCap
( StrTran
( Upper
( cXls
),
".XLS" ) ), ;
nTitRow :=
1, ;
nDatRow :=
2 If ! File
( Lfn2Sfn
( cXls
) ) CursorArrow
() MsgStop
( "Unexist File", cXls
) Return Nil EndIf oExcel := TOleAuto
():
New( "Excel.Application" ) oExcel:
WorkBooks:
Open( cXls
) oSheet := oExcel:
Get( "ActiveSheet" ) nRows := oSheet:
UsedRange:
Rows:
Count() nCols := oSheet:
UsedRange:
Columns:
Count() oMtr:
cText :=
"Creando Base de Datos" oMtr:
nTotal := nCols +
( nCols * nRows
) oMtr:
Set( nAvance
) oMtr:
Refresh() nStep :=
Max( 1, Int
( oMtr:
nTotal * .
03 ) ) For nCol :=
1 To nCols
If ValType
( oSheet:
Cells( nDatRow, nCol
):
Value ) =
"C" AAdd
( aCampos,
{ PadR
( oSheet:
Cells( nTitRow, nCol
):
Value,
10 ),
"C",
80,
0 } ) ElseIf ValType
( oSheet:
Cells( nDatRow, nCol
):
Value ) =
"N" AADD
( aCampos,
{ PadR
( oSheet:
Cells( nTitRow, nCol
):
Value,
10 ),
"N",
13,
0 } ) ElseIf ValType
( oSheet:
Cells( nDatRow, nCol
):
Value ) =
"L" AADD
( aCampos,
{ PadR
( oSheet:
Cells( nTitRow, nCol
):
Value,
10 ),
"L",
1,
0 } ) ElseIf ValType
( oSheet:
Cells( nDatRow, nCol
):
Value ) =
"D" AADD
( aCampos,
{ PadR
( oSheet:
Cells( nTitRow, nCol
):
Value,
10 ),
"D",
8,
0 } ) Else AADD
( aCampos,
{ PadR
( oSheet:
Cells( nTitRow, nCol
):
Value,
10 ),
"C",
80,
0 } ) ENDIf oMtr:
Set( ++ nAvance
) SysRefresh
() Next CursorArrow
() If Empty
( aCampos := aEditCampos
( aCampos, cDbf
) ) oExcel:
Quit() Return Nil EndIf CursorWait
() For nRow :=
1 To Len
( aCampos
) Next DbCreate
( cDbf, aCampos
) Use
( cDbf
) New For nRow := nDatRow
To nRows
APPEND BLANK
For nCol :=
1 To nCols
uData := oSheet:
Cells( nRow, nCol
):
Value nEle := aRedir
[ AScan
( aRedir,
{|e| e
[ 1 ] == nCol
} ),
2 ] If aCampos
[ nEle,
2 ] ==
"C" If ValType
( uData
) ==
"N" uData := Mask
( uData,,, .F., .F., .F.
) Else uData := VtoC
( uData
) EndIf ElseIf aCampos
[ nEle,
2 ] ==
"N" uData := VtoN
( uData
) ElseIf aCampos
[ nEle,
2 ] ==
"D" uData := CtoD
( VtoC
( uData
) ) EndIf FieldPut
( nEle, uData
) If ( ++ nAvance % nStep
) ==
0 oMtr:
Set( nAvance
) EndIf SysRefresh
() Next Next DbCloseArea
() oExcel:
Quit() oMtr:
Set( oMtr:
nTotal ) oMtr:
Refresh() CursorArrow
()Return Nil//--------------------------------------------------------------------------------------------------------------------//Static Function fDbf2Xls
( cXls, cDbf, oMtr, lActivate, cInd, cDrv, cTitle
) Local oExcel, oSheet, oClip, oRange, nCol, cLet, nTotCol, nTotRow, nAvance, uData, ;
nRow :=
1, ;
aCol :=
{ 26,
52,
78,
104,
130,
156 }, ;
aLet :=
{ "",
"A",
"B",
"C",
"D",
"E" }, ;
lCdx := .F., ;
cText :=
"" If Empty
( cDbf
) Return Nil EndIf CursorWait
() cDbf := AllTrim
( StrTran
( Upper
( cDbf
),
".DBF" ) ) cDbf +=
".DBF" cInd :=
If( Empty
( cInd
),
"", AllTrim
( Upper
( cInd
) ) ) If ! Empty
( cInd
) If At( ".", cInd
) >
0 lCdx :=
"CDX" $ cInd
ElseIf File
( cInd +
".CDX" ) lCdx := .T.
EndIf EndIf Default cDrv :=
If( lCdx,
"DBFCDX",
"DBFNTX" ) If ! File
( Lfn2Sfn
( cDbf
) ) CursorArrow
() MsgStop
( "No Existe el Archivo", cDbf
) Return Nil EndIf If ! Empty
( cInd
) Use cDbf Shared
New VIA cDrv
Set
Index To ( cInd
) Else Use
( cDbf
) Shared
New VIA cDrv
EndIf nTotRow :=
If( ! Empty
( cInd
) .and. lCdx, OrdKeyCount
(), LastRec
() ) nTotCol :=
Min( Fcount
(),
156 ) If Empty
( nTotRow
) DbCloseArea
() CursorArrow
() MsgStop
( "Base de datos vacía",
"Error" ) Return Nil EndIf oMtr:
cText :=
"Creando hoja de Excel" oMtr:
nTotal := nTotRow + nTotCol
oMtr:
Set( nAvance :=
0 ) oMtr:
Refresh() oExcel := TOleAuto
():
New( "Excel.Application" ) oExcel:
WorkBooks:
Add() oSheet := oExcel:
Get( "ActiveSheet" ) cLet := aLet
[ AScan
( aCol,
{|e| nTotCol <= e
} ) ] If ! Empty
( cLet
) nEle := AScan
( aLet, cLet
) -
1 cLet += Chr
( 64 + nTotCol - aCol
[ Max( 1, nEle
) ] ) Else cLet := Chr
( 64 + nTotCol
) EndIf If ! Empty
( cTitle
) cText += cTitle + Chr
( 13 ) EndIf For nCol :=
1 To nTotCol
cText += UppCap
( FieldName
( nCol
) ) + Chr
( 9 ) nAvance ++
oMtr:
Set( nAvance
) SysRefresh
() Next cText += Chr
( 13 ) DbGoTop
() nStart := nRow :=
1 While ! EoF
() For nCol :=
1 To nTotCol
uData := FieldGet
( nCol
) uData :=
If( ValType
( uData
)==
"D", DtoC
( uData
),
If( ValType
( uData
)==
"N", Str
( uData
) , ;
If( ValType
( uData
)==
"L",
If( uData ,
".T." ,
".F." ), VtoC
( uData
) ) ) ) cText += AllTrim
( uData
) + Chr
( 9 ) Next cText += Chr
( 13 ) nRow ++
IF Len
( cText
) >
20000 oClip := TClipBoard
():
New() oClip:
Clear() oClip:
SetText( cText
) oRange := oSheet:
Range( "A" + LTStr
( nStart
) ) oRange:
Select() oSheet:
Paste() oClip:
End() cText :=
"" nStart := nRow +
1 EndIf DbSkip
() nAvance ++
oMtr:
Set( nAvance
) SysRefresh
() EndDo If ! Empty
( cText
) oClip := TClipBoard
():
New() oClip:
Clear() oClip:
SetText( cText
) oRange := oSheet:
Range( "A" + LTStr
( nStart
) ) oRange:
Select() oSheet:
Paste() oClip:
End() EndIf oSheet:
Range( "A1:" + cLet +
"1" ):
Set( "HorizontalAlignment",
7 ) cRange :=
"A" +
If( ! Empty
( cTitle
),
"3",
"1" ) +
":" + cLet + LTStr
( oSheet:
UsedRange:
Rows:
Count() ) oSheet:
Range( cRange
):
Borders():
LineStyle :=
1 oSheet:
Columns( "A:" + cLet
):
AutoFit() DbCloseArea
() If lActivate
oExcel:
Visible := .T.
EndIf oExcel:
Quit() oMtr:
Set( oMtr:
nTotal ) CursorArrow
()Return Nil//--------------------------------------------------------------------------------------------------------------------//Static Function aEditCampos
( aCampos, cDbf
) Local oDlg, oBrw, oFont, cGet, cAnt, cSay, aCtl
[ 10 ], oDrCur, nBase, nEle, ;
aDbf := aCampos, ;
lOk := .F., ;
lRenamed := .F., ;
lCopy := .F., ;
nAvance :=
0, ;
aCla :=
{ "C",
"N",
"D",
"L",
"M" }, ;
aTip :=
{ "Alfanumérico",
"Numérico",
"Fecha",
"Lógico",
"Memo" } aRedir :=
{} cGet := cAnt :=
If( At( "\", cDbf ) > 0, cDbf, cFilePath( GetModuleFileName( GetInstance() ) ) + cDbf )
cSay := "Campo
1" + Space( 3 ) + Trim( aDbf[ 1, 1 ] )
For nEle := 1 To Len( aDbf )
AAdd( aRedir, { nEle, nEle } )
Next
DEFINE FONT oFont NAME "MS Sans Serif
" SIZE 0, -8
DEFINE CURSOR oDrCur RESOURCE "Drag
"
DEFINE DIALOG oDlg FROM 0, 0 TO 388, 380 PIXEL FONT oFont ;
STYLE nOr( WS_POPUP, WS_BORDER ) ;
COLOR CLR_BLACK, CLR_HBROWN
@ 0, 0 SAY aCtl[ 1 ] PROMPT "Crear Base de Datos
" OF oDlg ;
SIZE 192, 9 PIXEL CENTER ;
COLOR CLR_WHITE, CLR_BLUE FONT oFont
@ 13, 20 Group aCtl[ 2 ] To 29, 192 OF oDlg LABEL "Guardar Como
" ;
PIXEL
@ 19, 23 SAY aCtl[ 3 ] VAR cGet SIZE 142, 8 PIXEL OF oDlg BORDER
@ 51, 20 SAY aCtl[ 5 ] VAR cSay OF oDlg SIZE 148, 8 PIXEL ;
COLOR CLR_WHITE, 8323200 BORDER CENTER
@ 61, 20 BROWSE aCtl[ 6 ] ARRAY aDbf OF oDlg CELLED SIZE 148, 93 PIXEL ;
COLORS CLR_BLACK, CLR_WHITE, CLR_BLACK, CLR_HGRAY, CLR_WHITE, CLR_BLACK
aCtl[ 6 ]:bChange := { || cSay := "Campo
" + Space( 1 ) + ;
LTStr( aCtl[ 6 ]:nAt ) + Space( 3 ) + ;
If( aCtl[ 6 ]:nAt > 0 .and. ;
Len( aCtl[ 6 ]:aArray ) > 0 .and. ;
! aCtl[ 6 ]:lAppendMode, ;
aCtl[ 6 ]:aArray[ aCtl[ 6 ]:nAt ][ 1 ], "" ), ;
aCtl[ 5 ]:Refresh() }
ADD COLUMN TO aCtl[ 6 ] DATA ARRAY ELM 1 TITLE "Nombre
" ;
VALID { |uVar| ! Empty( uVar ) } PICTURE "@K!
" ;
ALIGN DT_LEFT, DT_CENTER SIZE 80 PIXELS ;
POSTEDIT { || lRenamed := If( aCtl[ 6 ]:lChanged, .T., lRenamed ) } ;
EDITABLE MOVE DT_MOVE_RIGHT
ADD COLUMN TO aCtl[ 6 ] COMBOBOX TITLE "Tipo
" ;
DATA ComboWBlock( aCtl[ 6 ], 2, 2, { aTip, aCla } ) ;
ALIGN DT_LEFT, DT_CENTER SIZE 70 PIXELS ;
EDITABLE MOVE DT_MOVE_NEXT ;
POSTEDIT { |v,o,c| c := o:aArray[ o:nAt, 2 ], o:aArray[ o:nAt, 3 ] := ;
If( c == "L
", 1, If( c == "D
", 8, o:aArray[ o:nAt, 3 ] ) ), ;
o:aArray[ o:nAt, 4 ] := If( c != "N
", 0, o:aArray[ o:nAt, 4 ] ) }
ADD COLUMN TO aCtl[ 6 ] DATA ARRAY ELM 3 TITLE "Longitud
" ;
WHEN ( aCtl[ 6 ]:aArray[ aCtl[ 6 ]:nAt, 2 ] $ "CN
" ) ;
PICTURE "@K!
" ALIGN DT_LEFT SIZE 55 PIXELS ;
EDITABLE MOVE DT_MOVE_NEXT
ADD COLUMN TO aCtl[ 6 ] DATA ARRAY ELM 4 TITLE "Decimales
" ;
WHEN aCtl[ 6 ]:aArray[ aCtl[ 6 ]:nAt, 2 ] == "N
" ;
VALID { |uVar| uVar <= 9 } ;
PICTURE "@K
" ALIGN DT_RIGHT, DT_CENTER SIZE 65 PIXELS ;
EDITABLE MOVE DT_MOVE_NEXT
aCtl[ 6 ]:lNoHScroll := .T.
aCtl[ 6 ]:lNoExit := .T.
aCtl[ 6 ]:SetAppendMode( .T. )
aCtl[ 6 ]:SetDeleteMode( .T., .F. )
aCtl[ 6 ]:aDefault := { Space( 10 ), "C
", 10, 0 }
aCtl[ 6 ]:bKeyDown := { |nKey| If( nKey = VK_INSERT, ( ASize( aCtl[ 6 ]:aArray, Len( aCtl[ 6 ]:aArray ) + 1 ), ;
AIns( aCtl[ 6 ]:aArray, aCtl[ 6 ]:nAt ), ;
aCtl[ 6 ]:aArray[ aCtl[ 6 ]:nAt ] := aCtl[ 6 ]:aDefault, ;
aCtl[ 6 ]:Refresh( .T. ) ), Nil ) }
aCtl[ 6 ]:oDragCursor := oDrCur
aCtl[ 6 ]:bDropOver := { |u,n| nDest := u[ 2 ]:GetTxtRow( n ), ;
fDropDrag( u[ 3 ], u[ 2 ]:GetTxtRow( n ), u[ 1 ], u[ 2 ] ) }
aCtl[ 6 ]:bDragBegin = { |nRow,nCol,nFlags,x| nFrom := x:nAt, SetDropInfo( { x:nAt, x, x:nRowPos } ) }
@158, 20 BUTTON aCtl[ 7 ] PROMPT "Crear
" OF oDlg SIZE 40, 12 PIXEL ;
ACTION ( aDbf := aCtl[ 6 ]:aArray, lOk := .T., oDlg:End() )
@158,127 BUTTON aCtl[ 8 ] PROMPT "Salir
" OF oDlg SIZE 40, 12 PIXEL ;
ACTION oDlg:End() CANCEL
oDlg:bGotFocus := { || aCtl[ 6 ]:SetFocus() }
ACTIVATE DIALOG oDlg CENTERED ON INIT aCtl[ 6 ]:SetFocus() ;
VALID ( oFont:End(), oDrCur:End(), .T. )
If ! lOk
aDbf := {}
EndIf
Return aDbf
//--------------------------------------------------------------------------------------------------------------------//
Static Function cGetFileName( lXls )
Default lXls := .T.
Return LongFileName( cGetFile32( If( lXls, "Libro Excel
(*.xls
) | *.xls
", "Base de Datos
(*.dbf
) | *.dbf
" ), ;
"Selecciona el Archivo
",,, .F. ) )
//--------------------------------------------------------------------------------------------------------------------//
Static Function fDropDrag( nSourceRow, nTargetRow, nAt, oBrw )
Local aItem, nEle, nAnt, nSkip
If ! ( ValType( nSourceRow ) == "N
" .and. ValType( nTargetRow ) == "N
" .and. ;
nSourceRow >= 1 .and. nTargetRow >= 1 .and. nSourceRow <= Len( oBrw:aArray ) .and. ;
nTargetRow <= Len( oBrw:aArray ) )
Return Nil
EndIf
nSkip := nTargetRow - nSourceRow
If nSkip < 0
nEle := AScan( aRedir, {|e| e[ 1 ] == nAt } )
aRedir[ nEle, 2 ] := nAt + nSkip // nTargetRow
For nAnt := 1 To ( nAt - 1 )
aRedir[ nAnt, 2 ] ++
Next
Else
nEle := AScan( aRedir, {|e| e[ 1 ] == nAt } )
aRedir[ nEle, 2 ] := nTargetRow
For nAnt := Len( aRedir ) To ( nAt + 1 ) Step -1
aRedir[ nAnt, 2 ] --
Next
EndIf
aItem := AClone( oBrw:aArray[ nAt ] )
ADel( oBrw:aArray, nAt )
nAt += nSkip
AIns( oBrw:aArray, nAt )
oBrw:aArray[ nAt ] := AClone( aItem )
oBrw:Refresh()
oBrw:lHasChanged := .T.
Return Nil
//--------------------------------------------------------------------------------------------------------------------//
Function fTraMsg()
Return Nil
//--------------------------------------------------------------------------------------------------------------------//
Function fManMsg()
Return Nil
//--------------------------------------------------------------------------------------------------------------------//
Static Function LongFileName( cShName )
Local nLen, ;
cBuffer := Space( 255 ), ;
cFilNam := Space( 255 )
cShName := AllTrim( cShName )
nLen := GetFullName( cShName, 255, @cBuffer, @cFilNam )
Return UppCap( Left( cBuffer, nLen ) )
//--------------------------------------------------------------------------------------------------------------------//
DLL32 Static Function GetFullName( cFileName AS STRING, nBuffer AS LONG, @lpBuffer AS STRING, @lpFilePart AS STRING ) ;
AS LONG PASCAL FROM "GetFullPathNameA
" LIB "kernel32.dll
"