Главная
Новый форум
 FAQFAQ   SearchSearch   MemberlistMemberlist   UsergroupsUsergroups   RegisterRegister 
 ProfileProfile   Log in to check your private messagesLog in to check your private messages   Log inLog in 

Функции БЭСТа
Goto page Previous  1, 2
 
Post new topic   This topic is locked: you cannot edit posts or make replies.   printer-friendly view     Forum Index -> Программирование в БЭСТ-4
View previous topic :: View next topic  
Author Message
nordk



Joined: 27 Jun 2005
Posts: 1000
Location: Горбунов Константин
Occupation: БЭСТ-Партнер
Interests: СПб
PostPosted: 17 Sep 2007 18:18    Post subject: Reply with quote
15.

Code:
****************************************************************
* Открытие базы данных:                                        *
* в распределенном режиме  lExc := NIL or lExc := .F.          *
*          или                                                 *
* в монопольном  режиме    lExc := .T.                         *
* NetUse( cAlias,cFile,[cIndexes],[lExc],[cRdd] ) --> lSuccess *
****************************************************************
FUNCTION NetUse( cAlias,cFile,cIndexes, lExc, cRdd, lReadyOnly, lNew, lNoIndex )
LOCAL i, cDbfFile, cCdxFile,cDisk,;
        lForever:=.F., nSeconds:=10, nCo, cParol := GetId()
Local uPath,uLoad,nArea:=SELECT()
  cFile := ALLTRIM( cFile )
  i     := ATNUM( '.', cFile )
  IF ValType( cRdd ) <> 'C' ;   cRdd := NameRdd()           ; ENDIF
  IF VALTYPE( lNew ) <> 'L' ;   lNew  := .T.                ; ENDIF
  IF SELECT( cAlias ) > 0 .AND. lNew  ;   (cAlias)->( dbCLOSEAREA() ) ; ENDIF
  IF VALTYPE( lExc ) <> 'L' ;   lExc  := .F.                ; ENDIF
  IF( ValType(lReadyOnly) <> 'L', ;
      lReadyOnly := .F. ,;
    )

  IF UPPER(cRdd) == 'SIXCDX'
     cRdd:='DBFCDX'
  ENDIF
  if IsAds()
     if !Empty( uPath := Upper(ExtractPath( cFile )) )
        uLoad := Upper(LoadPath())
        if !( SUBSTR(uLoad,3) $ uPath )
           cRdd := 'DBFCDX'
        endif
        if "PRO\" $ uPath
           cRdd := 'DBFCDX'
        endif
     endif
  endif


  IF( i == 0.OR. i < LEN(cFile) - 3, i:= LEN(cFile), i-- )
  IF RIGHT( cFile, 3 ) == 'PRO'
    cDbfFile := cFile
  ELSE
    cDbfFile := LEFT(cFile,i)+'.DBF'
    cFile := LEFT(cFile,i)
  ENDIF
/*
  IF !_REC_YES .AND. !Bs_IsTmp( cFile )
    // Глобальное запрещение записи
    lReadyOnly := .T.
  ENDIF
*/
  cCdxFile := LEFT(cFile,i)+'.CDX'

  IF( !FILE(cDbfFile), (nSeconds:= 0,SayError('Нет файла: '+cDbfFile)), ) // Нет базы


  DO WHILE (!lForever .AND. nSeconds > 0)
    WHILE  SECONDS() - nOpenSec < MemVar->WAIT_OPEN .AND. dOpenData = DATE(); ENDDO
    IF lNew

      IF lExc
        USE (cFile) ALIAS (cAlias) NEW VIA (cRdd) EXCLUSIVE
      ELSE
        USE (cFile) ALIAS (cAlias) NEW VIA (cRdd) SHARED
      ENDIF
    ELSE

      IF lExc
          USE (cFile) ALIAS (cAlias) VIA (cRdd) EXCLUSIVE
      ELSE
          USE (cFile) ALIAS (cAlias) VIA (cRdd) SHARED
      ENDIF
   ENDIF
    dOpenData := DATE()
    nOpenSec := SECONDS()

    IF !NETERR()               // USE успешно выполнена

     IF FILE(cCdxFile) .AND. EMPTY(cIndexes) .AND. EMPTY(lNoIndex)     // так как xH хватает CDX с таким же именем и падает
        OrdListAdd( cCdxFile )
      ENDIF
      IF (VALTYPE(cIndexes) == 'C')
         OrdListAdd(cIndexes )
      ELSEIF (VALTYPE(cIndexes) == 'A')
        FOR nCo:=1 TO LEN(cIndexes)
          IF (LEN(TRIM(cIndexes[nCo])) > 0)
            SET INDEX TO (cIndexes[nCo]) ADDITIVE
          ENDIF
        NEXT
      ENDIF
      lForever := .T.
      EXIT
    ENDIF
    // Ожидание приблизительно 0.1 секунда
