* Перевод в Excel из Grid делаю с помощью GRIDTOEXCEL,из курсора с помощью CURSORTOEXCEL
* тексты GRIDTOEXCEL, CURSORTOEXCEL приведены ниже
* пример перевода из курсора в Excel с последующей выдачей промежуточных итогов и оформления шапки
SELE 0
CREATE CURSOR SOCW (KP N(10),TN C(5),FIO C(40),SUMZ N(16,2),SUMP N(20,2),SUMR N(20,2),S35 N(20,2),S1 N(20,2),PRW L(1))
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (5,'4729 ','Мартинкевич Ярослав Леонардович ',136.33,375.00,238.67,81.15,2.39,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (5,'4730 ','Мартинкевич Андрей Леонардович ',118.37,375.00,256.63,87.25,2.57,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (8,'4778 ','Бурдиенко Олег Васильевич ',300.60,357.86,57.26,19.47,0.57,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (10,'4794 ','Молявко Анна Ежиевна ',-3.04,0.00,3.04,1.03,0.03,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (18,'4158 ','Василевская Ванда Альбиновна ',84.60,100.71,16.11,5.48,0.16,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (18,'4820 ','Перко Наталья Ивановна ',281.77,375.00,93.23,31.70,0.93,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (19,'4441 ','Якубчик Тереза Станиславовна ',273.99,367.07,93.08,31.65,0.93,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (19,'4751 ','Нехвядович Анастасия Валентиновна ',261.74,372.86,111.12,37.78,1.11,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (21,'4863 ','Савуль Александр Станиславович ',25.95,51.43,25.48,8.66,0.25,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (24,'4100 ','Максимова Людмила Викторовна ',66.82,68.57,1.75,0.60,0.02,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (24,'4331 ','Сягло Оксана Ивановна ',366.52,375.00,8.48,2.88,0.08,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (24,'4366 ','Мурачинская Татьяна Александровна ',161.07,171.43,10.36,3.52,0.10,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (24,'4487 ','Анацко Иван Викторович ',244.48,257.14,12.66,4.30,0.13,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (24,'4584 ','Барановский Эдуард Цезарьевич ',198.88,272.14,73.26,24.91,0.73,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (24,'4615 ','Яговдик Екатерина Александровна ',245.97,375.00,129.03,43.87,1.29,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (24,'4767 ','Радевич Оксана Владимировна ',324.63,375.00,50.37,17.13,0.50,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (24,'736 ','Дуки Викентий Чеславович ',352.35,375.00,22.65,7.70,0.23,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (18,'3602 ','Жук Татьяна Александровна ',361.40,411.99,50.59,8.84,0.26,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (18,'3710 ','Чижик Анна Яновна ',242.88,276.88,34.00,11.56,0.34,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (18,'4623 ','Керней Марина Александровна ',209.84,256.94,47.10,15.98,0.47,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (18,'4643 ','Василевская Ванда Альбиновна ',238.78,292.38,53.60,18.36,0.54,.T.)
INSERT INTO SOCW (KP,TN,FIO,SUMZ,SUMP,SUMR,S35,S1,PRW) VALUES (18,'4821 ','Якубчик Ольга Игоревна ',310.08,394.27,84.19,26.52,0.78,.T.)
*!* oGrid=This.Parent.Grid1
*!* cFileName=''
*!* oExcel=GRIDTOEXCEL(oGrid,cFileName)
*!* With oGrid
*!* cGridFile=.RecordSource
*!* Select (cGridFile)
*!* Count To nReccount
*!* KPL=FCOUNT()
*!* If nReccount=0
*!* Messagebox('Нет данных!',48,'Экспорт в Excel')
*!* Return .F.
*!* Endif
*!* endwith
Select SOCW
Count To nReccount
KPL=FCOUNT()
If nReccount=0
Messagebox('Нет данных!',48,'Экспорт в Excel')
Return .F.
Endif
SAPKA=[Подразд.*Таб.№*Ф И О*З/п*Прожит.мин.*Отклон.от минимума*34%соц.страх*1%соц.страх*Доплатить*]
oExcel=CURSORTOEXCEL('SOCW')
with oExcel
cRangeObj = .ActiveSheet.Range(.Cells(1,1),.Cells(nReccount+1,KPL))
dimension atemp[5]
atemp(1)=4
atemp(2)=5
atemp(3)=6
atemp(4)=7
atemp(5)=8
xlsum=-4157
xlCellTypeFormulas=-4123
cRangeObj.Subtotal(1,xlSum,@atemp,.t.,.f.,.t.)
.ActiveSheet.Range(.ActiveSheet.Columns(1),.ActiveSheet.Columns(kpl)).AutoFit
.Selection.SpecialCells(xlCellTypeFormulas, 23).Select
.Selection.Font.Bold = .T.
* ЗАПОЛНИМ ШАПКУ
nGR=GetWordCount(SAPKA,'*')
FOR I=1 TO nGR
.ActiveSheet.Cells(1,I).Value = GETWORDNUM(SAPKA,I,'*')
ENDFOR
endwith
****************************************************************************************************
PROCEDURE CURSORTOEXCEL
#define cNotReadableSymbols '{}!@^+|`~;<>?$%*&#()[]\/.,:-="'+[']+Chr(32)
Lparameters cCurName
Local cMaska,cGridFile,nReccount,i2,cIndex,nCol,cCaption, ;
arrCaptions[1],arrSelectItems[1],arrFields[1,2], ;
cItem,cFile,cName,cField,cSelectRow,cFilter,cKey,cNewKey,cOrder,lDescending,cCursor, ;
oErr,lRet,oExcel,nLine,nIndex, ;
cRangeObj,cABC,cBukva,nLen, ;
loColumn, loHeader, lnArrRow, lnTag,nColumn
cMaska=Replicate('_',Len(cNotReadableSymbols))
SELECT (cCurName)
nColumn=FCOUNT()
nReccount=RECCOUNT()
*!* If Empty(cFileName)
*!* cFileName=addbs(sys(2023)) + ;
*!* Juststem(cCurName)+'.xls'
*!* ENDIF
Try
* Copy To (cFileName) Type Xl5
oEXCEL=CREATEOBJECT("EXCEL.APPLICATION")
oExcel.Workbooks.Add
oSheet1 = oExcel.WorkSheets("Лист1")
SELECT (cCurName)
Count To nReccount
GO top
_vfp.DataToClip(,,3)
With oSheet1
.PasteSpecial("Текст",.F.,.F.)
EndWith
Catch To oErr
Endtry
*oEXCEL=CREATEOBJECT("EXCEL.APPLICATION")
with oExcel
*!* .Workbooks.Add(cFileName)
*!* erase (cFileName)
.ActiveSheet.Range(.ActiveSheet.Columns(1),.ActiveSheet.Columns(nColumn)).AutoFit
cRangeObj = .ActiveSheet.Range(.Cells(1,1),.Cells(1,nColumn))
with cRangeObj
.Font.Color = Rgb(0,0,128)
.Font.Name = 'Times'
.Font.Size = 9
.Font.FontStyle = 'Bold'
.Interior.ColorIndex=8
.Interior.Pattern=1
.HorizontalAlignment=2
endwith
nIndex=nColumn
cABC="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
nLen=Len(cABC)
If nIndex<=nLen
cBukva=Substr(cABC,nIndex,1)
Else
If nIndex%nLen=0
cBukva=Substr(cABC,Int(nIndex/nLen)-1,1)+Substr(cABC,nLen,1)
Else
cBukva=Substr(cABC,Int(nIndex/nLen),1)+Substr(cABC,Int(nIndex%nLen),1)
Endif
Endif
.ActiveSheet.Range('A1:'+cBukva+'1').Select()
Try
With .Selection
.BorderS(5).LineStyle=-4142
.BorderS(6).LineStyle=-4142
With .BorderS(7)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(8)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(9)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(10)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(11)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(12)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
Endwith
Catch When .T.
Endtry
.ActiveSheet.Range('A2:'+cBukva+Transform(nReccount+1)).Select()
Try
With .Selection
.BorderS(5).LineStyle=-4142
.BorderS(6).LineStyle=-4142
With .BorderS(7)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(8)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(9)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(10)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(11)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(12)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
Endwith
Catch When .T.
Endtry
.ActiveSheet.Range(.Cells(1,1),.Cells(1,1)).Select()
.Visible = .T.
ENDWITH
RETURN oEXCEL
*******************************************************************************
PROCEDURE GRIDTOEXCEL
#define cNotReadableSymbols '{}!@^+|`~;<>?$%*&#()[]\/.,:-="'+[']+Chr(32)
Lparameters oGrid,cFileName
Local cMaska,cGridFile,nReccount,i2,cIndex,nCol,cCaption, ;
arrCaptions[1],arrSelectItems[1],arrFields[1,2], ;
cItem,cFile,cName,cField,cSelectRow,cFilter,cKey,cNewKey,cOrder,lDescending,cCursor, ;
oErr,lRet,oExcel,nLine,nIndex, ;
cRangeObj,cABC,cBukva,nLen, ;
loColumn, loHeader, lnArrRow, lnTag
cMaska=Replicate('_',Len(cNotReadableSymbols))
With oGrid
cGridFile=.RecordSource
Select (cGridFile)
Count To nReccount
If nReccount=0
Wait Clear
Messagebox('Нет данных!',48,'Экспорт в Excel')
Return .F.
Endif
For Each loColumn In .Columns
If loColumn.Visible
nCol= loColumn.ColumnOrder
For Each loControl In loColumn.Controls
If Lower(loControl.BaseClass)="header"
loHeader = loControl
Exit
Endif
Endfor
cCaption=loHeader.Caption
If Empty(cCaption)
cCaption='Колон_'+Transform(nCol)
Else
cCaption=Strtran(cCaption,'№','_номер_')
cCaption=Strtran(cCaption,'$','_валют_')
cCaption=Chrtran(cCaption,cNotReadableSymbols,cMaska)
Do While At('__',cCaption)>0
cCaption=Strtran(cCaption,'__','_')
Enddo
If Right(cCaption,1)=='_' And Len(cCaption)>1
cCaption=Left(cCaption,Len(cCaption)-1)
Endif
If Left(cCaption,1)=='_' And Len(cCaption)>1
cCaption=Substr(cCaption,2)
Endif
cCaption = iif( Isdigit(cCaption), '_'+cCaption, cCaption)
Do While Ascan(arrCaptions,cCaption)>0
cCaption=cCaption+'_'
Enddo
If Alen(arrCaptions,1)<nCol
Dimension arrCaptions[nCol]
Endif
arrCaptions[nCol]=cCaption
If !Empty(loColumn.ControlSource)
If Alen(arrSelectItems,1)<nCol
Dimension arrSelectItems[nCol]
Endif
arrSelectItems[nCol] = iif(type(loColumn.ControlSource)="M", ;
"cast("+loColumn.ControlSource+" as c(254))", ;
loColumn.ControlSource) + ' AS ' + cCaption
If Alen(arrFields,1)<nCol
Dimension arrFields[nCol,2]
Endif
cItem=Upper(loColumn.ControlSource)
If At('.',cItem)=0
arrFields[nCol,1]=cItem
arrFields[nCol,2]=Upper(cGridFile)
Else
If Upper(cGridFile)$cItem
arrFields[nCol,1]=Substr(cItem,At('.',cItem)+1)
arrFields[nCol,2]=Upper(cGridFile)
Else
cFile=Substr(cItem,1,At('.',cItem)-1)
cName=''
For i2=Len(cFile) To 1 Step -1
If Substr(cFile,i2,1)$cNotReadableSymbols
Exit
Else
cName=Substr(cFile,i2,1)+cName
Endif
Endfor
arrFields[nCol,2]=cName
cField=Substr(cItem,At('.',cItem)+1)
cName=''
For i2=1 To Len(cField)
If Substr(cField,i2,1)$cNotReadableSymbols
Exit
Else
cName=cName+Substr(cField,i2,1)
Endif
Endfor
arrFields[nCol,1]=cName
Endif Upper(cGridFile)$cItem
Endif At('.',cItem)=0
Endif && !empty(loColumn.CONTROLSOURCE)
Endif
Endif
Endfor
cSelectRow=''
For lnArrRow = 1 To Alen(arrSelectItems,1)
If !Empty(arrSelectItems[lnArrRow])
cSelectRow = cSelectRow + Iif( !Empty(cSelectRow), ",", "") + arrSelectItems[lnArrRow]
Endif
Endfor
Endwith
*****************************************************
If Empty(cFileName)
cFileName=addbs(sys(2023)) + ;
Juststem(cGridFile)+'.xlsx'
Endif
cFilter = Filter(cGridFile)
cFilter = iif( Empty(cFilter), '.T.', cFilter)
Select (cGridFile)
cOrder=Order()
If !Empty(cOrder)
lDescending=Descending()
For lnTag = 1 To Tagcount()
If !Empty(Tag(lnTag))
If Tag(lnTag)==cOrder
cKey=Key(lnTag)
Exit
Endif
Else
Exit
Endif
Endfor
cNewKey=Upper(cKey)
For lnArrRow=1 To Alen(arrFields,1)
If Type('arrFields[lnArrRow,2]')='C' And arrFields[lnArrRow,2]==Upper(cGridFile)
cNewKey=Strtran(cNewKey,Upper(arrFields[lnArrRow,1]),Substr(arrSelectItems[lnArrRow],At('AS ',arrSelectItems[lnArrRow])+3))
Endif
Endfor
Endif
cCursor=Sys(2015)
oErr=.Null.
Try
Select &cSelectRow ;
FROM (cGridFile) ;
WHERE &cFilter ;
INTO Cursor (cCursor) Readwrite
Catch To oErr
Endtry
If Vartype(oErr)=='O' And !Isnull(oErr)
Messagebox('Ошибка при выполнении запроса: '+oErr.Message,48,'Экспорт в Excel')
Use In Select(cCursor)
Return lRet
Endif
If _Tally=0
Messagebox("Нет информации для экспорта в Microsoft Excel",48,'Экспорт в Excel')
Use In Select(cCursor)
Return lRet
Endif
If !Empty(cOrder)
oErr=.Null.
Try
Index On &cNewKey Tag curOrder
Catch To oErr
Endtry
If !(Vartype(oErr)='O' And !Isnull(oErr))
If lDescending
Set Order To Tag curOrder Descending
Else
Set Order To Tag curOrder
Endif
Endif
Endif
Dimension arrFields[1]
arrFields=.F.
Select (cCursor)
Afield(arrFields)
oErr=.Null.
***************************************************
Try
*!* Copy To (cFileName) Type Xl5
oEXCEL=CREATEOBJECT("EXCEL.APPLICATION")
oExcel.Workbooks.Add
oSheet1 = oExcel.WorkSheets("Лист1")
SELECT (cCursor)
Count To nReccount
GO top
_vfp.DataToClip(,,3)
With oSheet1
.PasteSpecial("Текст",.F.,.F.)
EndWith
Catch To oErr
Endtry
***********************************************
Use In Select(cCursor)
If !Isnull(oErr)
Messagebox('Ошибка экспорта в Excel'+Chr(13)+oErr.Message,48,'Экспорт в Excel')
Return lRet
Endif
oErr=.Null.
*!* Try
*!* oExcel=Createobject("Excel.Application")
*!* Catch To oErr
*!* Endtry
*!* If !Isnull(oErr)
*!* Messagebox('Ошибка запуска Excel'+Chr(13)+oErr.Message,48,'Экспорт в Excel')
*!* Return lRet
*!* Endif
with oExcel
*!* .Workbooks.Add(cFileName)
*!* erase (cFileName)
nLine=1
For i=1 To Alen(arrFields,1)
.ActiveSheet.Cells(nLine,i).Value=arrFields[i,1]
Endfor
cRangeObj = .ActiveSheet.Range(.Cells(nLine,1),.Cells(nLine,Alen(arrFields,1)))
with cRangeObj
.Font.Color = Rgb(0,0,128)
.Font.Name = 'Times'
.Font.Size = 9
.Font.FontStyle = 'Bold'
.Interior.ColorIndex=8
.Interior.Pattern=1
.HorizontalAlignment=2
endwith
.ActiveSheet.Range(.ActiveSheet.Columns(1),.ActiveSheet.Columns(Alen(arrFields,1))).AutoFit
nIndex=Alen(arrFields,1)
cABC="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
nLen=Len(cABC)
If nIndex<=nLen
cBukva=Substr(cABC,nIndex,1)
Else
If nIndex%nLen=0
cBukva=Substr(cABC,Int(nIndex/nLen)-1,1)+Substr(cABC,nLen,1)
Else
cBukva=Substr(cABC,Int(nIndex/nLen),1)+Substr(cABC,Int(nIndex%nLen),1)
Endif
Endif
.ActiveSheet.Range('A1:'+cBukva+'1').Select()
Try
With .Selection
.BorderS(5).LineStyle=-4142
.BorderS(6).LineStyle=-4142
With .BorderS(7)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(8)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(9)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(10)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(11)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(12)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
Endwith
Catch When .T.
Endtry
.ActiveSheet.Range('A2:'+cBukva+Transform(nReccount+1)).Select()
Try
With .Selection
.BorderS(5).LineStyle=-4142
.BorderS(6).LineStyle=-4142
With .BorderS(7)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(8)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(9)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(10)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(11)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
With .BorderS(12)
.LineStyle=1
.Weight=2
.ColorIndex=-4105
Endwith
Endwith
Catch When .T.
Endtry
.ActiveSheet.Range(.Cells(1,1),.Cells(1,1)).Select()
.Visible = .T.
endwith
Return oExcel