Курсы валют через Интернет в Б4+

// замечания принимаются по адресу 43valery@mail.ru
#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