//    INKEY(0.1)
    nSeconds--
  ENDDO


  IF !lForever
     IF nArea>0
        SELECT(nArea)
     ENDIF
  ENDIF
#ifndef _DEBUG
  CheckLastRec(cAlias)
#endif
RETURN(lForever)
Back to top
View user's profile Send private message Send e-mail
nordk



Joined: 27 Jun 2005
Posts: 1000
Location: Горбунов Константин
Occupation: БЭСТ-Партнер
Interests: СПб
PostPosted: 17 Sep 2007 18:26    Post subject: Reply with quote
16.

Code:
/********
*  Функция: DBOpenBases( <xBases>, [<cMessage>], [<lExc>], [<lRO>], [<NoProcess>], [<NoClearState>], [<lFile>])
*
*  Назначение: Открывает базы данных
*
*  Параметры:
*
*      <xBases> - список открываемых баз данных. Может быть массивом {<NameTable>,...<nNameTable>}
*                 или если алиас не совпадает { {<Alias>,<NameTable>},...{<nAlias>,<nNameTable>} } или
*                 символьной строкой. "NameTable".
*    <cMessage> - символьная строка сообщения ( по умолчанию со стандартным сообщением ).
*        <lExc> - открываются при .T. локально базы данных ( по умолчанию общий доступ ).
*         <lRO> - открываются только для чтения ( по умолчанию все ).
*   <NoProcess> - показывать или нет индикацию при открытии ( по умолчанию показывается ).
*<NoClearState> - не очищает установки на область если база открыта ( по умолчанию не зачищает ).
*       <lFile> - не выдает предупреждения при отсутствии базы и открывает .IDX  если есть
*/
Function DBOpenBases( xBases, cMessage, lExc, lRO, NoProcess, NoClearState, lFile)

   Local nProcess := 0
   Local lOK      := .T.
   LOCAL aBases   := If( Y_Type( xBases,"A"), xBases, {xBases} )
   Local aSave    := DBSave()
   Local nLen     := Len( aBases )

   IF Y_Type( aBases[nLen], "A") .AND. Len( aBases[nLen] ) > 3
      aSave := aBases[nLen]
      ASize( aBases, --nLen )
   ENDIF

   If( Y_Type(cMessage, "C"),, cMessage := "Открытие баз данных")

   NoProcess    := Len( aBases ) <= 10 .OR. N_Nil(NoProcess)
   NoClearState := N_Nil(NoClearState)

   AEval( aBases,;
         {|x, i|If( Y_Type(x, "A"),, aBases[i] := {x, x} ),;
                ASize( aBases[i], 3);
         };
        )
   If( NoProcess,, nProcess := Proces_Ini(nLen, 17,, cMessage))

   AEval( aBases,;
          {|x,i,cFile|;
                cFile := IF( ".DBF"  $ Upper(x[2]),;
                             StrTran( Upper(x[2]),".DBF",""),;
                             x[2];
                           ),;
                If( Select(x[1]) == 0 .AND.;
                    ( Y_Nil(lFile) .OR. N_Type(lFile,"L") .OR.;
                      !lFile .OR. FILE( cFile + ".DBF" );
                    ),;
                    If( ( lOK := lOK .And.;
                                 NetUse( x[1],;
                                         x[2],;
                                         IF( Y_Type( lFile, "L") .AND.;
                                             lFile .AND.;
                                             FILE( cFile + ".IDX"),;
                                             cFile + ".IDX",;
                                             NIL;
                                           ),;
                                         lExc,,;
                                         lRO;
                                       );
                        ),;
                        NIL,;
                        aBases[i] := NIL;
                      ),;
                    If( Select( x[1] ) != 0 .AND. Empty( x[3] ),;
                        (x[1])->(;
                             aBases[i, 3] := DBSave(),;
                             DBCommit(),;
                             If( NoClearState,,;
                                 (;
                                   DBClearRelation(),;
                                   DBClearFilter(),;
                                   SetScope(),;
                                   OrdSetFocus(1),;
                                   DBGoTop();
                                 );
                               );
                                 ),;
                        NIL;
                      );
                  ),;
                If( NoProcess,, Proces_Update(nProcess));
          })

