Курсы валют чз Интернет в Б4+
Select messages from
 # through # FAQ
[/[Print]\]

-> Программирование в БЭСТ-4
#1: Курсы валют чз Интернет в Б4+ Author: Хьюстон, Location: Хардырбиев PostPosted: 19 Oct 2007 20:32
    —
// Всем нуждающимся посвящается !
// замечания принимаются по адресу 43valery@mail.ru
Code:

#include "s_public.ch"
#include "set.ch"
#include "s_refer.ch"
#include "inkey.ch"
#include "my.ch"

Function OldCurs()
Local aSet := SaveSet()
Local nTop := 4,nBottom:=21
Local cBoxHead := 'БЭСТ: Курсы валют [Интернет версия] 1.01'
Local cHead:=' Справочник курсов валют '
Local cColHead:={'Валюта    Дата        Курс    ' }

Local aHeads:={{'Код валюты.................: ','Valuta'},;
               {'Дата установки ............: ','Date'},;
               {'Курс к основной валюте.... : ','VCurs'} }
Local aBlockCols := { { {|| Valuta},   1 },;
                      { {|| Date  },   8 },;
                      { {|| vCurs },  18 } ;
                    }

Local aWhen  := {{|| nApp != 1 },{|| nApp != 1 }}
Local aValid := {,,{|| !Empty(aIn[3]) }}
Local aPict := {,,'9999999.9999'}
Local aRef := {'RefVal'}
Local nUniMode := 2
Local bDelInit := {|| IsDel()}
Local bScrInit
Local aSortSeek:={;
      {'По валютам и датам',{'Введите код валюты.:',;
                   '        и дату.....:'},{'Valuta','DATE'},;
       "UPPER(aIn[1])+DTOS(aIn[2])",{'XXX','@D 99/99/99'},,,'VALUTA' },;
      {'По датам и валютам',  {'Введите дату.......:',;
                   '      и код валюты.:'},{'DATE','Valuta'},;
       "DTOS(aIn[1])+UPPER(aIn[2])",{'@D 99/99/99',"XXX"},,,'DATE' } ;
      }


Local aPrintHeads:={'Справочник курсов валют','Код','Дата','Курс'}
Local cCurProc
Local bPost    ,bDelPost ,aGetBlock ,bColor     ,bColor1    ,;
      nLeftBrd ,bScrPost ,cFindMacro,cCol_Browse,lYesClear  ,;
      bPreGet  ,bPostGet ,nTag      ,nDispRow   ,aHotKey    ,;
      bRestSave,bPostRead,lSubIndex ,bSayHead   ,bKeyHead

   bPreGet := {|| if( nApp==2 ,(aIn[2] := Date(),aIn[3] := 0.0000),) }

   ScrMain()
   ScrTitul(1,cBoxHead)
   ScrTitul(24,;
   "┘:Изм F2:Узнать F3:Сорт F4:Ввод F5:Обновить F6:Фильтр F7:Пск F8:Удалить")


   ShadowBox(cHead,3,20,22,60,COL_BROWSE)

   if m_Open_Base( {'Valuta','vCurs','Plan0','Main'} )
      UT_SetFilter('Upper(Code) != GlobalValuta','Valuta')
      MakeRefer("RefVal","Валюта",1,{"Код","Наименование"},{4,43,12},COL_REFER, {"Code"},{"aIn[1]"},"aIn[1]")
      SetKey(K_F5      ,{|| IRefresh() })
      SetKey(K_F2      ,{|| IKnown() })
      Select vCurs
      InitList(nTop,nBottom,cColHead,aBlockCols,cCurProc,aHeads,aRef,;
         aPict,aWhen,aValid,nUniMode,bDelInit,bScrInit,aSortSeek,aPrintHeads,;
               bPost    ,bDelPost ,aGetBlock ,bColor     ,bColor1    ,;
               nLeftBrd ,bScrPost ,cFindMacro,cCol_Browse,lYesClear  ,;
               bPreGet  ,bPostGet ,nTag      ,nDispRow   ,aHotKey    ,;
               bRestSave,bPostRead,lSubIndex ,bSayHead   ,bKeyHead   )





       ClearRefer()
       m_Close_Base( {'Valuta','vCurs','Plan0','Main'} )
   endif

   RestSet(aSet)
Return NIL

