Screenshot-Captura_Pantallas

HMG Samples and Enhancements

Moderator: Rathinagiri

User avatar
serge_girard
Posts: 2370
Joined: Sun Nov 25, 2012 2:44 pm
DBs Used: 1 MySQL - MariaDB
2 DBF
Location: Belgium
Has thanked: 628 times
Been thanked: 126 times
Contact:

Re: Screenshot-Captura_Pantallas

Post by serge_girard » Mon Oct 03, 2016 4:24 pm

To Roberto:

What is : "#pragma TEXTHIDDEN(1) " and what does it do ??

Thx,

Serge

User avatar
esgici
Posts: 4518
Joined: Wed Jul 30, 2008 9:17 pm
DBs Used: DBF
Location: iskenderun / Turkiye
Has thanked: 391 times
Been thanked: 111 times
Contact:

Post by esgici » Mon Oct 03, 2016 7:16 pm

Roberto Lopez wrote:Well...
...
Happy Capturing!!!

Enjoy!
OK, my two cent:

Code: Select all

/*
Re: Screenshot-Captura_Pantallas
Postby Roberto Lopez » 03 Oct 2016 17:14

Well... 

Be careful, since I've modified certain BOS Taurus functions to use handles instead window names.

Maybe you must rename some of such functions.

BT_WINHANDLE
BT_FILLRECTISNIL
BT_ADJUSTWIDTHHEIGHTRECT
BT_CLIENTAREAWIDTH
BT_CLIENTAREAHEIGHT
BT_BITMAPSAVEFILE
BT_BITMAPRELEASE
BT_BITMAPCAPTURECLIENTAREA

( added RL to BTs )

*/

#include <hmg.ch>

PROC Main()

   DEFINE WINDOW frmCS_Main ;
  	  AT 0,0 ;
		  WIDTH 120 HEIGHT 90 ;
		  TITLE 'Capture Screen' ;
		  MAIN 
      
      ON KEY ESCAPE ACTION ThisWindow.Release   
      
      @ 10, 10 BUTTON btnCapture CAPTION "Capture !" ACTION CaptureSystem()   
       
   END WINDOW
   
   frmCS_Main.Center
   frmCS_Main.Activate
      
RETU // CaptScrn.Main()

/*
   <...>
      DEFINE TIMER Timer_1 ;
      INTERVAL 30000 ;
      ACTION CaptureSystem()
   <...>
*/

*------------------------------------------------------------------------------*
FUNCTION CaptureSystem()
*------------------------------------------------------------------------------*

LOCAL cFileName

   frmCS_Main.Minimize()
   frmCS_Main.Hide
   
   cBaseDir := ''

   dDate   := DATE()

   cYear   := ALLTRIM( STR( YEAR( dDate ) ) )
   cMonth    := ALLTRIM( STRZERO(MONTH( dDate ) , 2 ) )
   cDay    := ALLTRIM( STRZERO(DAY  ( dDate ) , 2 ) )

   cTime   := TIME()

   cHour   := LEFT  ( cTime , 2 )   
   cMinutes  := SUBSTR( cTime , 4 , 2 )
   cSeconds := RIGHT ( cTime , 2)

   cFileName := cBaseDir + cYear + '-' + cMonth + '-' + cDay + '-' + cHour + '-' + cMinutes + '-' + cSeconds 
           
   
   xSAVEWINDOWBYHANDLE ( BT_SCR_GETDESKTOPHANDLE() , cFileName + '.' + 'jpg' , 0 , 0 , 1366 , 768 )

   frmCS_Main.Restore() 
   frmCS_Main.Show

   MsgDebug( cFileName ) 
   
   FTPUP(cFileName + '.jpg' )

   DELETE FILE (cFileName + '.jpg' )

RETURN NIL

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

PROCEDURE FTPUP(cFileName)

   #pragma TEXTHIDDEN(1) 
   cNetServer := 'your server addres here'
   cServer   := cNetServer + ':your server port here'
   cUser     := "your username"
   cPassword := "your password"     
   #pragma TEXTHIDDEN(0) 

   cUrl      := "ftp://" + cUser + ":" + cPassword + "@" + cServer

   oUrl              := tUrl():New( cUrl )
   oFTP              := tIPClientFtp():New( oUrl, .F. )
   oFTP:nConnTimeout := 20000
   oFTP:bUsePasv     := .T.

  
   /* We check if the user has an @ to force the userid */                                                                       
   
   IF At( "@", cUser ) > 0
      oFTP:oUrl:cServer   := cServer
      oFTP:oUrl:cUserID   := cUser
      oFTP:oUrl:cPassword := cPassword
   ENDIF

   IF oFTP:Open( cUrl )

      oFtp:UploadFile( cFileName )

      oFTP:Close()

   ELSE
   
      cStr := "Could not connect to the FTP server" + " " + oURL:cServer    
         
      IF oFTP:SocketCon == NIL
         cStr += Chr( 13 ) + Chr( 10 ) + "Connection uninitialized"
      ELSEIF hb_InetErrorCode( oFTP:SocketCon ) == 0
         cStr += Chr( 13 ) + Chr( 10 ) + "Server Response:" + " " + oFTP:cReply
      ELSE
         cStr += Chr( 13 ) + Chr( 10 ) + "Connection Failed:" + " " + hb_InetErrorDesc( oFTP:SocketCon )
      ENDIF

      *MSGSTOP(cStr)
      
   ENDIF