//   InKey(0.1)

   If( NoProcess,, Proces_End(nProcess))
   If( lOK .AND. Len( aBases ) = 1, DbSelectArea( aBases[ 1, 1 ] ), NIL )
   If( lOK, AAdd( aBases, aSave ), (Error_Use(), Break(NIL)))

Return (NIL)
Back to top
View user's profile Send private message Send e-mail
nordk



Joined: 27 Jun 2005
Posts: 1000
Location: Горбунов Константин
Occupation: БЭСТ-Партнер
Interests: СПб
PostPosted: 17 Sep 2007 18:30    Post subject: Reply with quote
17.

Code:
*  Функция: DBPush([<cAlias>], [<xOrder>], [<cFilter>],;
*                  [<aScope>], [<aRelations>], [<LAdd>], [<nRecNo>], [<lNoStek>])
*
*  Назначение: Сохраняет все текущие физические "элементы состояния" рабочей
*              области, такие как: алиас, текущий тег, текущий фильтр, Scope,
*              реляции, номер записи, анализируя, были ли они установлены
*              каждый в отдельности и устанавливает новые если заданы
*              соответствующие параметры. Если какой-либо параметр не задан
*              то значение соответствующего "элемента состояния" остается
*              прежним. Если необходимо снять текущие фильтр, Scope или
*              реляции то вместо соответствующего параметра надо передать
*              любое пустое значение кроме NIL: ("", {}, 0, .F.).
*              Все параметры опциональны.
*
*  Параметры:
*
*      <cAlias> - новый алиас (символьная строка).
*
*      <xOrder> - номер или имя нового тэга (число или символьная строка).
*
*     <cFilter> - новое выражение фильтра (символьная строка).
*
*      <aScope> - массив из двух, трех или четырех элементов соответствующих
*                 параметрам функции SetScope(), структура:
*
*                 {<cScope>, <xScope>, [<xScope1>], [<aOrder>]} .
*
*  <aRelations> - новые реляции в виде массива подмассивов из двух элементов,
*                 подмассивов может быть несколько, структура:
*
*                 { {<xLinkArea>, <cLinkExpr>},... }
*
*                 где:
*                      <xLinkArea> - номер или алиас рабочей области для
*                                    реляции (число или символьная строка).
*                      <cLinkExpr> - выражение реляции (символьная строка);
*                 Возможен вариант когда этот параметр строка используемая
*                 для реляции.
*        <LAdd> - если задан то реляции добавляются к существующим.
*                 Этот параметр для совмещения со складским модулем
*                 может быть алиасом связной таблицы.
*      <nRecNo> - новый номер записи (число).
*     <lNoStek> - не сохраняется в стек DBStatus, а сбрасывается в массив.
*/