static Function IsDel()
Local OldSel := Select()
Local lResult
  Begin Sequence
    lResult := .f.
    Main->(__dbLocate( {|| Upper( Main->Valuta ) == Upper(vCurs->Valuta).and.Main->DataOper == vCurs->Date},,,, .F. ))
    if Found()
      SayError( "Значение курса использовано в проводках" )
      Break
    endif

     Plan0->(__dbLocate( {|| Upper( Plan0->Valuta ) == Upper(vCurs->Valuta).and.Plan0->Date - 1 == vCurs->Date},,,, .F. ))
    if Found()
      SayError( "Значение курса использовано в вступительном балансе" )
      Break
    endif

    lResult := .t.
  End Sequence
Select( OldSel)
Return (lResult)


Static Function IRefresh()
Local aSet:={SaveSet(),SaveSetKey()}
Local GetList := {},oGet
Local OldDateFormat:=Set(_SET_DATEFORMAT,"dd.mm.yyyy")
Local nTop := 10,nLeft := 10,nBottom:=16,nRight:=71
Local nOff := 29
Local xmlDoc,nodeList,xmlNode,node_attr
Local url_request
Local iIndex,iEnd,i,n
Local bDate,eDate
Local cDate,dDate,cCurs,nCurs,cCode,cName,xDate
Local aPrev := NIL

Private aDop:={;
                  {.T.," Да  "},;
                  {.F.," Нет "} ;
                 }


Private aIn:=Array(5)

Private aCBR := {; //       12345678901234567890
                 {'R01235',"Доллар США          "};
                }

aIn[1] := vCurs->Valuta
aIn[2] := 'R01235'
aIn[3] := Bom(Date())
aIn[4] := Date()
aIn[5] := .f.