RETURN

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

*------------------------------------------------------------------------------*
FUNCTION XSAVEWINDOWBYHANDLE ( nHandle , cFileName , nRow , nCol , nWidth , nHeight )
*------------------------------------------------------------------------------*
LOCAL hBitmap

   hBitmap := BTRL_BITMAPCAPTURECLIENTAREA ( nHandle , nRow, nCol, nWidth, nHeight)

   IF hBitmap <> 0

   IF   UPPER(RIGHT( cFileName , 4 ) ) == '.GIF'
         BTRL_BITMAPSAVEFILE (hBitmap, cFileName , BT_FILEFORMAT_GIF )
   ELSEIF   UPPER(RIGHT( cFileName , 4 ) ) == '.JPG'
         BTRL_BITMAPSAVEFILE (hBitmap, cFileName , BT_FILEFORMAT_JPG )
   ELSEIF   UPPER(RIGHT( cFileName , 4 ) ) == '.PNG'
         BTRL_BITMAPSAVEFILE (hBitmap, cFileName , BT_FILEFORMAT_PNG )
   ELSEIF   UPPER(RIGHT( cFileName , 4 ) ) == '.BMP'
         BTRL_BITMAPSAVEFILE (hBitmap, cFileName , BT_FILEFORMAT_BMP )
   ENDIF

   BTRL_BITMAPRELEASE (hBitmap)

   ENDIF

RETURN hBitmap

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

Function BTRL_BITMAPCAPTURECLIENTAREA ( nHandle , Row, Col, Width, Height)
   LOCAL New_hBitmap
   LOCAL Max_Width  := BTRL_CLIENTAREAWIDTH( nHandle )
   LOCAL Max_Height := BTRL_CLIENTAREAHEIGHT( nHandle )
   BTRL_FILLRECTISNIL (@Row, @Col, @Width, @Height, 0, 0, Max_Width, Max_Height)   
   BTRL_ADJUSTWIDTHHEIGHTRECT (Row, Col, @Width, @Height, Max_Width, Max_Height)      
   New_hBitmap := BT_BMP_CAPTURESCR ( nHandle , Col, Row, Width, Height, BT_BITMAP_CAPTURE_DESKTOP)
Return New_hBitmap

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

Function BTRL_BITMAPSAVEFILE (hBitmap, cFileName, nTypePicture)
   LOCAL lRet
   nTypePicture := IF (Valtype(nTypePicture) == "U", BT_FILEFORMAT_BMP, nTypePicture)
   lRet := BT_BMP_SAVEFILE (hBitmap, cFileName, nTypePicture)
Return lRet

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

Function BTRL_BITMAPRELEASE (hBitmap)
   BT_BMP_RELEASE (hBitmap)
Return Nil

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

Function BTRL_CLIENTAREAWIDTH ( nHandle )
   LOCAL Width := BT_SCR_GETINFO ( nHandle , BT_SCR_CLIENTAREA, BT_SCR_INFO_WIDTH)   
Return Width

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

Function BTRL_CLIENTAREAHEIGHT ( nHandle )
   LOCAL Height := BT_SCR_GETINFO ( nHandle , BT_SCR_CLIENTAREA, BT_SCR_INFO_HEIGHT)      
Return Height

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

Function BTRL_FILLRECTISNIL (Row, Col, Width, Height, Row_value, Col_value, Width_value, Height_value)
   Row    := IF (Valtype(Row)    =="U",  Row_value,    Row)
   Col    := IF (Valtype(Col)    =="U",  Col_value,    Col)
   Width  := IF (Valtype(Width)  =="U",  Width_value,  Width)
   Height := IF (Valtype(Height) =="U",  Height_value, Height)   
Return Nil

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

Function BTRL_ADJUSTWIDTHHEIGHTRECT (Row, Col, Width, Height, Max_Width, Max_Height)
   Width  := IF ((Col + Width  > Max_Width),  (Max_Width  - Col), Width)
   Height := IF ((Row + Height > Max_Height), (Max_Height - Row), Height)
Return Nil

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

Function BTRL_WINHANDLE (Win)
   LOCAL hWnd := IF (ValType(Win)=="N", Win, GetFormHandle(Win))
Return hWnd

*._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-._.-  

Capturing and saving captured image OK.