Function DBPush( cAlias, xOrder, cFilter, aScope, aRelations, LAdd, nRecNo, lNoStek )

   Local IsNoAli     := Y_Nil( cAlias ),;
         IsNoOrd     := Y_Nil( xOrder ),;
         IsNoFil     := Y_Nil( cFilter ),;
         IsNoScp     := Y_Nil( aScope ),;
         IsNoRel     := Y_Nil( aRelations ).or. (vALtYPE(aRelations)=="A".AND.len(aRelations)==0) ,;
         IsNoRec     := Y_Nil( nRecNo ),;
         IsNoStk     := Y_Nil( lNoStek )

   Local aOldStat
   Local IsAnotherAlias
   Local xT
   Local nLen
   Local i := 1

   IF !IsNoScp.AND.LEN(aScope)>4.AND.VALTYPE(aScope[4])="L".AND.VALTYPE(aScope[5])="A"
      aScope[4]:=aScope[5] //titov - когда приходит из запомненного aScope
   ENDIF


   aOldStat :=  DBSave()

   If EMPTY(lNoStek)

      IsAnotherAlias := !If( IsNoAli, IsNoAli, aOldStat[1] == Upper(cAlias) )
      // 9 .F. если незадан алиас или оно не совпадает с текущим
      AAdd( aOldStat, IsAnotherAlias)
      AAdd( DBStatus, aOldStat)
      // Если заданный алиас не совпадает с текущим то сохраняем текущий и заданный
      If( !IsAnotherAlias, NIL, ( DBSelectArea( cAlias ), DBPush()) )
      If( IsNoRel, NIL,;
          ( xT := { Empty(aRelations), Y_Type(aRelations, "A"), Empty(LAdd), Y_Type(aRelations, "C") .AND. Y_Type(LAdd, "C") },;
            If( !( xT[1] .Or. ( xT[2] .And. xT[3] ) .Or. xT[4]), NIL, DBClearRelation());
          );
        )
      If( IsNoFil, NIL, DBClearFilter())
      If( IsNoScp, NIL, SetScope())
      If( IsNoOrd, NIL, OrdSetFocus(xOrder))
      If( IsNoScp, NIL,;
          If( Empty(aScope), NIL,;
              If( !( Y_Type( aScope, "A") .And. ( nLen := Len( aScope ) ) > 1), NIL,;
                  SetScope( aScope[1],;
                            aScope[2],;
                            If( nLen < 3,;
                                NIL,;
                                aScope[3];
                              ),;
                            If( nLen < 4,;
                                NIL,;
                                aScope[4];
                              ),,IF(!IsNoOrd,.T.,NIL);
                          );
                );
            );
        )
      If( IsNoFil, NIL, If( Empty(cFilter), NIL, DBSetFilter( &("{||" + cFilter + "}"), cFilter)))
      If( IsNoRel, NIL,;
          If( xT[1] .Or. !xT[2],;
              If( !xT[1] .AND. xT[4],;
                  DBSetRelation( LAdd, &("{|| "+aRelations+"}"), aRelations ),;
                  NIL;
                ),;
              AEval( aRelations,;
                     {|x, i| DBSetRelation(x[1], &("{||" + x[2] + "}"), x[2])};
                   );
            );
        )
      If( PCount() == 0, NIL, If( IsNoRec, DBGoTop(), DBGoTo(nRecNo) ) )
   EndIf

Return If( IsNoStk, NIL, aOldStat )
Back to top
View user's profile Send private message Send e-mail
nordk



Joined: 27 Jun 2005
Posts: 1000
Location: Горбунов Константин
Occupation: БЭСТ-Партнер
Interests: СПб
PostPosted: 18 Sep 2007 11:25    Post subject: Reply with quote
18.

Code:
FUNCTION SaveSet(nTop, nLeft, nBottom, nRight)
If nTop==NIL
  nTop:=0