Begin Sequence

         TRY
            xmlDoc := CreateObject( "MSXML2.DomDocument" )
         CATCH
            TRY
             xmlDoc := CreateObject( "MSXML2.DomDocument.4.0" )
            CATCH
              SayError( "MsXml2 не доступен!")
              Break
             END
         END

         xmlDoc:async := .f.

         url_request := "http://www.cbr.ru/scripts/XML_val.asp?d=0"
           Busy(.T.,"Запрос справочника валют")
          if !xmldoc:Load(url_request)
            SayError("Cправочник валют не загружен !")
            Busy(.F.)
            Break
         end
         Busy(.F.)
         NodeList := xmldoc:selectNodes("*/Item")
         iEnd := NodeList:length - 1

           if iEnd < 0
            SayError( "Справочник валют не загружен !")
            Break
         endif
         aCBR := {}


         For iIndex := 0 To iEnd
             xmlNode := NodeList:Item(iIndex):cloneNode(.t.)
             cCode := xmlNode:Attributes(0):Value // Код валюты
             cName := AnsiToOem(xmlNode:childNodes(0):Text) // Наименование
             cName := Left(cName,30)
             cName := Padr(cName,30)
             aadd(aCBR,{cCode,cName})
         next


   ShadowBox("",nTop,nLeft,nBottom,nRight,COL_INPUT,)
                       // 12345678901234567890123456789
   @ nTop+1,nLeft +1 Say "Валюта БЭСТ               :" Color 'w/bg'
   @ nTop+2,nLeft +1 Say "Валюта ЦБР                :" Color 'w/bg'
   @ nTop+3,nLeft +1 Say "Начальная дата дд.мм.гггг :" Color 'w/bg'
   @ nTop+4,nLeft +1 Say "Конечная дата дд.мм.гггг  :" Color 'w/bg'
   @ nTop+5,nLeft +1 Say "Дополнять вых. и пр. дни  :" Color 'w/bg'



   @ nTop+1,nLeft+nOff REFER 'RefVal' GET aIn[1] PICTURE "XXX" Color COL_GET

   oGet:=GETNEW(nTop+2,nLeft+nOff,{|x|IF(x=NIL,aIn[2],aIn[2] := aCBR[1])})
   oGet:block:={|x|RotateBlock(x,aCBR,'aIn[2]')}
   oGet:reader   := {|x|RotateAndReader(x,aCBR) }
   oGet:ColorSpec := COL_GET
   AADD(GetList, oGet)

   @ nTop+3,nLeft+nOff GET aIn[3] PICTURE "@D" Color COL_GET VALID aIn[3] <= aIn[4]
   @ nTop+4,nLeft+nOff GET aIn[4] PICTURE "@D" Color COL_GET VALID aIn[4] >= aIn[3]


   oGet:=GETNEW(nTop+5,nLeft+nOff,{|x|IF(x=NIL,aIn[5],aIn[5] := aDop[1])})
   oGet:block:={|x|RotateBlock(x,aDop,'aIn[5]')}
   oGet:reader   := {|x|RotateAndReader(x,aDop) }
   oGet:ColorSpec := COL_GET
   AADD(GetList, oGet)




   AEVAL( GetList, {|x| x:Display() } )







   SetCursor(1)
   READ
   SetCursor(0)




   if LastKey() != K_ESC.and. YesOrNo({"Запросить курсы валюты "+aIn[1]+ " ?",;
               "Период запроса с "+Dtoc(aIn[3])+" по "+Dtoc(aIn[4])},,,,,,COL_BROWSE)

       bDate := DTOC(aIn[3])
       eDate := DTOC(aIn[4])


       url_request := "http://www.cbr.ru/scripts/XML_dynamic.asp?date_req1="+bDate+"&date_req2="+eDate+"&VAL_NM_RQ="+aIn[2]
       Busy(.T.,"Выполнение запроса")
       if !xmldoc:Load(url_request)
          SayError("Курсы валют не загружены !")
          Busy(.F.)
          Break
       end
       Busy(.F.)
       NodeList := xmldoc:selectNodes("*/Record")
       iEnd := NodeList:length - 1
       if iEnd < 0
            SayError( "Курсы валют не загружены !")
            Break
       endif


       Busy(.T.,"Обработка результата запроса")
       For iIndex := 0 To iEnd
           xmlNode := NodeList:Item(iIndex):cloneNode(.t.)

           cDate := xmlNode:Attributes(0):Value // Дата
           cCode := xmlNode:Attributes(1):Value // Код валюты
           cCurs := xmlNode:childNodes(1):Text // Курс

           cCurs := StrTran( cCurs, ',','.')
           nCurs := Val(cCurs)
           dDate := CTOD(cDate)
           altd()
           if aIn[5].and.aPrev != NIL

              if dDate != aPrev[1] + 1
                 xDate := aPrev[1] + 1
                 while xDate != dDate
                      if vCurs->(dbSeek( Upper(aIn[1])+DTOS(xDate) ))
                         if vCurs->(RecLock())
                            vCurs->vCurs := aPrev[2]
                            vCurs->(dbUnLock())
                         endif
                        else
                         if vCurs->(AddRec())
                            vCurs->Valuta := aIn[1]
                            vCurs->Date := xDate
                            vCurs->vCurs := aPrev[2]
                            vCurs->(dbUnLock())
                          endif
                      endif
                     xDate++
                 enddo
              endif

           endif


           aPrev := {dDate,nCurs}





           if vCurs->(dbSeek( Upper(aIn[1])+DTOS(dDate) ))
              if vCurs->(RecLock())
                 vCurs->vCurs := nCurs
                 vCurs->(dbUnLock())
              endif
             else
              if vCurs->(AddRec())
                 vCurs->Valuta := aIn[1]
                 vCurs->Date := dDate
                 vCurs->vCurs := nCurs
                 vCurs->(dbUnLock())
               endif
           endif
       next

       vCurs->(dbSeek( Upper(aIn[1])+DTOS(aIn[3]) ))
//       vCurs->(dbGoTop())
        Busy(.F.)
        SayAndWait("Курсы валюты "+aIn[1]+ " обновлены успешно.")






   endif

End Sequence

   Set(_SET_DATEFORMAT,OldDateFormat)

   RestSet(aSet[1])
   RestSetKey(aSet[2])
Return NIL

static Function UT_SetFilter(cFilter,cAlias,cFocus)
cAlias  := if(cAlias   == NIL,,cAlias)
cFocus  := if(cFocus   == NIL,,cFocus )
cFilter := if(cFilter  == NIL,,cFilter )
   if Empty(cFilter)
      Return .f.
   end
   if !Empty(cAlias)
      dbSelectArea(cAlias)
   end
   if !Empty(cFocus)
      OrdSetFocus(cFocus)
   end
   dbSetFilter({|| &cFilter}, cFilter)
   dbGoTop()
Return .t.



Static Function IKnown()
Local aSet:={SaveSet(),SaveSetKey()}
Local GetList := {},oGet
Local OldDateFormat:=Set(_SET_DATEFORMAT,"dd.mm.yyyy")
Local nTop := 10,nLeft := 10,nBottom:=13,nRight:=71
Local nOff := 29
Local xmlDoc,nodeList,xmlNode,node_attr
Local url_request
Local iIndex,iEnd,i,n
Local bDate,eDate
Local cDate,dDate,cCurs,nCurs,cCode,cName,xDate
Local aPrev := NIL

