Joined: 27 Jun 2005 Posts: 1000 Location: Горбунов Константин Occupation: БЭСТ-Партнер Interests: СПб
Posted: 23 Apr 2007 19:40 Post subject:
1
Code:
FUNCTION NWDoc(cField,xKey,cPre,cTag,cAlias,lClearScope)
//----------------------------------------------------------------------------//
// Генерирует следущий номер документа
// Работает только с символьными полями
// cField - имя поля
// xKey - текущее значение ключа для идентификации раздела !!!
// [cPre] - префикс для идентификации данного типа генерации в пределах текущего
// сеанса выполнения АРМ'а
// [cTag] - имя тега
// [cAlias] - алиас для доступа к счетчикам. По умолчанию MEMDAT.
// [lClearScope] - очистка Scope
// ВНИМАНИЕ !! Требует открытой базы с алиасом cAlias с полями :
// IDENT C 50, VALUE C 50, LEN N 2 0, TYPE C 1
// проиндексированной по UPPER(IDENT)
// Смотри: NVDOC(), NControlMem()
Joined: 27 Jun 2005 Posts: 1000 Location: Горбунов Константин Occupation: БЭСТ-Партнер Interests: СПб
Posted: 23 Apr 2007 19:46 Post subject:
2.
Code:
//----------------------------------------------------------------------------//
FUNCTION NVDoc(nAdd,nGet,cField,xKey,cPre,cTag,lRight,cAlias,bVar,lNoSoob,lClearScope,lValidEdit)
//----------------------------------------------------------------------------//
// nAdd - режим nApp
// nGet - номер в GetList
// xKey - текущее значение ключа для идентификации раздела !!!
// [cPre] - префикс для идентификации данного типа генерации в пределах текущего
// сеанса выполнения АРМ'а
// [cTag] - имя тега
// [lRight] - если .T. то сдвиг вправо
// [cAlias] - алиас для доступа к счетчикам. По умолчанию MEMDAT.
// [bVar] - блок кода доступа к переменной. По умолчанию {|x| IF(x != NIL,aIn[SeekPos(cField)] := x,aIn[SeekPos(cField)]) }
// или из GET-буфера
// [lNoSoob] - выдавать ли сообщение о дублировании
// может быть блоком кода,
// если EVAL(lNoSoob) вернет .T., то сообщение не выдается
// ВНИМАНИЕ !! Требует открытой базы с алиасом cAlias с полями :
// IDENT C 50, VALUE C 50, LEN N 2 0
// проиндексированной по UPPER(IDENT)
// [lClearScope] - очистка Scope
// [lValidEdit] - проверка всегда как редактирование
// Смотри : NWDOC(), NControlMem()
LOCAL lRet:=.T.
LOCAL nRec := RECNO()
LOCAL lSeek := .F.,x, cKey
LOCAL cIdent := UPPER(cPre+IF(xKey=NIL,"",xKey))
LOCAL cLast:=pLastNum,cNext:=pNextNum,cNext0
LOCAL bEnd := {||;
DBSEEK(SUBSTR(xKey,1,LEN(xKey)-1)+CHR(ASC(SUBSTR(xKey,-1))+1),.T.),;
dbSkip(-1),;
IF((!(xKey=LEFT(&(INDEXKEY()),LEN(xKey)))),;
BLANK(EVAL(FIELDBLOCK(cField)),.T.),;
EVAL(FIELDBLOCK(cField));
);
}
IF(ValType(cAlias) = "C",,cAlias := "MEMDAT")
IF(ValType(lValidEdit) = "L",,lValidEdit := .F.)
dbPush()
IF(lClearScope != NIL .AND. lClearScope ,SetScope(),NIL)
IF(ValType(bVar) = "B",,bVar := {|x| IF(x != NIL,aIn[IF(VarSeekPos(cField,SetSeekPos()) = 0,nGet,VarSeekPos(cField,SetSeekPos()))] := x,aIn[IF(VarSeekPos(cField,SetSeekPos()) = 0,nGet,VarSeekPos(cField,SetSeekPos()))]) })
IF(ValType(cTag) = "C",ORDSETFOCUS(cTag),NIL)
cPre:=IF(cPre=NIL,"",cPre)
IF !EMPTY(lRight) //Случай для документов (не для аналитики)
IF nGet != NIL
ToRight(nGet,.T.)
ELSE
EVAL(bVar,ObrabotkaNom(EVAL(bVar)))
ENDIF
ENDIF
IF nGet != NIL
m->GetList[nGet]:display()
ENDIF
cKey := IF(xKey==NIL,'',xKey)+UPPER(IF(nGet = NIL .OR. m->GetList[nGet]:buffer=NIL,EVAL(bVar),m->GetList[nGet]:buffer))
DBSEEK(cKey)
DBEVAL({|| lSeek := .T. },{|| (nAdd = 2 .AND. !lValidEdit) .OR. nRec != RECNO() },{|| &(ORDKEY()) = cKey.AND.!lSeek })
IF (LASTKEY()!=K_UP)
IF (nAdd==1 .OR. lValidEdit) .AND. lSeek .OR. (nAdd=2 .AND. !lValidEdit .AND. lSeek)
IF IF(ValType(lNoSoob) = "B",!EVAL(lNoSoob),EMPTY(lNoSoob))
SayError('Такой номер уже имеется')
ENDIF
lRet:=.F.
ELSEIF nAdd=2
cNext0:=pNextNum:=EVAL(bVar) //Случай для дополнения аналитики
IF (cAlias)->(dbSeek(PADR(cIdent,LEN((cAlias)->IDENT))))
IF (cAlias)->TYPE = "C"
pNextNum := LEFT((cAlias)->VALUE,(cAlias)->LEN)
ELSEIF (cAlias)->TYPE = "D"
pNextNum := CTOD((cAlias)->VALUE)
ENDIF
ENDIF
Joined: 27 Jun 2005 Posts: 1000 Location: Горбунов Константин Occupation: БЭСТ-Партнер Interests: СПб
Posted: 23 Apr 2007 19:48 Post subject:
3.
Code:
//----------------------------------------------------------------------------//
FUNCTION NControlMem(xKey,cPre,cAlias,lDel)
//----------------------------------------------------------------------------//
// Отмена сгенерированного значения NWDOC()
// xKey - значение ключа для идентификации раздела !!!
// [cPre] - префикс для идентификации данного типа генерации в пределах текущего
// сеанса выполнения АРМ'а
// [cAlias] - алиас для доступа к счетчикам. По умолчанию MEMDAT.
// [lDel] - очистка счетчика
// ВНИМАНИЕ !! Требует открытой базы с алиасом cAlias с полями :
// IDENT C 50, VALUE C 50, LEN N 2 0
// проиндексированной по UPPER(IDENT)
// Смотри: NWDOC(), NVDOC()
LOCAL cIdent := UPPER(cPre+IF(xKey=NIL,"",xKey))
LOCAL cNum0:=pNextNum,cFile, lBottom, nRec := RECNO()
xKey:=IF(xKey==NIL,'',xKey)
cPre:=IF(cPre=NIL,"",cPre)
IF(ValType(cAlias) = "C",,cAlias := "MEMDAT")
IF (cAlias)->(dbSeek(PADR(cIdent,LEN((cAlias)->IDENT))))
IF (cAlias)->TYPE = "C"
pNextNum := LEFT((cAlias)->VALUE,(cAlias)->LEN)
ELSEIF (cAlias)->TYPE = "D"
pNextNum := CTOD((cAlias)->VALUE)
ENDIF
ENDIF
IF pNextNum=cNum0
pNextNum:= pLastNum
IF (cAlias)->(EOF() .AND. AddRec()) .OR. (cAlias)->(RecLock())
IF EMPTY(lDel) .AND. ValType(XTOC(pNextNum)) = "C"
(cAlias)->VALUE := XTOC(pNextNum)
(cAlias)->LEN := LEN(XTOC(pNextNum))
(cAlias)->IDENT := cIdent
(cAlias)->TYPE := ValType(pNextNum)
(cAlias)->(dbUnLock())
ELSEIF !EMPTY(lDel).OR.(dbPush(),dbGoBottom(),lBottom := (nRec = Recno()),dbPop(),lBottom)
(cAlias)->VALUE := BLANK((cAlias)->VALUE,.T.)
ENDIF
ENDIF
ENDIF
RETURN(NIL)
Joined: 27 Jun 2005 Posts: 1000 Location: Горбунов Константин Occupation: БЭСТ-Партнер Interests: СПб
Posted: 14 May 2007 19:11 Post subject:
5.
Code:
FUNCTION Jrn_Write(nAdd)
STATIC sPre:="!"
LOCAL nArea:=SELECT(),cReestr:=Jrn_Reestr(),aRee
LOCAL cUserName:=PADR(IF(EMPTY(_USER_NAME),SUBSTR(IDENT_USER,COUNTLEFT(IDENT_USER,"0")+1),_USER_NAME),25)
LOCAL cPre
IF EMPTY(cReestr).OR.;
UPPER(sPre)==(cPre:=UPPER(DTOS(Date())+LEFT(Time(),5)+cReestr+cUserName+;
STR(EVAL(aKeys[cReestr,P_NNOPER]),17,0)+STR(nAdd,1,0)))
RETURN .T.
ENDIF
NetUse("Jrn_Sys",LoadPath()+"Jrn")
AddRec()
REPLACE Date WITH Date(),Time WITH LEFT(Time(),5),Reestr WITH cReestr,;
UserName WITH cUserName,;
NNOper WITH (nArea)->(EVAL(aKeys[cReestr,P_NNOPER])),Oper WITH STR(nAdd,1,0)
sPre:=DTOS(Date)+TIME+Reestr+UserName+STR(NNOPER,17,0)+Oper
REPLACE UserName WITH Crypt(UserName,PAROL)
//IF nAdd==3//пишем всегда, иначе при уалении теряются концы в предыдущих записях
aRee:=aKeys[cReestr]
REPLACE Comment WITH ;
(nArea)->(;
EVAL1(aRee[P_JRN])+";"+EVAL1(aRee[P_DOC])+;
";"+DTOC(EVAL(aRee[P_DATE]))+";"+;
EVAL1(aRee[P_AGENTNAME])+";"+;
STR(EVAL(aRee[P_SUMMA]),14,2);
)
//ENDIF
Joined: 27 Jun 2005 Posts: 1000 Location: Горбунов Константин Occupation: БЭСТ-Партнер Interests: СПб
Posted: 14 May 2007 19:14 Post subject:
6.
Code:
FUNCTION Jrn_Reestr()
LOCAL cRet:="",i,cPath:=SUBSTR(UPPER(LoadPath()),3),c
SetKeys()
altd()
IF _JRN_YES
c:=UPPER(dbinfo(10))
i:=AT(cPath,c)+LEN(cPath)
TRY
cRet:=aReestr[SUBSTR(c,i)]
CATCH
cRet:=""
END
ENDIF
RETURN cRet
Joined: 27 Jun 2005 Posts: 1000 Location: Горбунов Константин Occupation: БЭСТ-Партнер Interests: СПб
Posted: 13 Jul 2007 14:46 Post subject:
8.
Code:
FUNCTION GenPro( dDat1, dDat2, nMode, nMode1, lPriS0, lPereMbp, aDoc, lOnly, lAct)
#DEFINE VIDTYPE IF(m->plAct, Status+"$", Vid+Type)
//nMode=2 - все проводки, 1 - отложенные
//nMode1=1 - запись в главную книгу, 2 - в буфер MProBuf
//lPris0 - если присутствует, то обрабатываются только проводки c S0
//lSpisMbp - перерасчитывать ведомости списания МБП
//aDoc - массив документов {UPPER(Sclad+Vid+Type+CodeDoc+NumDoc)}
//lOnly - только новые проводки
//lAct - Проводки по актам переоценки (только для "розницы", обязательно aDoc)
LOCAL cSDoc:= IF(EMPTY(lAct), "MDoc", "MPere")
LOCAL nArea := SELECT()
LOCAL nSumma, aMat, aPro, aPrePro, i, nSum, nDoc := 1
LOCAL nWin := WSELECT()
LOCAL nWin1 := NoOrYes( {'','Генерация проводок [ ]',''},,,15,35,COL_REFER )
LOCAL lYes := INDIK_NEW(18,61)
LOCAL aBase := {'MAIN','VALUTA','SPR_PART','S45','S45M','KALK','KALK_S',;
{"SSH_FACT",LoadPath()+"REAL\SH_FACT.DBF"},{"SSH_OP",LoadPath()+"REAL\SH_OP.DBF"},{"SH_FACT",LoadPath()+"TOVAR\SH_FACT.DBF"},{"SH_OP",LoadPath()+"TOVAR\SH_OP.DBF"},"SPR_NDS";
}
LOCAL cVid:=m->pVid,cType:=m->pType,cSclad:=m->pSclad
SELECT MDocM
SET RELATION TO;
UPPER(Grup+NNum) INTO MLabel,;
UPPER(Grup) INTO MGrup,;
UPPER(CodeVal) INTO Valuta,;
UPPER(Schet) INTO MSchet,;
UPPER(Sclad+Grup) INTO MStru,;
UPPER(Grup+NNum+Partia) INTO SPR_PART
SELECT (cSDoc)
IF nMode1 = 1
SET RELATION TO UPPER( VIDTYPE + CodeOper ) INTO MCodOp,;
Pro INTO Main,;
UPPER( VIDTYPE ) INTO Moves
ELSE
SET RELATION TO UPPER( VIDTYPE + CodeOper ) INTO MCodOp,;
UPPER( VIDTYPE ) INTO Moves
ENDIF
IF aDoc == NIL
DbSeek( DTos( dDat1 ), .T. )
ENDIF
// Суммы для накопления в заголовке документа
IF IS_MODEL
InitSumModel(@aSumModel)
ENDIF
Joined: 27 Jun 2005 Posts: 1000 Location: Горбунов Константин Occupation: БЭСТ-Партнер Interests: СПб
Posted: 18 Jul 2007 13:17 Post subject:
9.
Code:
//--------------------------------------------------------------------------//
FUNCTION ChangeOper(aOper,aWork)
//--------------------------------------------------------------------------//
LOCAL cLastColor:=SETCOLOR(COL_SHEADR)
LOCAL nRec:=RECNO(),nOper1,nOper2,cText,nMode,nMode1:=1
LOCAL nTop:=12,nLeft:=27,nBottom:=15,nRight:=59
LOCAL aSetKey:=SaveSetKey(),aSet,cCode1,cCode2
LOCAL sScreen:=SaveScreen(),nWin := WSELECT(),nWin1,lYes,i,lErr:=.F.
LOCAL aItem1:={;
' - увеличить/уменьшить ',;
' - взять из прайс-листа '}
LOCAL aItem:={' - операции движения ТМЦ '}
LOCAL aBase := {'MDoc','MDocM','MKart','MLabel','MSclad','MCodOpA','MCodOp','MSchet','MStru','DateSebe','People','SPR_PART',"MOVES",'KALK','KALK_S',"SH_OP","MAIN","VALUTA",'MPar','MCalc','MCalc1',{"SSH_FACT",LoadPath()+"REAL\SH_FACT.DBF"},{"SSH_OP",LoadPath()+"REAL\SH_OP.DBF"},{"SH_FACT",LoadPath()+"TOVAR\SH_FACT.DBF"},{"SH_OP",LoadPath()+"TOVAR\SH_OP.DBF"},"SPR_NDS"}
LOCAL lFirstEnt:=.T., lOneDoc:=.F.
LOCAL bFor := ;
{||;
lSREdit(1).AND.;
(;
!(;
(nMode = 2 .OR. nMode = 3) .AND.;
(IS_PSHFACT.OR.IS_SHFACT);
) .OR.;
IF(;
IS_PSHFACT,;
EMPTY(SH_FACT->(dbSeek(MDOC->OPER_FACT),SH_FACT->TEK_NOMER)).OR.;
MDOC->STATUS_F = "1",;
GetMDocFact(MDOC->(UPPER(Sclad+Vid+Type+CodeDoc+NumDoc)),"MDOC","SSH_OP","MDOCM") <= 0;
);
) .AND.;
!IsSeek45(MDOC->Vid,MDOC->Type,MDOC->Sclad,MDOC->CodeDoc,MDOC->NumDoc) .AND.;
!IsSeekRet(MDOC->Vid,MDOC->Type,MDOC->Sclad,MDOC->CodeDoc,MDOC->NumDoc,MDOC->Date) .AND.;
!((!EMPTY(aWork).AND.;
!lOneDoc .AND.;
!EMPTY(MDOC->ID_Reg).AND.;
YesRegistr(MDOC->ID_Reg)).OR.;
!MayDelReg(mDoc->Id_Reg) ).AND. ;
!ChangeO(cCode1,cCode2,lYes,nMode,nMode1);
}
PRIVATE pUpdated:=.T.
BEGIN SEQUENCE
IF EOF()
BREAK
ENDIF
IF (GlobalTask$"TV".OR.!IsView(MDoc->Date)) .AND. MDoc->Type # '#' .AND. !Moves->YesUchet
IF pVid='1'
AADD(aItem,' - цены поставщиков ')
ELSE
AADD(aItem,' - отпускные цены ')
ENDIF
AADD(aItem, ' - значения параметров (налогов) ')
ENDIF
IF (nMode:=BoxMenu(' Заменить в документах: ',5,10,aItem,,,,COL_SHEADR,COL_SHEADR,'NoClear',,'Wide'))=0
BREAK
ENDIF
SAYSCREEN('√',5+nMode,12)
DO CASE
CASE nMode=1
cText:='Замена операций......[ ]'
RestScreen(,,,,sScreen)
IF LEN(aOper)<=1
SayError({'Для этого режима требуется более одной операции',;
'в справочнике типовых операций!'})
BREAK
ENDIF
IF LEN(aWork)==0
IF !YesOrNo({'Режим заменяет коды операций с пересчетом',;
'моделей калькуляции и проводок.',;
'Для расчета будут использоваться значения параметров,',;
'запомненные на момент ввода соответствующих документов.',;
'Обработка производится только для текущего документа !'},,' Продолжать? ',' Возврат ')
BREAK
ENDIF
AADD(aWork,{RECNO(),IF(MDOC->Vid=='1',SumOutR,Summa)})
lOneDoc=.T.
ELSE
IF !YesOrNo({'Режим заменяет коды операций с пересчетом',;
'моделей калькуляции и проводок по отмеченным документам.',;
'Для расчета будут использоваться значения параметров,',;
'запомненные на момент ввода соответствующих документов.',;
'Документы, зарегистрированные в расчетах, пересчитаны не будут';
};
,,' Продолжать? ',' Возврат ')
BREAK
ENDIF
ENDIF
RestScreen(,,,,sScreen)
IF (nOper1:=BoxMenu(' Заменяемая операция ',5,10,aOper,,,,COL_SHEADR,COL_SHEADR,'NoClear'))==0
BREAK
ENDIF
cCode1:=SUBSTR(aOper[nOper1],2,4)
IF (nOper2:=BoxMenu(' Операцию '+cCode1+' заменить на: ',7,13,aOper,,,,COL_SHEADR,COL_SHEADR))==0
BREAK
ENDIF
cCode2:=SUBSTR(aOper[nOper2],2,4)
/* IF UPPER(cCode1)==UPPER(cCode2)
SayError('Заменяемая операция должна отличаться!')
BREAK
ENDIF */
IF pVid+pType = '26'.AND. MCodOp->(DBSEEK(UPPER(pVid+pType+cCode2)),Schet_A) # MCodOp->(DBSEEK(UPPER(pVid+pType+cCode1)),Schet_A)
SayError('При замене операции счет не должен изменяться!')
BREAK
ENDIF
CASE nMode=2
cText:='Изменение цен........[ ]'
IF pVid='2'.AND.YesDop.AND.YesReal.AND.!_ROZNICA
IF (nMode1:=BoxMenu(' Режим изменения цен: ',9,20,aItem1,,,,COL_SHEADR,COL_SHEADR,'NoClear',,'Wide'))=0
BREAK
ENDIF
SAYSCREEN('√',10,22)
ENDIF
IF nMode1=1
IF IF(IS_PSHFACT.OR.IS_SHFACT.OR._CN_PRESENT ,;
!YesOrNo( IF (pVid ='1', {'Цены в документах, созданных на основании',;
'счетов-фактур, изменены не будут !'},;
{'Режим осуществляет изменение цен в документах',;
'не связанных со счетами-фактурами !' } ),,' Продолжать? ',' Возврат '),.F.)
BREAK
ENDIF
PRIVATE GetList:={},pProcent:=0,pRound:=0,pNakidka:=0,pSkidka:=0
PRIVATE aKol:={;
{-3,'до тысяч '},;
{-2,'до сотен '},;
{-1,'до десятков'},;
{ 0,'до целых '},;
{ 1,'до десятых '},;
{ 2,'до сотых '},;
{ 3,'до тысячных'}}
ShadowBox("",nTop,nLeft,nBottom,nRight,COL_SHEADR,,'Wide')
@ nTop+1,nLeft+2 SAY 'Изменить цены на:' GET m->pProcent PICT '9999.999 %'
@ nTop+2,nLeft+2 SAY 'Округлить :' GET m->pRound PICT 'XXXXXXXXXXX'
GetList[2]:block:={|x|RotateBlock(x,m->aKol,'pRound')}
GetList[2]:reader:={|x|RotateAndReader(x,m->aKol)}
GetList[2]:display()
SETCURSOR(1)
READ
SETCURSOR(0)
RestScreen(,,,,sScreen)
IF LastKey() = K_ESC
BREAK
ENDIF
ENDIF
IF LEN(aWork)==0
IF !YesOrNo({'Режим изменяет '+IF(pVid='1','цены поставщиков ','отпускные цены ')+'с пересчетом ',;
'моделей калькуляции и проводок по всем документам '+IF(!(IS_PSHFACT.OR.IS_SHFACT),' !',','),;
IF((IS_PSHFACT.OR.IS_SHFACT), IF (pVid='1', 'кроме документов, созданных на основании счетов-фактур !', 'не связанным со счетами-фактурами ! ' ),'──────────────────────'),;
'Обработка производится только для текущего документа !'},,' Продолжать? ',' Возврат ')
BREAK
ENDIF
AADD(aWork,{RECNO(),IF(MDOC->Vid=='1',SumOutR,Summa)})
lOneDoc=.T.
ELSE
IF !YesOrNo({'Режим изменяет '+IF(pVid='1','цены поставщиков ','отпускные цены ')+'с пересчетом ',;
'моделей калькуляции и проводок по отмеченным документам,',;
IF((IS_PSHFACT.OR.IS_SHFACT),;
IF (pVid = '1' ,;
'кроме документов, созданных на основании счетов-фактур !' ,;
'не связянных со счетами-фактурами ! ' ) ,;
'──────────────────────'),;
'Документы, зарегистрированные в расчетах, пересчитаны не будут';
},,;
' Продолжать? ',' Возврат ')
BREAK
ENDIF
ENDIF
CASE nMode=3
cText:='Изменение параметров [ ]'
RestScreen(,,,,sScreen)
IF LEN(aWork)==0
IF !YesOrNo({'Режим осуществляет подстановку значений параметров',;
'из справочника групп, используемых в калькуляциях и проводках,',;
'если значения параметров были изменены после ввода документа.' ,;
'Также производится пересчет калькуляций и проводок.' ,;
IF((IS_PSHFACT.OR.IS_SHFACT), 'Подстановка не осуществляется для документов,','──────────────────────'),;
IF((IS_PSHFACT.OR.IS_SHFACT), IF (pVid = '1' , 'созданных на основании счетов-фактур ! ', 'связанных со счетами-фактурами') ,''),;
'Обработка производится только для текущего документа !'},,' Продолжать? ',' Возврат ')
BREAK
ENDIF
AADD(aWork,{RECNO(),IF(MDOC->Vid=='1',SumOutR,Summa)})
lOneDoc=.T.
ELSE
IF !YesOrNo({'Режим осуществляет подстановку значений параметров',;
'из справочника групп, используемых в калькуляциях и проводках,',;
'если значения параметров были изменены после ввода документа.' ,;
'Также производится пересчет калькуляций и проводок.' ,;
IF((IS_PSHFACT.OR.IS_SHFACT), 'Подстановка не осуществляется для документов,','──────────────────────'),;
IF((IS_PSHFACT.OR.IS_SHFACT), IF (pVid = '1' , 'созданных на основании счетов-фактур ! ', 'связанных со счетами-фактурами') ,''),;
'Документы, зарегистрированные в расчетах, пересчитаны не будут',;
'Обработка производится только для отмеченных документов !'},,' Продолжать? ',' Возврат ')
BREAK
ENDIF
ENDIF
ENDCASE
RestScreen(,,,,sScreen)
nWin1:=NoOrYes({'',cText,''},,,15,35,COL_SHEADR)
lYes := INDIK_NEW(18,61)
dbOpenBases(aBase,,,,.T.,.T.)
SH_OP->(ORDSETFOCUS("TAG_OPER"))
SH_FACT->(ORDSETFOCUS("TAG_OPER"))
SSH_OP->(ORDSETFOCUS("TAG_NNOPER"))
SSH_FACT->(ORDSETFOCUS("TAG_KREDIT"))
SELECT MCalc1
SET RELATION TO UPPER(Vid+Ident) INTO MPar
Main->(ORDSETFOCUS('Tag_NNOper'))
SELECT MDoc
IF LEN(aWork) > 0
FOR i:=1 TO LEN(aWork)
INDIK_UPDATE(lYes)
GO aWork[i,1]
IF !IsDateOut(MDoc->DATE,.T.).AND.EVAL(bFor)
lErr:=.T.
ENDIF
IF lFirstEnt.AND.!A3MaxDate(DateProv(MDoc->Pro))
lFirstEnt:=.F.
lErr:=.T.
ENDIF
NEXT
ELSE
GO TOP
WHILE !EOF()
INDIK_UPDATE(lYes)
IF !IsDateOut(MDoc->DATE,.T.).AND.EVAL(bFor)
lErr:=.T.
ENDIF
IF lFirstEnt.AND.!A3MaxDate(DateProv(MDoc->Pro))
lFirstEnt:=.F.
lErr:=.T.
ENDIF
SKIP
ENDDO
ENDIF
INDIK_END(lYes)
WSELECT(nWin1)
WCLOSE()
dbCloseBases(aBase)
aWork:={}
IF nMode=1.AND.lErr
SayError({'После перерасчета операций',;
'в документах,помеченных знаком "?"',;
'имеются ошибки!'})
ENDIF
END SEQUENCE
WSELECT(nWin)
RestScreen(,,,,sScreen)
RestSetKey(aSetKey)
SELECT MDoc
COMMIT
GO nRec
RETURN(2)
Joined: 27 Jun 2005 Posts: 1000 Location: Горбунов Константин Occupation: БЭСТ-Партнер Interests: СПб
Posted: 20 Jul 2007 15:35 Post subject:
10.
Code:
FUNCTION WinReport(cReport,cFile,cFile1,lDesigner)
/**********
cFile - имя файла описания шапки с полями:VarName,VarC,VarN,VarD,VarL,FieldName
или массив {cVarName,xVar, cField/nElement} - наименование, значение, имя поля в cFile1 или в номер значения в строке-массиве
сFile1 - имя файла строк или массив значений
В более сложных случаях может в cFile1 могут быть перечислены несколько файлов
через запятую,например "File1,File2,File3",тогда в первом файле сField указывается
в виде "File.Pield", где File - не обязательно полное имя файла таблицы,
может быть часть, лишь бы бы входила бы как часть имени и отличалась от других
Вместо файлов могут передаваться алиасы открытых областей (тогда, если их
несколько, в cField указывается точное название алиаса и имя поля через точку).
*********************************/
LOCAL nArea:=SELECT()
LOCAL aVar:={},aVar1:={},nField,xVal
LOCAL lTable1:=VALTYPE(cFile1)="C".AND.NetUses(cFile1,aVar1)
LOCAL lArray1:=VALTYPE(cFile1)=="A",aLen:={}
LOCAL lTable:=VALTYPE(cFile)="C".AND.(SELECT(cFile)>0.OR.NetUse("RpTable",cFile,,,,.T.))
LOCAL cVarFile:=TEMPFILE(m->GlobalTmpPath,"xml"),nVarFile
LOCAL cHead:="",cVar:='<Row i_d="1" ',j:=1,i,cSpisok,nSpisok
LOCAL aVar1N
IF !(VALTYPE(cReport)=="C".AND.!EMPTY(cReport))
SayError("Ошибка в указании 1-го параметра (имени шаблона) WinReport!")
RETURN "WINREPORT"
ELSEIF EMPTY(cFile)
SayError("Ошибка в указании 2-го параметра WinReport!")
RETURN "WINREPORT"
ENDIF
altd()
busy(.T.,"Подготовка данных")
IF lArray1
//находим макс.длины полей, если задан массив строк
ASIZE(aLen,LEN(cFile1[1]))
AFILL(aLen,0)
FOR i:=1 TO LEN(cFile1)
FOR j=1 TO LEN(cFile1[i])
IF VALTYPE(cFile1[i,j])=="C"
aLen[j]:=MAX(aLen[j],LEN(cFile1[i,j]))
ENDIF
NEXT
NEXT
aVar1:={{"","",{}}}
ENDIF
IF lTable
IF SELECT(cFile)>0
DbSelectArea(cFile)
ELSE
SELECT RpTable
ENDIF
cAlias:=ALIAS()
DbGoTop()
WHILE !EOF()
IF !(DELETED().OR.EMPTY(FIELD->VarName))
IF EMPTY(FIELD->FieldName)
xVal:=GetMyVar()
AADD(aVar,{MyName(FIELD->VarName),VALTYPE(xVal),LenVar(xVal),xVal})
ELSEIF lTable1
AddVar1(aVar1,cFile1,MyName((cAlias)->VarName),(cAlias)->FieldName)
ENDIF
ENDIF
SKIP
ENDDO
ELSEIF VALTYPE(cFile)=="A"
FOR i:=1 TO LEN(cFile)
IF LEN(cFile[i])<3.OR.EMPTY(cFile[i,3])
xVal:=cFile[i,2]
AADD(aVar,{MyName(cFile[i,1]),VALTYPE(xVal),LenVar(xVal),xVal})
ELSEIF lTable1
AddVar1(aVar1,cFile1,MyName(cFile[i,1]),cFile[i,3])
ELSEIF lArray1.AND.VALTYPE(cFile[i,3])=="N".AND.(nField:=cFile[i,3])>0
AADD(aVar1[1,3],{MyName(cFile[i,1]),VALTYPE(cFile1[1,nField]),aLen[nField],nField})
ENDIF
NEXT
ENDIF
IF ( nVarFile := FCREATE(cVarFile) ) == -1
SayError( "Ошибка создания временного файла "+cVarFile)
ELSE
FWRITE(nVarFile,'<?xml version="1.0" encoding="windows-1251"?>'+CRLF)
FWRITE(nVarFile,"<DataBase>"+CRLF)
FWRITE(nVarFile,"<SMakers>"+CRLF)
FWRITE(nVarFile,'<SMaker name="bda.s_maker">'+CRLF)
//Шапка
FWRITE(nVarFile,'<Part PartName="'+DosToXML("Шапка")+'" PartType="1">'+CRLF)
FOR i:=1 TO LEN(aVar)
cHead+=FieldToXml(i,aVar[i,1],aVar[i,2],aVar[i,3])
cVar+=Fi(i)+'="'+ DosToXML(GetVal(aVar[i,4]))+'" '
NEXT
FWRITE(nVarFile,"<FieldDefs>"+CRLF)
FWRITE(nVarFile,cHead)
FWRITE(nVarFile,"</FieldDefs>"+CRLF)
FWRITE(nVarFile,"<Rows>"+CRLF)
cVar+="/>"+CRLF
FWRITE(nVarFile,cVar)
FWRITE(nVarFile,"</Rows>"+CRLF)
FWRITE(nVarFile,'</Part>'+CRLF)
IF lTable1.OR.lArray1
FOR nSpisok:=1 TO LEN(aVar1)
//Список
cHead:=""
cSpisok:="Список"
IF LEN(aVar1)>1
cSpisok+="_"+aVar1[nSpisok,4]
ENDIF
FWRITE(nVarFile,'<Part PartName="'+DosToXML(cSpisok)+'" PartType="1">'+CRLF)
aVar1N:=aVar1[nSpisok,3]
FOR i:=1 TO LEN(aVar1N)
cHead+=FieldToXml(aVar1N[i,4],aVar1N[i,1],aVar1N[i,2],aVar1N[i,3])
NEXT
FWRITE(nVarFile,"<FieldDefs>"+CRLF)
FWRITE(nVarFile,cHead)
FWRITE(nVarFile,"</FieldDefs>"+CRLF)
FWRITE(nVarFile,"<Rows>"+CRLF)
j:=1
IF lTable1
DbSelectArea(aVar1[nSpisok,2])
dbGoTop()
WHILE !EOF()
cVar:='<Row i_d="' + LTRIM(STR(j++,10,0))+'" '
FOR i:=1 TO LEN(aVar1N)
IF (nField:=aVar1N[i,4])>0
cVar+=FI(nField)+'="'+ DosToXML(GetVal(FIELDGET(nField)))+'" '
ENDIF
NEXT
cVar+="/>"+CRLF
FWRITE(nVarFile,cVar)
SKIP
ENDDO
ELSE
FOR j:=1 TO LEN(cFile1)
cVar:='<Row i_d="' + LTRIM(STR(j,10,0))+'" '
FOR i:=1 TO LEN(aVar1N)
IF (nField:=aVar1N[i,4])>0
cVar+=FI(nField)+'="'+ DosToXML(GetVal(cFile1[j,nField]))+'" '
ENDIF
NEXT
cVar+="/>"+CRLF
FWRITE(nVarFile,cVar)
NEXT
ENDIF
FWRITE(nVarFile,"</Rows>"+CRLF)
FWRITE(nVarFile,'</Part>'+CRLF)
NEXT //nSpisok
ENDIF
busy(.F.)
IF lTable.AND.SELECT("RpTable")>0
RpTable->(DbCloseArea())
ENDIF
IF lTable1
NetCloses(aVar1)
ENDIF
FRCall("ShowReport",LoadPath()+cReport,cVarFile,IF(lDesigner!=NIL.AND.lDesigner,1,0),1)
WHILE .T.
INKEY(.1)
IF !FILE(cVarFile)
Exit
ENDIF
ENDDO
SELECT(nArea)
You cannot post new topics in this forum You cannot reply to topics in this forum You cannot edit your posts in this forum You cannot delete your posts in this forum You cannot vote in polls in this forum
FAQ
Search
Memberlist
Usergroups
Register
Profile
Log in to check your private messages
Log in