EndIf
If nLeft==NIL
  nLeft:=0
EndIf
If nBottom==NIL
  nBottom:=MAXROW()
EndIf
If nRight==NIL
  nRight:=MAXCOL()
EndIf
RETURN {SetColor(), SaveScreen(nTop, nLeft, nBottom, nRight), SetCursor(), Select(), Row(), Col(), help_code}
Back to top
View user's profile Send private message Send e-mail
nordk



Joined: 27 Jun 2005
Posts: 1000
Location: Горбунов Константин
Occupation: БЭСТ-Партнер
Interests: СПб
PostPosted: 18 Sep 2007 11:27    Post subject: Reply with quote
19.

Code:
FUNCTION SAVESETKEY()
Local aSave := HB_SetKeySave()
Local i
Local aRest := {}
      For i := 1 to len(aSave)
          if aSave[i][1] == K_F1.or.;
             aSave[i][1] == K_ALT_F1.or.;
             aSave[i][1] == K_ALT_Z.or.;
             aSave[i][1] == K_ALT_K.or.;
             aSave[i][1] == K_ALT_INS.or.;
             aSave[i][1] == K_ALT_V
             aadd(aRest,aSave[i])
          else
             setkey(aSave[i][1],nil)
          endif
      Next
      if !Empty(aRest)
         HB_SetKeySave(aRest)
      endif

Return aSave
Back to top
View user's profile Send private message Send e-mail
nordk



Joined: 27 Jun 2005
Posts: 1000
Location: Горбунов Константин
Occupation: БЭСТ-Партнер
Interests: СПб
PostPosted: 26 Oct 2007 16:41    Post subject: Reply with quote
20.

Code:
//--------------------------------------------------------------------------//
   FUNCTION PricePere(lPrice,get,lSkid,bnCena,bnVCena)
//--------------------------------------------------------------------------//
// Если lPrice!=NIL, то по текущему прайс листу
LOCAL aMat:=aWindow[2][7]:cargo[1],i,cMat,nProces
LOCAL lIndik:=LEN(aMat)>10,nCena,nVCena,nKol,nKolNNum
LOCAL nWi:=WSELECT()
LOCAL aPar   := DefParam()
LOCAL aParam := RetTypeParam(5)
IF get!=NIL.AND.!get:changed()
   RETURN(.T.)
ENDIF
WSELECT(0)
IF lIndik
   PROCES TO nProces PROMPT "Пересчет цен" MAX LEN(aMat)
