Donnay Software Web Forums
http://bb.mobile.donnay-software.com/Donnay/
http://bb.mobile.donnay-software.com/Donnay/viewtopic.php?f=2&t=1409
Code: Select all
**********************************************************************************
*** (C) д.э.н., к.т.н., профессор Луценко Евгений Вениаминович, Россия, Краснодар.
**********************************************************************************
#include "xb2net.ch"
#pragma Library("XB2NET.LIB")
PROCEDURE AppSys
// Рабочий стол остается окном приложения
RETURN
********************************************************************************
FUNCTION Main()
LOCAL GetList[0], GetOptions, nColor, oMessageBox, oMenuWords, oDlg, ;
oMenuBar,oMenu1,oMenu2,oMenu3,oMenu4,oMenu5,oMenu6,oMenu7,;
oMenu3_3
DC_IconDefault(1000)
SET DECIMALS TO 15
SET DATE GERMAN
SET ESCAPE On
SET COLLATION TO SYSTEM // Русификация
*SET COLLATION TO ASCII // Русификация
*** Flag = 0. Что-то вообще не то
*** Flag = 1. Если в текущей папке исполнимого файла системы нет, то скачивание и разархивирование полного архива и запуск системы на исполнение
*** Если в текущей папке исполнимый файл системы есть, то
*** проверка дат создания файла системы и файла обновлений
*** Flag = 2. Если система устарела - скачивание обновлений и запуск новой версии системы
*** Flag = 3. Иначе - запуск существующей версии системы
Flag = 0
mCountSys = ADIR("_aidos-x.exe")
IF mCountSys = 0 // В текущей папке исполнимого файла системы нет
Flag = 1
ELSE
Flag = 2 // Возможно система устарела, надо скачать и развернуть обновления
PRIVATE aName[1], aSize[1], aDate[1]
mCountSys = ADIR("_aidos-x.exe", aName, aSize, aDate )
mDateSys = aDate[1]
StrFile(DTOC(aDate[1]), "DateSys.txt") // Запись текстового файла с датой создания исполнимого модуля системы
ENDIF
cGDServer:="http://lc.kubagro.ru"
Ftp_User :="*********"
Ftp_Passw:="*********"
Ftp_File:="Downloads.exe"
*savepath:="c:\Downloads\"
oFtp := XbFTPClient():new()
IF oFtp:Connect(cGDServer) // Соединение
IF oFtp:Login(Ftp_User, Ftp_Passw) // Авторизация
oFtp:PassiveMode:=.T. // Пассивный режим
// Flag = 1. Если в текущей папке исполнимого файла системы нет, то скачивание и разархивирование полного архива и запуск системы на исполнение
IF Flag = 1
IF oFtp:GetFile(Ftp_File, "Aidos-x.exe")
* LB_Warning('Start and update System "Aidos-X++"', '(C) System "Aidos-X++"' )
ELSE
LB_Warning('Update file can not be found on the FTP server', '(C) System "Aidos-X++"')
ENDIF
ELSE
***** Проверка времени создания файла обновлений без его скачивания прямо на FTP-сервере
aFileUpd:=oFtp:Directory("Downloads.exe")
mDateUpd = CTOD(SUBSTR(aFileUpd[1], 4, 2) + "." + SUBSTR(aFileUpd[1], 1, 2) + ".20" + SUBSTR(aFileUpd[1], 7, 2))
StrFile(DTOC(mDateUpd), "DateUpd.txt") // Запись текстового файла параметров файла обновлений
** Flag = 2. Если система устарела - скачивание обновлений и запуск новой версии системы
IF mDateSys < mDateUpd // Исполнимый файл системы в текущей папке старее файла обновлений
Flag = 2 // Система устарела, надо скачать и развернуть обновления
IF oFtp:GetFile(Ftp_File, "Downloads.exe") // Скачивание файла обновлений
* LB_Warning('Start and update System "Aidos-X++"', '(C) System "Aidos-X++"' )
ELSE
LB_Warning('Update file can not be found on the FTP server', '(C) System "Aidos-X++"')
ENDIF
ELSE
Flag = 3 // Система не устарела, просто запустить ее
ENDIF
ENDIF
ELSE
LB_Warning('Authorization error with the FTP server', '(C) System "Aidos-X++"' )
ENDIF
ELSE
LB_Warning('Error connecting to FTP server', '(C) System "Aidos-X++"' )
ENDIF
oFtp:close()
oFTP:destroy()
*** Если файл обновлений новее установленной на компьютере системы, то развернуть его, иначе просто запустить систему
DO CASE
CASE Flag = 0 // Что-то не то
LB_Warning('Error! Error! Error! Error!', '(C) System "Aidos-X++"' )
CASE Flag = 1 // Flag = 1. Если в текущей папке исполнимого файла системы нет, то скачивание и разархивирование полного архива и запуск системы на исполнение
RunShell("","Aidos-x.exe",.T.) // Полный архив - инсталляция
aMess := {}
AADD(aMess, 'Необходимо выполнить разархивирование')
AADD(aMess, 'и только после этого закрыть данное окно')
AADD(aMess, 'после чего система будет запущена.')
AADD(aMess, '')
AADD(aMess, 'При разархивировании необходимо выбрать')
AADD(aMess, 'опцию: "Копировать поверх всех файлов"')
AADD(aMess, '"Yes to All" или "OwerWrite All"')
LB_Warning(aMess, '(C) System "Aidos-X++"' )
RunShell("","_aidos-x.exe",.T.) // Исполнимый файл системы
CASE Flag = 2 // Flag = 2. Если система устарела - скачивание обновлений и запуск новой версии системы
RunShell("","Downloads.exe",.T.)
aMess := {}
AADD(aMess, 'Необходимо выполнить разархивирование')
AADD(aMess, 'и только после этого закрыть данное окно')
AADD(aMess, 'после чего система будет запущена.')
AADD(aMess, '')
AADD(aMess, 'При разархивировании необходимо выбрать')
AADD(aMess, 'опцию: "Копировать поверх всех файлов"')
AADD(aMess, '"Yes to All" или "OwerWrite All"')
LB_Warning(aMess, '(C) System "Aidos-X++"' )
RunShell("","_aidos-x.exe",.T.)
CASE Flag = 3 // Flag = 3. Запуск существующей версии системы
RunShell("","_aidos-x.exe",.T.)
ENDCASE
RETURN NIL
***********************************************************************************************************************
FUNCTION LB_Warning( message, ctitle )
LOCAL aMsg := {}
* DEFAULT cTitle TO ''
IF valtype(message) # 'A'
aadd(aMsg,message)
ELSE
aMsg := message
ENDIF
IF LEN(ALLTRIM(cTitle)) > 0
DC_MsgBox(10,10,aMsg,cTitle)
ELSE
DC_MsgBox(10,10,aMsg,'Универсальная когнитивная аналитическая система "Эйдос-Х++"')
ENDIF
RETURN NIL
***********************************************************************************************************************
FUNCTION DC_CenterObject( oXbp, oRel )
LOCAL nRelWidth, nRelHeight, nWidth, nHeight, nCol, nRow, aPos
DEFAULT oRel := oXbp:setParent()
nWidth := oXbp:currentSize()[1]
nHeight := oXbp:currentSize()[2]
nRelWidth := oRel:currentSize()[1]
nRelHeight := oRel:currentSize()[2]
nCol := (nRelWidth-nWidth)/6
nRow := (nRelHeight-nHeight)/2
IF oRel == oXbp:setParent()
oXbp:setPos( {nCol,nRow} )
ELSE
aPos := DC_CalcAbsolutePosition({0,0},oRel)
oXbp:setPos( {aPos[1]+nCol,aPos[2]+nRow} )
ENDIF
RETURN nil
***********************************************************************************************************************
/*
╓───────────────────────────────────────────────────╖
║ Program..: _DCMSG.PRG ║
║ Author...: Roger Donnay ║
║ Notice...: (c) DONNAY Software Designs 1987-2000 ║
║ Date.....: Dec 30, 2000 ║
║ Notes....: Message Functions ║
║ ║
║ Functions: dc_msgbox(), dc_confirm() ║
║ dc_errormsg(), dc_msgboxyesno() ║
╙───────────────────────────────────────────────────╜
*/
*---------------
FUNCTION dc_msgbox ( nRow, nCol, aMessage, cTitle, lWait, nSeconds, lYesNo,;
nChoice, aItems, aMenuId, cMenuName, cHotKey, cFont, ;
bEval, nIcon, lNoRestore, lAlwaysOnTop, aColor, ;
aButtSize, lHorizButtons, oOwner )
LOCAL nWidth, i, cSaveScreen, nYesNoCol, nCursor, cSaveColor, ;
lPrint, lConsole, cDevice, aChoice, cColor1, cColor2, ;
cMessage, oDlg, oXbp, nHeight, oParent, lInLoop, oOldApp, ;
GetList := {}, aLocals[7], lOk, nTabGroup, GetOptions, ;
oAppFocus := SetAppFocus(), nLine, cKey, cPrompt, lAction := .f., ;
lOutput, nIconType, nButtHeight, nButtWidth, lPixel, nColumn
l_Escape := DC_MsgBoxEscape()
l_EscHit := .f.
DEFAULT nChoice := 0, ;
lNoRestore := .t., ;
lAlwaysOnTop := .f., ;
lHorizButtons := .f., ;
aColor := DC_MsgBoxColor(), ;
oOwner := SetAppWindow()
IF Valtype( nRow ) = 'C'
aMessage := { nRow }
lWait := .t.
nRow := 0
nCol := 0
ELSEIF Valtype(nRow) ='A'
aMessage := AClone(nRow)
lWait := .t.
nRow := 0
nCol := 0
ENDIF
DC_VALTYPE( @lYesNo, .f. )
DC_VALTYPE( @nRow,0, @nCol,0, @aMessage,{}, @cTitle,DC_MsgBoxTitle(), ;
@nSeconds,0, @lWait,!lYesNo, @aItems,{} )
IF Valtype(nIcon) # 'N'
IF lYesNo
nIcon := XBPSTATIC_SYSICON_ICONQUESTION
nIconType := XBPSTATIC_TYPE_SYSICON
ELSE
nIcon := XBPSTATIC_SYSICON_ICONINFORMATION
nIconType := XBPSTATIC_TYPE_SYSICON
ENDIF
ELSE
nIconType := XBPSTATIC_TYPE_ICON
ENDIF
IF nIcon < 100
nIconType := XBPSTATIC_TYPE_SYSICON
ENDIF
FOR i := 1 TO LEN(aMessage)
aMessage[i] := DC_XtoC(aMessage[i])
NEXT
IF LEN(aMessage)>0 .AND. lWait .AND. !('Y/N'$UPPER(aMessage[1])) ;
.AND. nSeconds=1 .AND. !lYesNo .AND. LEN(aItems)=0
CLEAR TYPEAHEAD
ENDIF
IF ( lYesNo .OR. lWait .OR. LEN(aItems)>0 ) .AND. !DC_Gui() .AND. !DC_MsgBoxGui()
IF LEN( aMessage ) > 0
AADD(aMessage,' ')
ENDIF
AADD(aMessage,' ')
AADD(aMessage,' ')
FOR i := 1 TO LEN(aItems)-2
AADD(aMessage,' ')
NEXT
ENDIF
nWidth := 0
FOR i := 1 TO LEN(aMessage)
nWidth := MAX( nWidth, LEN(aMessage[i]) )
NEXT
FOR i := 1 TO LEN(aItems)
nWidth := MAX( nWidth, LEN(aItems[i])+3 )
NEXT
nWidth := MAX(nWidth,LEN(cTitle)+4)
IF !DC_Gui() .AND. !DC_MsgBoxGui()
nRow := IIF( nRow <> 0, nRow,INT( (DC_Maxrow()-LEN(aMessage)) /2 -1 ) )
nCol := IIF( nCol <> 0 ,nCol,INT( ( DC_Maxcol()-nWidth )/2 - 1 ) )
DC_InkeyRele(0)
nCursor := SET(_SET_CURSOR,0)
cSaveColor := SETCOLOR()
lPrint := SET(_SET_PRINTER,.f.)
lConsole := SET(_SET_CONSOLE,.t.)
cDevice := SET(_SET_DEVICE,'SCREEN')
IF lYesNo .AND. DC_MsgBoxYesNo()
IF nChoice # 2
cColor1 := 'W/G'
cColor2 := 'W+/G'
ELSE
cColor1 := 'W/R'
cColor2 := 'W+/R'
ENDIF
cSaveScreen := DC_Explode( nRow, nCol, nRow+LEN(aMessage)+ ;
IIF(Empty(aItems),1,2), nCol+nWidth+4, ;
cColor1, cColor2,,cTitle )
ELSE
cSaveScreen := DC_EXPL( nRow, nCol, nRow+LEN(aMessage)+IIF(Empty(aItems),1,2),;
nCol+nWidth+4, cTitle )
ENDIF
FOR i := 1 TO LEN(aMessage)
@ nRow+i, nCol+2 SAY aMessage[i]
NEXT
ENDIF
DO CASE
CASE lWait .AND. LEN(aItems)=0 .AND. nSeconds=1 .AND. !DC_Gui() .AND. !DC_MsgBoxGui()
nYesNoCol := nCol + INT( ( nWidth-10 )/2 - 1 )
lYesNo := DC_OK( nRow + LEN(aMessage) - 2, nYesNoCol, nChoice, .t. )
CASE lYesNo .OR. lWait .OR. Len(aItems)>0
IF DC_Gui() .OR. DC_MsgBoxGui()
@ 1,1 DCSTATIC TYPE nIconType SIZE 5,1.8 CAPTION nIcon
IF lYesNo
IF nWidth < 25
nWidth := 25
ENDIF
ELSE
IF nWidth < 20
nWidth := 20
ENDIF
ENDIF
nLine := 3.5
FOR i := 1 TO LEN(aMessage)
@ nLine, 1 DCSAY Pad(aMessage[i],nWidth) FONT cFont SIZE 0
IF Valtype(aColor) == 'A'
ATail(GetList)[aGETLIST_COLOR] := aColor
ENDIF
nLine++
NEXT
nLine++
IF Empty(nChoice)
nChoice := 1
ENDIF
nColumn := 1
IF Empty(aButtSize)
nButtHeight := 1.2
IF lHorizButtons // PC CAW 06-12-12 start // to correct problem where long messages
nButtWidth := 0
FOR i := 1 TO LEN(aItems)
nButtWidth := MAX( nButtWidth, LEN(aItems[i])+3 )
NEXT
ELSE
nButtWidth := nWidth // original code
ENDIF // PC CAW 06-12-12 end
lPixel := .f.
ELSE
nButtHeight := aButtSize[2]
nButtWidth := aButtSize[1]
lPixel := .t.
nLine-- // PC CAW 06-12-12 if button size provided, one extra line was inserted
nLine *= DC_GetOptDefault()[nGETOPT_ROWPIXELS]
ENDIF
IF LEN(aItems) > 0 .AND. lHorizButtons // PC CAW 06-12-12 begin // need to use static for centering in horizontal mode only
nColumn := 0
@ nLine,0 DCSTATIC TYPE XBPSTATIC_TYPE_TEXT ;
SIZE (nButtWidth * len(aItems)) + (IIF( lPixel,10,1.4 )*(len(aItems)-1)), nButtHeight+.5 OBJECT o_Static ;
_PIXEL lPixel
ENDIF // PC CAW 06-12-12 end
FOR i := 1 TO Len(aItems)
cPrompt := Alltrim(aItems[i])
IF '~' $ cPrompt
cKey := Substr(cPrompt,At('~',cPrompt)+1,1)
ELSEIF '&' $ cPrompt
cKey := Substr(cPrompt,At('&',cPrompt)+1,1)
ELSE
cKey := Substr(cPrompt,1,1)
ENDIF
IF i = 1
nTabGroup := XBP_BEGIN_GROUP
ELSEIF i = Len(aItems)
nTabGroup := XBP_END_GROUP
ELSE
nTabGroup := XBP_WITHIN_GROUP
ENDIF
IF !Empty(aItems[i]) .AND. !aItems[i] == '@'
IF lHorizButtons // PC CAW 06-12-12 added for horizontal buttons - begin - to allow centering
@ .2, nColumn DCPUSHBUTTON CAPTION aItems[i] SIZE nButtWidth, nButtHeight ;
ACTION _ActionBlock(i,@nChoice,@cHotKey,GetList,cKey) ;
EVAL _EvalBlock(i,nChoice) ;
_PIXEL lPixel ;
PARENT o_Static ;
TABSTOP ;
FONT cFont ;
TABGROUP nTabGroup ;
ACCELKEY { DC_KeyTran(Asc(Lower(cKey))), DC_KeyTran(Asc(Upper(cKey))) }
ELSE // PC CAW 06-12-12 added for horizontal buttons - end
@ nLine, nColumn DCPUSHBUTTON CAPTION aItems[i] SIZE nButtWidth, nButtHeight ; // original code
ACTION _ActionBlock(i,@nChoice,@cHotKey,GetList,cKey) ;
EVAL _EvalBlock(i,nChoice) ;
_PIXEL lPixel ;
TABSTOP ;
FONT cFont ;
TABGROUP nTabGroup ;
ACCELKEY { DC_KeyTran(Asc(Lower(cKey))), DC_KeyTran(Asc(Upper(cKey))) }
ENDIF
ENDIF
IF lHorizButtons
IF lPixel
nColumn += nButtWidth + 10
ELSE
nColumn += nButtWidth + 1.4
ENDIF
ELSE
IF lPixel
nLine += nButtHeight + 10
ELSE
nLine += 1.4
ENDIF
ENDIF
NEXT
l_YesNo := lYesNo
IF lYesNo .OR. Empty(aItems)
@ nLine,0 DCSTATIC TYPE XBPSTATIC_TYPE_TEXT ;
SIZE IIF( lYesNo,20.6,10 ), 1.7 OBJECT o_Static ;
_PIXEL lPixel
ENDIF
IF lYesNo
IF nChoice = 2
lYesNo := .f.
ENDIF
lAction := .f.
@ .2,.6 DCPUSHBUTTON CAPTION DC_LangMsg(DCMSG_YES) ;
SIZE 9,1.3 ;
PARENT o_Static ;
TABSTOP ;
TABGROUP XBP_BEGIN_GROUP ;
OBJECT oYes ;
ACTION {||lAction := .t., lYesNo := .t., DC_ReadGuiEvent(DCGUI_EXIT_OK,GetList)} ;
EVAL {|o|IIF( lYesNo, SetAppFocus(o),nil ) }
@ .2,11.4 DCPUSHBUTTON CAPTION DC_LangMsg(DCMSG_NO) ;
SIZE 9,1.3 ;
PARENT o_Static ;
TABGROUP XBP_END_GROUP ;
TABSTOP ;
OBJECT oNo ;
ACTION {||lAction := .t., lYesNo := .f., DC_ReadGuiEvent(DCGUI_EXIT_ABORT,GetList)} ;
EVAL {|o|IIF( lYesNo, nil, SetAppFocus(o) ) }
ELSEIF Empty(aItems)
@ .2, .6 DCPUSHBUTTON CAPTION DC_LangMsg(DCMSG_OK) ;
TABSTOP ;
SIZE 9,1.3 ;
PARENT o_Static ;
OBJECT oOk ;
ACTION {||PostAppEvent( xbeP_Close,nil,nil,oDlg )} ;
EVAL {|o|SetAppFocus(o)}
ENDIF
IF !Empty(nRow) .AND. !Empty(nCol)
DCGETOPTIONS NOMAXBUTTON NOMINBUTTON NORESIZE ;
WINDOWROW nRow ;
WINDOWCOL nCol ;
HIDE ;
_ALWAYS lAlwaysOnTop
ELSE
DCGETOPTIONS NOMAXBUTTON NOMINBUTTON NORESIZE ;
HIDE ;
_ALWAYS lAlwaysOnTop
ENDIF
GetOptions[lGETOPT_PIXEL] := .f.
GetOptions[nGETOPT_BUTTONALIGN] := DCGUI_BUTTONALIGN_CENTER
DCREAD GUI FIT MODAL TITLE cTitle OPTIONS GetOptions ;
TIMEOUT nSeconds ;
HANDLER dlgHandler REFERENCE aLocals ;
PARENT @oDlg ;
_NOAUTORESTORE lNoRestore ;
CLEAREVENTS ;
EXPRESS ;
TO lOutput ;
OWNER oOwner ;
EVAL {|o|;
DC_CenterObject(o, oOwner), ;
IIF(lYesNo .OR. Empty(aItems) .OR. lHorizButtons,_CenterStatic(o, aLocals),nil), ; // PC 06-12-12 added to allow centering of horizontal buttons when array presented
o:Show(), ;
IIF(Valtype(bEval)=='B',Eval(bEval,o),nil)}
IF !lOutput
nChoice := 0
ENDIF
IF lAction
lYesNo := lOutput
ENDIF
ELSE
lYesNo := ;
DC_YESNO( nRow + LEN(aMessage) - 2, nYesNoCol, nChoice, .t., cMenuName )
ENDIF
CASE LEN(aItems)>0
aChoice := DC_MSGITEMS( nRow + LEN(aMessage) - LEN(aItems), nCol, ;
nChoice, aItems, aMenuId, cMenuName )
nChoice := aChoice[2]
cHotKey := aChoice[1]
lYesNo := LASTKEY()#27
CASE !DC_Gui() .AND. !DC_MsgBoxGui()
DC_INKEYRELE(0)
DC_INKEY(,nSeconds)
lYesNo := UPPER(CHR(LASTKEY()))='Y'
ENDCASE
IF !DC_Gui() .AND. !DC_MsgBoxGui()
DC_IMPL( cSaveScreen )
DC_INKEYRELE(0)
SET(_SET_CURSOR,nCursor)
SET(_SET_PRINTER,lPrint)
SET(_SET_DEVICE,cDevice)
SET(_SET_CONSOLE,lConsole)
SETCOLOR( cSaveColor )
ELSE
// DC_ClearEvents()
ENDIF
IF Valtype(oAppFocus) = 'O'
SetAppFocus(oAppFocus)
ENDIF
IF l_EscHit // .OR. !lOutput
lYesNo := .f.
nChoice := 0
ENDIF
RETURN lYesNo
* ---------------
STATIC FUNCTION ;
DlgHandler ( nEvent, mp1, mp2, oXbp, oDlg, GetList, aLocals )
IF l_YesNo .AND. nEvent = xbeP_Keyboard
IF mp1 = Asc(Upper(Substr(Strtran(DC_LangMsg(DCMSG_YES),'&',''),1,1))) .OR. ;
mp1 = Asc(Lower(Substr(Strtran(DC_LangMsg(DCMSG_YES),'&',''),1,1)))
SetAppFocus(oYes)
PostAppEvent( xbeP_Keyboard, xbeK_ENTER, nil, oYes )
ELSEIF mp1 = Asc(Upper(Substr(Strtran(DC_LangMsg(DCMSG_NO),'&',''),1,1))) .OR. ;
mp1 = Asc(Lower(Substr(Strtran(DC_LangMsg(DCMSG_NO),'&',''),1,1)))
SetAppFocus(oNo)
PostAppEvent( xbeP_Keyboard, xbeK_ENTER, nil, oNo )
ELSEIF mp1 == xbeK_ESC .AND. l_Escape
l_EscHit := .t.
RETURN DCGUI_EXIT_ABORT
ENDIF
ENDIF
RETURN DCGUI_NONE
*-----------------
STATIC FUNCTION _ActionBlock( i, nChoice, cHotKey, GetList, cKey )
RETURN {||nChoice := i, ;
cHotKey := cKey, ;
DC_ReadGuiEvent(DCGUI_EXIT_OK,GetList)}
*-----------------
STATIC FUNCTION _EvalBlock( i, nChoice )
RETURN {|o|IIF(nChoice == i, SetAppFocus(o),nil)}
*-----------------
FUNCTION dc_yesno ( nSrow, nScol, nChoice, lNoBox, cMenuName )
LOCAL cSaveScrn, cColor1, cColor2, oDlg, oXbp
DC_VALTYPE( @nSrow,0, @nScol,0, @nChoice,1, @lNoBox,.f. )
nSrow := IIF( nSrow <> 0, nSrow,INT( (DC_Maxrow()-1) /2 -1 ) )
nScol := IIF( nScol <> 0 ,nScol,INT( (DC_Maxcol()-15 )/2 - 1 ) )
IF !lNoBox
cSaveScrn := DC_EXPL( nSrow, nScol, nSrow+2, nScol+15 )
ENDIF
DC_At_Prompt( nSrow+1, nScol+2, ' Yes ',,PAD('YES',8) )
DC_At_Prompt( nSrow+1, nScol+9,' No ',,PAD('NO',8) )
nChoice := DC_Menu_To( nChoice, 17, -1,, cMenuName )
DC_IMPL(cSaveScrn)
RETURN nChoice=1
*---------------
FUNCTION dc_ok ( nSrow, nScol, nChoice, lNoBox )
LOCAL cSaveScrn, lInkeyWin := DC_InkeyWin(.t.)
nSrow := IIF(Valtype(nSrow)='N',nSrow,0)
nScol := IIF(Valtype(nScol)='N',nScol,0)
nChoice := IIF(Valtype(nChoice)='N',nChoice,1)
lNoBox := IIF(Valtype(lNoBox)='L',lNoBox,.f.)
nSrow := IIF( nSrow <> 0, nSrow,INT( (DC_Maxrow()-1) /2 -1 ) )
nScol := IIF( nScol <> 0 ,nScol,INT( (DC_Maxcol()-15 )/2 - 1 ) )
IF !lNoBox
cSaveScrn := DC_EXPL( nSrow, nScol, nSrow+2, nScol+15 )
ENDIF
DC_At_Prompt( nSrow+1, nScol+6, ' OK ' )
nChoice := DC_MENU_TO( nChoice, 17, -1 )
DC_IMPL(cSaveScrn)
DC_InkeyWin(lInKeyWin)
RETURN nChoice=1
*---------------
STATIC FUNCTION ;
dc_msgitems ( nSrow, nScol, nChoice, aItems, aMenuId, cMenuName )
nChoice := IIF(Valtype(nChoice)='N',nChoice,1)
RETURN DC_MenuPull( { nSrow,nScol+2,,, 'A',.t.,.f.,,,.f.,,,,,,,;
aItems,,,,,,,,aMenuId }, @nChoice, .f., cMenuName )
/*--------------------*/
FUNCTION dc_confirm ( nRow, nChoice )
DC_INKEYRELE(0)
RETURN DC_MSGBOX( nRow,,,,,,, @nChoice, ;
{ DC_MSG_2_1, DC_MSG_2_2, DC_MSG_2_3 } )
/*--------------------*/
FUNCTION dc_errormsg( aMessage, lSound, cTitle )
LOCAL i, lGui := DC_Gui(), cMessage
DEFAULT lSound := .f., ;
cTitle := 'Error', ;
aMessage := {'An Error Occured!'}
cMessage := ''
IF lSound
FOR i := 1 TO Len(aMessage)
cMessage += aMessage[i] + Chr(13)
NEXT
DC_WinAlert(cMessage)
ELSE
DC_Gui(.t.)
DC_MsgBox(,,aMessage)
DC_Gui(lGui)
ENDIF
RETURN nil
/* --------------------- */
FUNCTION dc_msgboxyesno ( lMode )
STATIC lYesNo := .f.
LOCAL lSaveYesNo := lYesNo
lYesNo := IIF(Valtype(lMode)='L',lMode,lYesNo)
RETURN lSaveYesNo
/* ----------------------- */
/*
xButtons - can be array of button captions, or:
XBPMB_OK, XBPMB_OKCANCEL, XBPMB_ABORTRETRYIGNORE, XBPMB_YESNO,
XBPMB_YESNOCANCEL
nStyle - when <xButtons> is an array, <nStyle> is an icon of type:
XBPSTATIC_SYSICON_ otherwise,
XBPMB_NOICON, XBPMB_QUESTION, XBPMB_WARNING, XBPMB_INFORMATION,
XBPMB_CRITICAL
XBPMB_APPMODAL modal in relation to the Xbase++ app
XBPMB_SYSMODAL modal system wide
XBPMB_MOVEABLE box can be moved
nDefButton- XBPMB_DEFBUTTON1, XBPMB_DEFBUTTON2, XBPMB_DEFBUTTON3
*/
FUNCTION DC_WinAlert( cMessage, cTitle, xButtons, nStyle, ;
nDefButton, oOwner )
LOCAL nReturn, oAppFocus := SetAppFocus()
DEFAULT cTitle TO AppName()
IF ValType(xButtons) == "A"
nReturn := DC_GuiAlert( oOwner, StrTran(cMessage,Chr(10),";"), ;
xButtons, nStyle, cTitle )
SetAppFocus(oAppFocus)
// DC_ClearEvents()
RETURN nReturn
ENDIF
DEFAULT xButtons TO XBPMB_OK
DEFAULT nStyle TO XBPMB_WARNING + XBPMB_MOVEABLE + XBPMB_APPMODAL
DO CASE
CASE nDefButton == Nil; nDefButton := XBPMB_DEFBUTTON1
CASE nDefButton == 2 ; nDefButton := XBPMB_DEFBUTTON2
CASE nDefButton == 3 ; nDefButton := XBPMB_DEFBUTTON3
OTHERWISE ; nDefButton := XBPMB_DEFBUTTON1
ENDCASE
cMessage := Strtran(cMessage,';',Chr(13))
nReturn := ConfirmBox( oOwner, cMessage, cTitle, xButtons, ;
nStyle, nDefButton )
SetAppFocus(oAppFocus)
// DC_ClearEvents()
DO CASE
CASE nReturn == XBPMB_RET_OK ; RETURN XBPMB_RET_OK
CASE nReturn == XBPMB_RET_ABORT ; RETURN XBPMB_RET_ABORT
CASE nReturn == XBPMB_RET_YES ; RETURN XBPMB_RET_YES
CASE nReturn == XBPMB_RET_CANCEL ; RETURN iif(xButtons == XBPMB_OKCANCEL, XBPMB_RET_CANCEL, XBPMB_RET_ABORT)
CASE nReturn == XBPMB_RET_RETRY ; RETURN XBPMB_RET_RETRY
CASE nReturn == XBPMB_RET_IGNORE ; RETURN XBPMB_RET_IGNORE
CASE nReturn == XBPMB_RET_NO ; RETURN XBPMB_RET_NO
CASE nReturn == XBPMB_RET_ENTER ; RETURN XBPMB_RET_ENTER
ENDCASE
RETURN 0
* ------------------ *
FUNCTION DC_IconDefault( noIcon )
STATIC snoIcon := nil
LOCAL noOldIcon := snoIcon
snoIcon := IIF(Valtype(noIcon)$'NO',noIcon,snoIcon )
RETURN noOldIcon
* ----------------------
STATIC FUNCTION _CenterStatic( oDlg, aLocals )
LOCAL nWidth, nDlgWidth, nCol
nWidth := o_Static:currentSize()[1]
nDlgWidth := oDlg:drawingArea:currentSize()[1]
nCol := (nDlgWidth-nWidth)/2
o_Static:setPos({nCol, o_Static:currentPos()[2] } )
RETURN nil
* ----------------------
FUNCTION DC_MsgBoxTitle( cTitle )
STATIC scTitle := nil
LOCAL cOldTitle := scTitle
scTitle := IIF(Valtype(cTitle)='C',cTitle,scTitle )
IF cOldTitle == nil
cOldTitle := AppName()
ENDIF
RETURN cOldTitle
* -----------------------
FUNCTION DC_MsgBoxGui( lGui )
STATIC slGui := .f.
LOCAL lOldGui := slGui
IF Valtype(lGui) = 'L'
slGui := lGui
ENDIF
RETURN lOldGui
* ------------------------
FUNCTION DC_BusyOn( oParentDlg, bDialog )
LOCAL oBusyDlg := Eval( bDialog, oParentDlg )
DEFAULT oParentDlg := AppDeskTop()
oBusyDlg:setParent(oParentDlg)
IF oParentDlg:IsDerivedfrom('XbpDialog')
oParentDlg:drawingArea:disable()
ELSE
oParentDlg:Disable()
ENDIF
DC_CenterObject(oBusyDlg,oParentDlg)
oBusyDlg:show()
oBusyDlg:toFront()
RETURN oBusyDlg
* ------------------------
FUNCTION DC_BusyOff( oBusyDlg )
LOCAL oParentDlg
oParentDlg := oBusyDlg:setParent()
IF oParentDlg:IsDerivedfrom('XbpDialog')
oParentDlg:drawingArea:enable()
ELSE
oParentDlg:enable()
ENDIF
oBusyDlg:destroy()
RETURN nil
* ------------------
GETSETFUNCTION DC_MsgBoxEscape DEFAULT .f.
* ------------------
GETSETFUNCTION DC_MsgBoxColor DEFAULT { nil, nil }
FUNCTION Xb2NetKey(); Return(********) // <-- put your Xb2.NET license key here
Code: Select all
///////////////////////////////////////////////////////////////////////////////
//
// FTPTEST.PRG
//
// Xb2.NET xbFTPClient test program
//
// Copyright (c) 2004-2009, Xb2.NET inc.
// All rights reserved.
//
// Author: Boris Borzic
// Email: support@xb2.net
// Web: http://www.xb2.net
//
///////////////////////////////////////////////////////////////////////////////
#include "xb2net.ch"
procedure Main( cServer, cUserID, cPassword, cPath, cFlag, cFlag2, cFlag3 )
Local oFtp, bCallback
if PCount() == 0 .or. "/?" $ cServer
?
? "USAGE: " + Lower(AppName()) + " URL [uid] [pwd] [path] [/passive] [/securedata] [/show]"
?
? " URL - FTP/FTPS server address or domain name"
? " uid - login userid, default is 'anonymous'"
? " pwd - login password, default is a null string"
? " path - switch to a specific directory"
? " /passive - use passive mode if connecting through a firewall"
? " /securedata - use secure data channel (when using FTPS)"
? " /show - display detailed progress information"
?
? "EXAMPLE:"
? Lower(AppName()) + " ftps://TheBatCave.com batman 1o7T&x0 batfiles /passive/securedata"
?
inkey(0)
quit
endif
// make the console window bigger
SetAppWindow():Configure( NIL, NIL, {0,23}, 45, 80, AppName())
cFlag := lower(var2char(cFlag) + var2char(cFlag2) + var2char(cFlag3))
oFtp := xbFTPClient():new()
oFtp:PassiveMode := "/passive" $ cFlag
oFtp:SecureDataChannel:= "/securedata" $ cFlag
oFtp:RecvTimeout(10000)
oFtp:SendTimeout(10000)
if "/show" $ cFlag
// set callback to see what's going on
// this codeblock will display status/progress info in terminal window:
SetColor("w+/n")
oFtp:SetCallBack({|a,b| DisplayStatus(a,b)})
endif
// if the FTP server needs a certificate from the client do this:
//
// (1) create xbSSLContext object:
//
// oSSL := xbSSLContext():new(SSL_v23)
//
// (2a) if the certificate is in PKCS12 (.PFX) format do this:
//
// if ! oSSL:UsePKCS12File(".\MyCert.pfx", "MyPassword")
// ? "Certificate Error:", xbSSLGetErrorString()
// endif
//
// (2b) if the certificate is in PEM (base64 encoded) format do this:
//
// oSSL:UseCertificateFile(".\MyCert.pem")
// oSSL:UsePrivateKeyFile(".\MyCert.pem")
//
// (3) attach oSSL to oFtp:
//
// oFtp:SetSSLContext(oSSL)
//
// connect to FTP server
if ! oFtp:Connect( cServer )
Terminate( "*** ERROR: Failed to connect to FTP server: " + cServer )
endif
// do login
if oFtp:Login(cUserID, cPassword)
? "Connected to ", cServer
else
Terminate( "*** ERROR: Login failed!" )
endif
// get current directory
? "current dir =", oFtp:GetCurrentDirectory()
if !empty(cPath)
// change directory
if ! oFtp:SetCurrentDirectory(cPath)
Terminate( "*** ERROR: Unable to change path to: " + cPath )
endif
? "path changed, current dir =", oFtp:GetCurrentDirectory()
endif
ShowDir( oFtp )
? "Create directory 'TEST'"
if !oFtp:CreateDirectory("TEST")
Terminate( "*** ERROR: Failed to create directory 'TEST'", .F.)
endif
? "Change path to 'TEST'"
if ! oFtp:SetCurrentDirectory("TEST")
Terminate( "*** ERROR: Unable to change path to: 'TEST'", .F. )
endif
? "path changed, current dir =", oFtp:GetCurrentDirectory()
ShowDir( oFtp )
? "Upload file: " + AppName(.t.)
// if oFtp:PutFile(AppName(.T.), "test.exe")
if oFtp:PutFile("test.exe", "test.exe")
? "Transmitted:", oFtp:BytesTransferred, "bytes in", oFtp:ElapsedTime, "seconds"
else
Terminate( "*** ERROR: Unable to upload file!")
endif
ShowDir( oFtp )
? "Rename file test.exe -> test-1.EXE"
if ! oFtp:RenameFile("test.exe", "test-1.EXE")
Terminate( "*** ERROR: Unable to rename file!")
endif
ShowDir( oFtp )
? "Download file: test-1.EXE"
if oFtp:GetFile("test-1.EXE")
? "Received:", oFtp:BytesTransferred, "bytes in", oFtp:ElapsedTime, "seconds"
else
Terminate( "*** ERROR: Unable to download file!")
endif
?
? "Delete file test-1.EXE"
if ! oFtp:DeleteFile("test-1.EXE")
Terminate( "*** ERROR: Unable to delete file!")
endif
ShowDir( oFtp )
? "Change to parent directory and delete directory 'TEST'"
oFtp:SetCurrentDirectory()
if ! oFtp:DeleteDirectory("TEST")
Terminate( "*** ERROR: Unable to delete directory!", .F.)
endif
ShowDir( oFtp )
oFtp:Destroy()
Terminate("end of test...")
Return
procedure DisplayStatus( nStatus, cMessage )
Local cColor := SetColor(iif(isFTP_ST(nStatus), "n+/n", "r/n"))
? nStatus, cMessage
SetColor(cColor)
Return
procedure Terminate( cMessage, lQuit )
Local cColor
if cMessage != NIL
cColor := SetColor("gr+/n")
? cMessage
inkey(0)
SetColor(cColor)
endif
if lQuit == NIL .or. lQuit
quit
endif
Return
Procedure ShowDir( oFtp )
Local aDir, cColor
cColor := SetColor("g/n")
?
? "Push a key to get directory listing..."
SetColor(cColor)
inkey(0)
aDir := oFtp:Directory()
if empty(aDir)
? "dir: <empty>"
else
? "dir: "
AEval(aDir, {|x| QOut(x)})
endif
?
Return