Private aIn:=Array(2)

Private aCBR := {; //       12345678901234567890
                 {'R01235',"Доллар США          "};
                }

aIn[1] := 'R01235'
aIn[2] := Date()




Begin Sequence

         TRY
            xmlDoc := CreateObject( "MSXML2.DomDocument" )
         CATCH
            TRY
             xmlDoc := CreateObject( "MSXML2.DomDocument.4.0" )
            CATCH
              SayError( "MsXml2 не доступен!")
              Break
             END
         END

         xmlDoc:async := .f.

         url_request := "http://www.cbr.ru/scripts/XML_val.asp?d=0"
           Busy(.T.,"Запрос справочника валют")
          if !xmldoc:Load(url_request)
            SayError("Cправочник валют не загружен !")
            Busy(.F.)
            Break
         end
         Busy(.F.)
         NodeList := xmldoc:selectNodes("*/Item")
         iEnd := NodeList:length - 1

           if iEnd < 0
            SayError( "Справочник валют не загружен !")
            Break
         endif
         aCBR := {}


         For iIndex := 0 To iEnd
             xmlNode := NodeList:Item(iIndex):cloneNode(.t.)
             cCode := xmlNode:Attributes(0):Value // Код валюты
             cName := AnsiToOem(xmlNode:childNodes(0):Text) // Наименование
             cName := Left(cName,30)
             cName := Padr(cName,30)
             aadd(aCBR,{cCode,cName})
         next


   ShadowBox("",nTop,nLeft,nBottom,nRight,COL_INPUT,)
                       // 12345678901234567890123456789
   @ nTop+1,nLeft +1 Say "Валюта ЦБР                :" Color 'w/bg'
   @ nTop+2,nLeft +1 Say "Дата запроса дд.мм.гггг   :" Color 'w/bg'


   oGet:=GETNEW(nTop+1,nLeft+nOff,{|x|IF(x=NIL,aIn[1],aIn[1] := aCBR[1])})
   oGet:block:={|x|RotateBlock(x,aCBR,'aIn[1]')}
   oGet:reader   := {|x|RotateAndReader(x,aCBR) }
   oGet:ColorSpec := COL_GET
   AADD(GetList, oGet)

   @ nTop+2,nLeft+nOff GET aIn[2] PICTURE "@D" Color COL_GET
   AEVAL( GetList, {|x| x:Display() } )

   SetCursor(1)
   READ
   SetCursor(0)


   if LastKey() != K_ESC.and. YesOrNo({"Запросить курс валюты ?",;
               "Запрос на "+Dtoc(aIn[2])},,,,,,COL_BROWSE)

       bDate := DTOC(aIn[2])
       eDate := DTOC(aIn[2])


       url_request := "http://www.cbr.ru/scripts/XML_dynamic.asp?date_req1="+bDate+"&date_req2="+eDate+"&VAL_NM_RQ="+AllTrim(aIn[1])
       Busy(.T.,"Выполнение запроса")
       if !xmldoc:Load(url_request)
          SayError("Курс валюты не загружены !")
          Busy(.F.)
          Break
       end
       Busy(.F.)
       NodeList := xmldoc:selectNodes("*/Record")
       iEnd := NodeList:length - 1
       if iEnd < 0
            SayError( "Курс валюты не найден !")
            Break
       endif

       Busy(.T.,"Обработка результата запроса")
       For iIndex := 0 To iEnd
           xmlNode := NodeList:Item(iIndex):cloneNode(.t.)
           cDate := xmlNode:Attributes(0):Value // Дата
           cCode := xmlNode:Attributes(1):Value // Код валюты
           cCurs := xmlNode:childNodes(1):Text // Курс

           cCurs := StrTran( cCurs, ',','.')
           nCurs := Val(cCurs)
           dDate := CTOD(cDate)
       Next
        Busy(.F.)
        SayAndWait({"Курс валюты на "+Dtoc(aIn[2]) +" = "+ cCurs })
   endif

End Sequence

   Set(_SET_DATEFORMAT,OldDateFormat)

   RestSet(aSet[1])
   RestSetKey(aSet[2])
Return NIL
-> Программирование в БЭСТ-4


output generated using printer-friendly topic mod. All times are GMT + 4 Hours

Page 1 of 1

Powered by phpBB © 2001, 2005 phpBB Group