ENDIF
FOR i:=1 TO LEN(aMat)
  IF lIndik
    Proces_Update(nProces)
  ENDIF
  cMat:=aMat[i]
  MLabel->(DBSEEK(UPPER(SUBSTR(cMat,Q_GRUP,L_GRUP)+SUBSTR(cMat,Q_NNUM,L_NNUM))))
  SPR_PART->(DBSEEK(UPPER(SUBSTR(cMat,Q_GRUP,L_GRUP)+SUBSTR(cMat,Q_NNUM,L_NNUM)+SUBSTR(cMat,Q_PARTIA,L_PARTIA))))
  MSTRU->(DBSEEK(UPPER(SUBSTR(cMat,Q_GRUP,L_GRUP))))
  MSCHET->(DBSEEK(UPPER(MSTRU->SCHET)))
  MGRUP->(DBSEEK(UPPER(SUBSTR(cMat,Q_GRUP,L_GRUP))))

  IF lPrice!=NIL
    cMat:=STUFF(cMat,Q_CODEVAL,3,IF(LNEWCENA,IsAddPricePartia(pNumber)[2],MLabel->CodeVal))
    cMat:=STUFF(cMat,Q_CENAVAL,13,STR(IF(LNEWCENA,IsAddPricePartia(pNumber)[5],MLabel->CenaVal),13,5))
    cMat:=STUFF(cMat,Q_OCENA1,15,STR(__RLABEL->OCena1,15,3))
    cMat:=STUFF(cMat,Q_OCENA2,15,STR(__RLABEL->OCena2,15,3))
    cMat:=STUFF(cMat,Q_OCENA3,15,STR(__RLABEL->OCena3,15,3))
    cMat:=STUFF(cMat,Q_OCENA4,15,STR(__RLABEL->OCena4,15,3))
    cMat:=STUFF(cMat,Q_VCENA1,15,STR(__RLABEL->VCena1,15,3))
    cMat:=STUFF(cMat,Q_VCENA2,15,STR(__RLABEL->VCena2,15,3))
    cMat:=STUFF(cMat,Q_VCENA3,15,STR(__RLABEL->VCena3,15,3))
    cMat:=STUFF(cMat,Q_VCENA4,15,STR(__RLABEL->VCena4,15,3))
  ENDIF

  nKolNNum:=0  //Для суммирования количества по номенклатуре
  nKol:=VAL(SUBSTR(cMat,Q_KOL,L_KOLR))
  AEVAL(aMat, {|x| nKolNNum+= IF(UPPER(SUBSTR(cMat,Q_GRUP,L_GRUP)+SUBSTR(cMat,Q_NNUM,L_NNUM))==;
                                 UPPER(SUBSTR(x,Q_GRUP,L_GRUP)+SUBSTR(x,Q_NNUM,L_NNUM)),;
                                       VAL(SUBSTR(x,Q_KOL,L_KOLR)), 0) })
  pCenaVal := VAL(SUBSTR(cMat,Q_CENAVAL,13))
  nCena:=IF(bnCena#NIL,EVAL(bnCena,cMat),IF(LNEWCENA,;
                      RealAddPrice(pNumber,SUBSTR(cMat,Q_GRUP,L_GRUP)+SUBSTR(cMat,Q_NNUM,L_NNUM)+IF(IsAddPricePartia(pNumber)[1],SUBSTR(cMat,Q_PARTIA,L_PARTIA),""),,SUBSTR(cMat,Q_SCLAD,6),.T.,iMLABEL->ED),;
                      GetCena('O',nKolNNum,cMat,,,,MemVar->RoundGlob,lSkid,VAL(SUBSTR(cMat,Q_CENAOUT,15)))))
  nVCena:=IF(bnVCena#NIL,EVAL(bnVCena,cMat),IF(LNEWCENA,;
                       RealAddPrice(pNumber,SUBSTR(cMat,Q_GRUP,L_GRUP)+SUBSTR(cMat,Q_NNUM,L_NNUM)+IF(IsAddPricePartia(pNumber)[1],SUBSTR(cMat,Q_PARTIA,L_PARTIA),""),.F.,SUBSTR(cMat,Q_SCLAD,6),.T.,iMLABEL->ED),;
                       GetCena('V',nKolNNum,cMat,,,,MemVar->RoundVal,lSkid,VAL(SUBSTR(cMat,Q_VCENA,15)))))

  cMat:=STUFF(cMat,Q_FACTCENA,L_SUM,STR(nCena,L_SUM,CURR_MAIN))
  cMat:=STUFF(cMat,Q_CENAOUT,15,STR(nCena,15,3))

  cMat:=STUFF(cMat,Q_VCENA,15,STR(nVCena,15,3))
  cMat:=STUFF(cMat,Q_SUMOUT,15,STR(nCena*nKol,15,CURR_MAIN))
  EditCalc(.F.,.F.,2,aPar,@cMat,aParam,@pModel)
  aMat[i]:=cMat
NEXT
IF lIndik
   Proces_End()
ENDIF
IF lPrice!=NIL
   pUpdated:=.T.
   SETLASTKEY(0)
ENDIF
WSELECT(aWindow[2][6])
aWindow[2][7]:RefreshAll()  //Этот метод надо делать уже в окне
InitObj(aWindow[2][7],'Passiv')  //Объект
WSELECT(nWi)
DispSum1()
RETURN(.T.)
Back to top
View user's profile Send private message Send e-mail
nordk