But uploading to ftp failed :(

No any error message but file not found in the server :(

Does anyone can test on his own server ?

Viva HMG :D
Viva INTERNATIONAL HMG :D

User avatar
Roberto Lopez
HMG Founder
Posts: 3980
Joined: Wed Jul 30, 2008 6:43 pm
Has thanked: 27 times
Been thanked: 168 times

Post by Roberto Lopez » Mon Oct 03, 2016 7:18 pm

serge_girard wrote:To Roberto:

What is : "#pragma TEXTHIDDEN(1) " and what does it do ??

Thx,

Serge
Basically, the content between #pragma TEXTHIDDEN(1) and #pragma TEXTHIDDEN(0) are not visible looking at the exe file (ie: with an hex editor).

In my case, the server address, port, username and password are 'hardcoded' inside the prg, so, they must be protected from curious people :)
Regards/Saludos,

Roberto


(Veritas Filia Temporis)

User avatar
Roberto Lopez
HMG Founder
Posts: 3980
Joined: Wed Jul 30, 2008 6:43 pm
Has thanked: 27 times
Been thanked: 168 times

Post by Roberto Lopez » Mon Oct 03, 2016 7:24 pm

esgici wrote:Does anyone can test on his own server ?
Me :)

It has been working for about two weeks.

Please, check address, username, port and password.

And... un-comment the error message display line to see what's going on...
Regards/Saludos,

Roberto


(Veritas Filia Temporis)

User avatar
Roberto Lopez
HMG Founder
Posts: 3980
Joined: Wed Jul 30, 2008 6:43 pm
Has thanked: 27 times
Been thanked: 168 times

Post by Roberto Lopez » Mon Oct 03, 2016 7:27 pm

Roberto Lopez wrote:And... un-comment the error message display line to see what's going on...
This is the line to un-comment:

Code: Select all

  *MSGSTOP(cStr)
Regards/Saludos,

Roberto


(Veritas Filia Temporis)

User avatar
Roberto Lopez
HMG Founder
Posts: 3980
Joined: Wed Jul 30, 2008 6:43 pm
Has thanked: 27 times
Been thanked: 168 times

Post by Roberto Lopez » Mon Oct 03, 2016 7:34 pm

OOPS...

In fact I've uploaded a lot of unneeded code.

Since in Mustafa utility, the capture is already saved to a file, the only thing needed is the FtpUp() function.

You can ignore all other code.

Sorry.
Regards/Saludos,

Roberto


(Veritas Filia Temporis)

User avatar
Roberto Lopez
HMG Founder
Posts: 3980
Joined: Wed Jul 30, 2008 6:43 pm
Has thanked: 27 times
Been thanked: 168 times

Post by Roberto Lopez » Mon Oct 03, 2016 7:44 pm

Roberto Lopez wrote: This is the line to un-comment:

Code: Select all

  *MSGSTOP(cStr)
And... please replace:

Code: Select all

oFtp:UploadFile( cFileName )
With:

Code: Select all

		IF ! oFtp:UploadFile( cFileName )
			MSGINFO('Upload Error!')
		ELSE
			MSGINFO('Upload Ok!')
		ENDIF
Regards/Saludos,

Roberto


(Veritas Filia Temporis)

User avatar
esgici
Posts: 4518
Joined: Wed Jul 30, 2008 9:17 pm
DBs Used: DBF
Location: iskenderun / Turkiye
Has thanked: 391 times
Been thanked: 111 times
Contact:

Post by esgici » Mon Oct 03, 2016 8:05 pm

Roberto Lopez wrote: This is the line to un-comment:
...
And... please replace:
...
Thank you very much,

now I can see: my connection info has some problem :(

( In fact I haven't enough experience on that field :( )

Tomorrow I hope to find some remedies.

Regards

Viva HMG :D
Viva INTERNATIONAL HMG :D

User avatar
Roberto Lopez
HMG Founder
Posts: 3980
Joined: Wed Jul 30, 2008 6:43 pm
Has thanked: 27 times
Been thanked: 168 times

Post by Roberto Lopez » Mon Oct 03, 2016 10:47 pm

esgici wrote:
Roberto Lopez wrote: This is the line to un-comment:
...
And... please replace:
...
Thank you very much,

now I can see: my connection info has some problem :(

( In fact I haven't enough experience on that field :( )

Tomorrow I hope to find some remedies.

Regards

Viva HMG :D
If you have not so much experience with FTP, I recommend you: "Quick and Easy FTP Server":

http://www.pablosoftwaresolutions.com/h ... _lite.html

The lite version supports up to three users, this is enough for testing.
Regards/Saludos,

Roberto


(Veritas Filia Temporis)

User avatar
esgici
Posts: 4518
Joined: Wed Jul 30, 2008 9:17 pm
DBs Used: DBF
Location: iskenderun / Turkiye
Has thanked: 391 times
Been thanked: 111 times
Contact:

Post by esgici » Tue Oct 04, 2016 7:11 am

Roberto Lopez wrote:...
If you have not so much experience with FTP, I recommend you:...
...
The lite version supports up to three users, this is enough for testing.
Thank you very much :arrow:

Best regards,

Viva HMG :D
Viva INTERNATIONAL HMG :D

Post Reply