Joined: 27 Jun 2005
Posts: 1000
Location: Горбунов Константин
Occupation: БЭСТ-Партнер
Interests: СПб
PostPosted: 06 Nov 2007 13:17    Post subject: Reply with quote
21.

Code:
//--------------------------------------------------------------------------//
FUNCTION QPrint(aPHeads,block,bFooter,bSayHead,bKeyHead,aGroup)
//--------------------------------------------------------------------------//
PLOCAL nCo,cFi,cAlias,cFile:=TEMPFILE( GlobalTmpPath )
PLOCAL nRecNo:=RECNO()
PLOCAL aFields:={}
PLOCAL cFormat:='│'
PLOCAL cHead,cField,cPict,cPict0,nField
PLOCAL cHead0:='┌',cHead1:='│',cHead2:='├'
PLOCAL aBlockKey:=SaveKey()
PLOCAL aTot:={}
IF (EOF().OR.LASTREC()=0)
 RestKey(aBlockKey)
 RETURN (1)
ENDIF
FOR nCo:=2 TO LEN(aPHeads)
cField:=IF(VALTYPE(aPHeads[nCo])=='A',aPHeads[nCo,2],Field(nCo-1))
//AADD(aFields,FiName(cField))
AADD(aFields,cField)
nField:=FiNum(cField)
cAlias:=FiAlias(cField)
IF ((cAlias)->(FIELDTYPE(nField))=='N')
   cPict0:=REPLICATE('9',(cAlias)->(FIELDSIZE(nField)))
   cPict0:=STUFF(cPict0,LEN(cPict0)-(cAlias)->(FIELDDECI(nField)),1,'.')
ELSE
   cPict0:=REPLICATE('X',(cAlias)->(FIELDSIZE(nField)))
ENDIF
cPict:=IF((VALTYPE(aPHeads[nCo])=='A'.AND.LEN(aPHeads[nCo])>2).AND.aPHeads[nCo,3]!=NIL,;
aPHeads[nCo,3],cPict0)
cFormat+=cPict+'│'
IF VALTYPE(aPHeads[nCo])=='A'.AND.LEN(aPHeads[nCo])>3.AND.aPHeads[nCo,4]!=NIL;
.AND.aPHeads[nCo,4]
   AADD(aTot,nCo-1)
ENDIF
cHead:=IF(VALTYPE(aPHeads[nCo])=='A',IF(ValType(aPHeads[nCo,1]) = "C",aPHeads[nCo,1],EVAL(aPHeads[nCo,1])),aPHeads[nCo])
cHead0+=REPLICATE('─',LEN(cPict))+'┬'
cHead1+=CENTER(cHead,LEN(cPict),.T.)+'│'
cHead2+=REPLICATE('─',LEN(cPict))+'┼'
NEXT
cHead0:=LEFT(cHead0,LEN(cHead0)-1)+'┐'
cHead2:=LEFT(cHead2,LEN(cHead2)-1)+'┤'
GO TOP
IF TotRep({PADC(IF(ValType(aPHeads[1])=="B", EVAL(aPHeads[1]), aPHeads[1]),LEN(cFormat))},aFields,{cHead0,cHead1,cHead2},;
   cFormat,aTot,aGroup,bFooter,cFile,,.T.,.T.,LASTREC(),,,,block,;
   ,,,,,,,bSayHead,bKeyHead)>0
   View(cFile,LASTREC(),LEN(cFormat))
ENDIF
GO nRecNo
RestKey(aBlockKey)
RETURN (1)
Back to top
View user's profile Send private message Send e-mail
nordk



Joined: 27 Jun 2005
Posts: 1000
Location: Горбунов Константин
Occupation: БЭСТ-Партнер
Interests: СПб
PostPosted: 06 Nov 2007 17:33    Post subject: Reply with quote
23 БЭСТ-5

Code:
FUNCTION QPrint1(aPHeads,block,bFooter,bSayHead,bKeyHead,aGroup)
//--------------------------------------------------------------------------//
PLOCAL nCo,cFi,cAlias,cFile:=TEMPFILE( GlobalTmpPath )
PLOCAL nRecNo:=RECNO()
PLOCAL aFields:={}
PLOCAL cFormat:='│'
PLOCAL cHead,cField,cPict,cPict0,nField
PLOCAL cHead0:='-',cHead1:='│',cHead2:='+'
PLOCAL aBlockKey:=SaveKey()
PLOCAL aTot:={}
IF (EOF().OR.LASTREC()=0)
 RestKey(aBlockKey)
 RETURN (1)
ENDIF
FOR nCo:=2 TO LEN(aPHeads)
cField:=IF(VALTYPE(aPHeads[nCo])=='A',aPHeads[nCo,2],Field(nCo-1))
//AADD(aFields,FiName(cField))
AADD(aFields,cField)
IF VALTYPE(cField)=="B"
   cPict0:=REPLICATE('X',LEN(aPHeads[nCo,1]))
ELSE
   nField:=FiNum(cField)
   cAlias:=FiAlias(cField)
   IF ((cAlias)->(FIELDTYPE(nField))=='N')
      cPict0:=REPLICATE('9',(cAlias)->(FIELDSIZE(nField)))
      cPict0:=STUFF(cPict0,LEN(cPict0)-(cAlias)->(FIELDDECI(nField)),1,'.')
   ELSE
      cPict0:=REPLICATE('X',(cAlias)->(FIELDSIZE(nField)))
   ENDIF
ENDIF
cPict:=IF((VALTYPE(aPHeads[nCo])=='A'.AND.LEN(aPHeads[nCo])>2).AND.aPHeads[nCo,3]!=NIL,;
aPHeads[nCo,3],cPict0)
cFormat+=cPict+'│'
IF VALTYPE(aPHeads[nCo])=='A'.AND.LEN(aPHeads[nCo])>3.AND.aPHeads[nCo,4]!=NIL;
.AND.aPHeads[nCo,4]
   AADD(aTot,nCo-1)
ENDIF
cHead:=IF(VALTYPE(aPHeads[nCo])=='A',IF(ValType(aPHeads[nCo,1]) = "C",aPHeads[nCo,1],EVAL(aPHeads[nCo,1])),aPHeads[nCo])
cHead0+=REPLICATE('-',LEN(cPict))+'-'
cHead1+=CENTER(cHead,LEN(cPict),.T.)+' '
cHead2+=REPLICATE('-',LEN(cPict))+'-'
NEXT
cHead0:=LEFT(cHead0,LEN(cHead0)-1)+'-'
cHead2:=LEFT(cHead2,LEN(cHead2)-1)+'-'
GO TOP
IF TotRep({PADC(IF(ValType(aPHeads[1])=="B", EVAL(aPHeads[1]), aPHeads[1]),LEN(cFormat))},aFields,{cHead0,cHead1,cHead2},;
   cFormat,aTot,aGroup,bFooter,cFile,,.T.,.T.,LASTREC(),,,,block,;
   ,,,,,,,bSayHead,bKeyHead)>0
   View(cFile,LASTREC(),LEN(cFormat))
ENDIF
GO nRecNo
RestKey(aBlockKey)
RETURN (1)
Back to top
View user's profile Send private message Send e-mail
Display posts from previous:   
Post new topic   This topic is locked: you cannot edit posts or make replies.   printer-friendly view     Forum Index -> Программирование в БЭСТ-4 All times are GMT + 4 Hours
Goto page Previous  1, 2
Page 2 of 2

 
Jump to:  
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


Powered by phpBB © phpBB Group

Rambler
Rambler's Top100 Рейтинг@Mail.ru