Send screenshot by network

[Kwai chang caine]

Hello at all

I want to send numerous screenshots by network, what is the better way for have the most smalls files
Compress the picture in JPG or compress the BMP with PB pack ???
Because i have see the Pack cannot compress a JPG because it is enough compressed
Or perhaps another way i don't know ??

Have a good day

[Kwai chang caine]

Thanks for your answer

In fact it's just for maintenance of another pc, like VNC or other software
I not need quality, just can read the text...

I have read on internet, traditionnal screenshots are not enough fast for do this job like VNC, but my problem is not the capture, but the size of the capture
For the moment i have 80k by jpg for have the minimum of quality for a resolution of 1200 x 700 with EncodeImage(#Image, #PB_ImagePlugin_JPEG, 6, 1)
I have thinking perhaps there are a better way for compress picture ???

[infratec]

Hi KCC,

that's the reason why only differences are transmitted and not always full pictures.

I've written a VNC-Server in C and also a (very small one) in PB.
It's not a very big deal.

Here are the basics:

rfb.pbi

Code: Select all

;
; RFB Protocol V 3.3
;
; translated to PB by infratec
;


; Set this For the endian of your machine. 0 = big, 1 = little
#rfbEndianTest = 1


;
; Macro To compare pixel formats.
;
Macro PF_EQ(x,y)
  ((x\bitsPerPixel = y\bitsPerPixel) And (x\depth = y\depth) And (x\trueColour = y\trueColour) And ((x\bigEndian = y\bigEndian) Or (x\bitsPerPixel = 8)) And ( Not x\trueColour Or ((x\redMax = y\redMax) And (x\greenMax = y\greenMax) And (x\blueMax = y\blueMax) And (x\redShift = y\redShift) And (x\greenShift = y\greenShift) And (x\blueShift = y\blueShift))))
EndMacro


;
; Macros For endian swapping.
;
Macro Swap16(s)
  ((((s) & $ff) << 8) | (((s) >> 8) & $ff))
EndMacro

Macro Swap32(l)
  (((l) >> 24) | (((l) & $00ff0000) >> 8)  | (((l) & $0000ff00) << 8)  | ((l) << 24))
EndMacro

CompilerIf #rfbEndianTest = 1
  Macro Swap16IfLE(s)
    Swap16(s)
  EndMacro
CompilerElse
  Macro Swap16IfLE(s)
    (s)
  EndMacro
CompilerEndIf

CompilerIf #rfbEndianTest = 1
  Macro Swap32IfLE(l)
    Swap32(l)
  EndMacro
CompilerElse
  Macro Swap32IfLE(l)
    (l)
  EndMacro
CompilerEndIf



;*****************************************************************************
;*
;* Structures used in several messages
;*
;*****************************************************************************

Structure rfbRectangle
  x.u
  y.u
  w.u
  h.u
EndStructure
#sz_rfbRectangle = 8


Structure rfbPixelFormat
  bitsPerPixel.a ;      /* 8,16,32 only */
  depth.a;      /* 8 to 32 */
  bigEndian.a;      /* True if multi-byte pixels are interpreted as big endian
  trueColour.a;      /* If false then we need a "colour map" to
  ; the following fields are only meaningful If trueColour is true */

  redMax.u
  greenMax.u
  blueMax.u
 
  redShift.a
  greenShift.a
  blueShift.a

  pad1.a
  pad2.u
EndStructure
#sz_rfbPixelFormat = 16


#rfbProtocolMajorVersion = "003"
#rfbProtocolMinorVersion = "003"

#sz_rfbProtocolVersionMsg = 12


Enumeration
  #rfbConnFailed
  #rfbNoAuth
  #rfbVncAuth
EndEnumeration

Enumeration
  #rfbVncAuthOK
  #rfbVncAuthFailed
  #rfbVncAuthTooMany
EndEnumeration



Structure rfbClientInitMsg
  Shared.l
EndStructure
#sz_rfbClientInitMsg = 1


Structure rfbServerInitMsg
  framebufferWidth.u
  framebufferHeight.u
  format.rfbPixelFormat
  nameLength.l
EndStructure
#sz_rfbServerInitMsg = (8 + #sz_rfbPixelFormat)


;*****************************************************************************
;*
;* Message types
;*
;*****************************************************************************/

;* server -> client *
Enumeration
  #rfbFramebufferUpdate
  #rfbSetColourMapEntries
  #rfbBell
  #rfbServerCutText
EndEnumeration


;* client -> server *
Enumeration
  #rfbSetPixelFormat
  #rfbFixColourMapEntries
  #rfbSetEncodings
  #rfbFramebufferUpdateRequest
  #rfbKeyEvent
  #rfbPointerEvent
  #rfbClientCutText

  #rfbEnableExtensionRequest = 10
  #rfbExtensionData
EndEnumeration



;*****************************************************************************
;*
;* Encoding types
;*
;*****************************************************************************
 Enumeration
  #rfbEncodingRaw
  #rfbEncodingCopyRect
  #rfbEncodingRRE
  #rfbEncodingCoRRE = 4
  #rfbEncodingHextile
  #rfbEncodingZlib
  #rfbEncodingTight
  #rfbEncodingZlibHex
  #rfbEncodingZRLE = 16
  #rfbEncodingLzo = 21
EndEnumeration


;*****************************************************************************
;*
;* Server -> client message definitions
;*
;*****************************************************************************

Structure rfbFramebufferUpdateMsg
  type.a;         /* always rfbFramebufferUpdate */
  pad.a
  nRects.u
  ; followed by nRects rectangles
EndStructure
#sz_rfbFramebufferUpdateMsg = 4


Structure rfbFramebufferUpdateRectHeader
  r.rfbRectangle
  encoding.l;   /* one of the encoding types rfbEncoding... */
EndStructure
#sz_rfbFramebufferUpdateRectHeader = #sz_rfbRectangle + 4


Structure  rfbCopyRect
  srcX.u
  srcY.u
EndStructure
#sz_rfbCopyRect = 4


Structure rfbRREHeader
  nSubrects.l
EndStructure
#sz_rfbRREHeader = 4


Structure rfbCoRRERectangle
  x.a
  y.a
  w.a
  h.a
EndStructure
#sz_rfbCoRRERectangle = 4


Macro rfbHextileRaw
  (1 << 0)
EndMacro

Macro rfbHextileBackgroundSpecified
  (1 << 1)
EndMacro

Macro rfbHextileForegroundSpecified
  (1 << 2)
EndMacro

Macro rfbHextileAnySubrects
  (1 << 3)
EndMacro

Macro rfbHextileSubrectsColoured
  (1 << 4)
EndMacro

Macro rfbHextilePackXY(x,y)
  (((x) << 4) | (y))
EndMacro

Macro rfbHextilePackWH(w,h)
  ((((w)-1) << 4) | ((h)-1))
EndMacro

Macro rfbHextileExtractX(byte)
  ((byte) >> 4)
EndMacro

Macro rfbHextileExtractY(byte)
  ((byte) & 0xf)
EndMacro

Macro rfbHextileExtractW(byte)
  (((byte) >> 4) + 1)
EndMacro

Macro rfbHextileExtractH(byte)
  (((byte) & 0xf) + 1)
EndMacro
 


Structure rfbSetColourMapEntriesMsg
  type.a;         /* always rfbSetColourMapEntries */
  pad.a
  firstColour.u
  nColours.u
  ; /* Followed by nColours * 3 * CARD16
  ;     r1, g1, b1, r2, g2, b2, r3, g3, b3, ..., rn, bn, gn */
EndStructure
#sz_rfbSetColourMapEntriesMsg = 6


Structure rfbBellMsg
  type.a
EndStructure
#sz_rfbBellMsg = 1


Structure rfbServerCutTextMsg
  type.a
  pad1.a
  pad2.u
  length.l
  ; followed by char text[length] */
EndStructure
#sz_rfbServerCutTextMsg = 8


Structure rfbEnableExtensionRequestMsg
  type.a;         /* always rfbEnableExtensionRequest */
  new_msg.a
  flags.a
  pad1.a
  length.l
  ; Followed by <length> bytes of Data */
EndStructure


Structure rfbExtensionDataMsg
  type.a
  pad1.a
  pad2.u
  length.l;      /* Must be correct if used
  ; Followed by <length> bytes of Data
EndStructure


Structure rfbServerToClientMsg
  StructureUnion
    fu.rfbFramebufferUpdateMsg
    scme.rfbSetColourMapEntriesMsg
    b.rfbBellMsg
    sct.rfbServerCutTextMsg
    eer.rfbEnableExtensionRequestMsg
    ed.rfbExtensionDataMsg
  EndStructureUnion
EndStructure


;*****************************************************************************
;*
;* Message definitions (client -> server)
;*
;*****************************************************************************

Structure rfbSetPixelFormatMsg
  type.a;         /* always rfbSetPixelFormat */
  pad1.a
  pad2.u
  format.rfbPixelFormat
EndStructure
#sz_rfbSetPixelFormatMsg = (#sz_rfbPixelFormat + 4)


Structure rfbFixColourMapEntriesMsg
  type.a;         /* always rfbFixColourMapEntries */
  pad.a
  firstColour.u
  nColours.u
  ; Followed by nColours * 3 * CARD16
  ; r1, g1, b1, r2, g2, b2, r3, g3, b3, ..., rn, bn, gn */
EndStructure
#sz_rfbFixColourMapEntriesMsg = 6


Structure rfbSetEncodingsMsg
  type.a;         /* always rfbSetEncodings */
  pad.a
  nEncodings.u
  ; followed by nEncodings * CARD32 encoding types */
EndStructure
#sz_rfbSetEncodingsMsg = 4


Structure rfbFramebufferUpdateRequestMsg
  type.a;         /* always rfbFramebufferUpdateRequest */
  incremental.a
  x.u
  y.u
  w.u
  h.u
EndStructure
#sz_rfbFramebufferUpdateRequestMsg = 10


Structure rfbKeyEventMsg
  type.a;         /* always rfbKeyEvent */
  down.a;         /* true if down (press), false if up */
  pad.u;
  key.l;         /* key is specified as an X keysym */
EndStructure
#sz_rfbKeyEventMsg = 8


#rfbButton1Mask = 1
#rfbButton2Mask = 2
#rfbButton3Mask = 4

Structure rfbPointerEventMsg
  type.a;         /* always rfbPointerEvent */
  buttonMask.a;      /* bits 0-7 are buttons 1-8, 0=up, 1=down */
  x.u
  y.u
EndStructure
#sz_rfbPointerEventMsg = 6


Structure rfbClientCutTextMsg
  type.a;         /* always rfbClientCutText */
  pad1.a
  pad2.u
  length.l
  ; followed by char text[length] */
EndStructure
#sz_rfbClientCutTextMsg = 8


Structure rfbClientToServerMsg
  StructureUnion
    spf.rfbSetPixelFormatMsg
    fcme.rfbFixColourMapEntriesMsg
    se.rfbSetEncodingsMsg
    fur.rfbFramebufferUpdateRequestMsg
    ke.rfbKeyEventMsg
    pe.rfbPointerEventMsg
    cct.rfbClientCutTextMsg
    eer.rfbEnableExtensionRequestMsg
    ed.rfbExtensionDataMsg
  EndStructureUnion
EndStructure

And a small example:

rfbcounter.pb

Code: Select all

#rfbMaxClientWait = 20000   ;   time (ms) after which we decide client has
                                ; gone away - needed To stop us hanging */


IncludeFile "rfb.pbi"

Declare.i ListenAtTcpAddr(port.i)
Declare do_client(sock.i)
Declare.i draw_digit(sock.i, digit.i, segl.i, segw.i, fg.i, bg.i, xoffset.i, yoffset.i)
Declare.i draw_counter(sock.i, value.i, numdigits.i, segl.i, segw.i, fg.i, bg.i)
Declare putSubrect(*buf, *lenp, colour.i, x.i, y.i, w.i, h.i)

Declare.i ReadExact(*sock, *buf, len.i)
Declare.i WriteExact(*sock, *buf, len.i)


Global BGR233Format.rfbPixelFormat
BGR233Format\bitsPerPixel = 8
BGR233Format\depth = 8
BGR233Format\bigEndian = 1
BGR233Format\trueColour = 1
BGR233Format\redMax = 7
BGR233Format\greenMax = 7
BGR233Format\blueMax = 3
BGR233Format\redShift = 0
BGR233Format\greenShift = 3
BGR233Format\blueShift = 6


Global screenWidth.i, screenHeight.i
Global fg.i = 0
Global bg.i = $ff
Global segmentWidth.i, segmentLength.i
Global numdigits.i = 4
Global segment_aspect.i = 3 ; length = 3 * width
Global digit_spacing.i = 2  ; space is two segment widths
Global border.i
Global clockmode.i = #False


; Set the segments that make up each digit
#bottom = 1
#bottomLeft = 2
#bottomRight = 4
#middle = 8
#topLeft = 16
#topRight = 32
#top = 64
#all = 127

Global Dim digits.a(10)
digits(0) = #all & ~#middle
digits(1) = #bottomRight | #topRight
digits(2) = #all & ~(#topLeft| #bottomRight)
digits(3) = #all & ~(#topLeft| #bottomLeft)
digits(4) = #topLeft | #middle | #topRight | #bottomRight
digits(5) = #all & ~(#topRight | #bottomLeft)
digits(6) = #all & ~#topRight
digits(7) = #top | #topRight | #bottomRight
digits(8) = #all
digits(9) = #all & ~#bottomLeft


#PROGNAME = "rfbcounter"

Procedure.i main()
 
  Protected s.i, sock.i
  Protected port.u
 
  Protected addrlen.i
  Protected appname.s
 
  Protected argc.i, argv.i
 
  OpenConsole()
 
  appname = GetFilePart(ProgramFilename())
 
  argc = CountProgramParameters()
 
  If argc < 2
     MessageRequester("Info", "usage: " + appname + " [-clock] server-number dispwidth [fg] [bg]")
     End
  EndIf
 
 
  argv = -1
  If FindString(ProgramParameter(0), "-clock")
    clockmode = #True
    argv + 1
    argc + 1
  EndIf
 
   
  port = Val(ProgramParameter(argv + 1))
  If port < 100 : port + 5900 : EndIf
 
  screenWidth = Val(ProgramParameter(argv + 2))
  border = screenWidth / 20

  ; Each char is 2 segment widths + one length wide.
  ; There are (numdigits-1) spaces between digits.
  segmentWidth = (screenWidth - 2 * border) / ((numdigits * (2 + segment_aspect) + (numdigits - 1) * digit_spacing))
  segmentLength = segmentWidth * segment_aspect
  screenHeight = segmentWidth * (3 + 2 * segment_aspect)  + 2 * border
   
  If argc >= 4 : fg = Val(ProgramParameter(argv + 3)) : EndIf
  If argc >= 5 : bg = Val(ProgramParameter(argv + 4)) : EndIf
 
  If InitNetwork() = 0
    End
  EndIf

   
  s = ListenAtTcpAddr(port)
  If s = 0
     End 1
  EndIf
   
  PrintN(appname + ": listening on port " + Str(port))
 
  While #True
     Protected one.i = 1
     Protected pv.s
     Protected auth.l
     Protected cim.rfbClientInitMsg
     Protected sim.rfbServerInitMsg
     Protected Dim textbuf.a(1024)
      
     ; Wait For an incoming connection
     Repeat
       Delay(3)
     Until NetworkServerEvent() = #PB_NetworkEvent_Connect
    
     sock = EventClient()
    
     PrintN(appname + ": accepted connection")
      
     ; Send our protocol version & Read the client's - we ignore it
    pv = "RFB " + #rfbProtocolMajorVersion + "." + #rfbProtocolMinorVersion + #LF$
      
    If WriteExact(@sock, @pv, #sz_rfbProtocolVersionMsg) < 0
      PrintN("Error: Writing protocol version")
       CloseNetworkServer(s)
       End 1
     EndIf
      
     If ReadExact(@sock, @pv, #sz_rfbProtocolVersionMsg) < 0      
       PrintN("Error: Reading client protocol version");
       CloseNetworkServer(s)
       End 1
     EndIf
      
     ; No authentication
     auth = Swap32IfLE(#rfbNoAuth)
     If WriteExact(@sock, @auth, SizeOf(auth)) < 0
       PrintN("Error: Writing NoAuth")
       CloseNetworkServer(s)
       End 1
     EndIf
      
     ; Read & ignore client Init msg
     If ReadExact(@sock, @cim, #sz_rfbClientInitMsg) < 0
       PrintN("Error: Reading client init msg")
       CloseNetworkServer(s)
       End 1
     EndIf
      
     ; Server Init msg
     sim\framebufferWidth = Swap16IfLE(screenWidth)
     sim\framebufferHeight = Swap16IfLE(screenHeight)
     ;sim\format = BGR233Format
     CopyStructure(BGR233Format, sim\format, rfbPixelFormat)
     sim\format\redMax = Swap16IfLE(sim\format\redMax)
     sim\format\greenMax = Swap16IfLE(sim\format\greenMax)
     sim\format\blueMax = Swap16IfLE(sim\format\blueMax)
     sim\nameLength = Len(#PROGNAME)
     sim\nameLength = Swap32IfLE(sim\nameLength)
     ;strcpy(textbuf, #PROGNAME)
     PokeS(@textbuf(0), #PROGNAME)
     If WriteExact(@sock, @sim, #sz_rfbServerInitMsg) < 0
       PrintN("Error: Sending server init msg")
       CloseNetworkServer(s)
       End 1
     EndIf
      
     If WriteExact(@sock, @textbuf, Len(#PROGNAME)) < 0
       PrintN("Error: Sending server name")
       CloseNetworkServer(s)
       End 1
     EndIf
      
     ; Then process this client
    do_client(s)
   
  Wend
 
  CloseNetworkServer(s)
 
  ProcedureReturn 0
   
EndProcedure




main()

End




Procedure do_client(s.i)
 
  While #True
   
     Protected n.i
     Protected msgType.a
    
     ; Peek the first byte of the message To find its type
    
     ; thats not possible with PB, so we have to read the first byte
     ; and later we have to read only the rest (one byte less)
     n = ReadExact(@sock, @msgType, 1)
     If n <= 0
       PrintN("Error: recv")
       ProcedureReturn
     EndIf
    
;     Debug msgType
    
     Select msgType
         
       Case #rfbSetPixelFormat
        
        ; We Read the client's pixel format, but in this simple
        ; program we are Not going To do any translation, so If
        ; the client doesn't either accept what we gave it, or
        ; request BGR233, we close connection.
       
          Protected spf.rfbSetPixelFormatMsg
         
          n = ReadExact(@sock, @spf + 1, SizeOf(rfbSetPixelFormatMsg) - 1)
          If n <= 0
            If n = 0
               PrintN("rfbProcessClientMessage: client gone")
            Else
              PrintN("Error: rfbProcessClientMessage: read")
            EndIf
            ProcedureReturn
          EndIf
            
          spf\format\bitsPerPixel = spf\format\bitsPerPixel
          spf\format\depth = spf\format\depth
          If spf\format\trueColour
            spf\format\trueColour = 1
          Else
            spf\format\trueColour = 0
          EndIf
          If spf\format\bigEndian
            spf\format\bigEndian = 1
          Else
            spf\format\bigEndian = 0
          EndIf
          spf\format\redMax = Swap16IfLE(spf\format\redMax)
          spf\format\greenMax = Swap16IfLE(spf\format\greenMax)
          spf\format\blueMax = Swap16IfLE(spf\format\blueMax)
          spf\format\redShift = spf\format\redShift
          spf\format\greenShift = spf\format\greenShift
          spf\format\blueShift = spf\format\blueShift
            
          If Not PF_EQ(spf\format, BGR233Format)
            PrintN("Error: Client has wrong pixel format")
            ProcedureReturn
          EndIf
            
       
       Case #rfbFixColourMapEntries
         PrintN("Error: rfbProcessClientMessage: cannot handle colourmaps")
          End 1
        
       
       Case #rfbSetEncodings
               
        ; This reads but ignores the encoding List.
          ; We simply check here that the client
          ; can do RRE encoding.
       
          Protected se.rfbSetEncodingsMsg
          Protected enc.l
          Protected i.i
          Protected candoRRE.i = 0
         
          n = ReadExact(@sock, @se + 1, SizeOf(rfbSetEncodingsMsg) - 1)
          If n <= 0
            If n = 0
               PrintN("rfbProcessClientMessage: client gone")
            Else
              PrintN("Error: rfbProcessClientMessage: read")
            EndIf
            ProcedureReturn
          EndIf
            
          se\nEncodings = Swap16IfLE(se\nEncodings)
          For i = 0 To se\nEncodings - 1
            n = ReadExact(@sock, @enc, 4)
            If n <= 0
               If n = 0
                 PrintN("rfbProcessClientMessage: client gone")
               Else
                 PrintN("Error: rfbProcessClientMessage: read")
               EndIf
               ProcedureReturn
             EndIf
             If Swap32IfLE(enc) = #rfbEncodingRRE : candoRRE = 1 : EndIf
          Next i
         
          If Not candoRRE
            PrintN("Error: Client can't do RRE")
            ProcedureReturn
          EndIf
          
       
        Case #rfbFramebufferUpdateRequest
         
         ; This is the important bit.
        ; The client has requested an update, so we need To send it
        ; the display.

          Protected sur.rfbFramebufferUpdateRequestMsg
          Static counterval.i = 0
          Static oldcounterval.i = 0
         
          n = ReadExact(@sock, @sur + 1, SizeOf(rfbFramebufferUpdateRequestMsg) - 1)
          If n <= 0
            If n = 0
              PrintN("rfbProcessClientMessage: client gone")
            Else
              PrintN("Error: rfbProcessClientMessage: read")
            EndIf
            ProcedureReturn
          EndIf
            
          If sur\incremental
;          Debug "Inc"
            If clockmode
               Protected DateTime.i
               While (1)
                 DateTime = Date()                
                 counterval = 100 * Hour(DateTime) + Minute(DateTime)
                 If counterval <> oldcounterval
                   Break;
                 EndIf
                 Delay(60000 - Second(DateTime) * 1000)
               Wend
               oldcounterval = counterval;
            Else
               counterval = (counterval + 1) % 10000
            EndIf
            If Not draw_counter(sock, counterval, numdigits, segmentWidth, segmentLength, fg, bg)
              ProcedureReturn
            EndIf

          Else ; blank the screen initially
;          Debug "Full"
            Protected su.rfbFramebufferUpdateMsg
            Protected rect.rfbFramebufferUpdateRectHeader
            Protected hdr.rfbRREHeader
            Protected colour.a
            su\type   = #rfbFramebufferUpdate
            su\nRects = Swap16IfLE(1)
            WriteExact(@sock, @su, #sz_rfbFramebufferUpdateMsg)
            rect\r\x = Swap16IfLE(0)
            rect\r\y = Swap16IfLE(0)
            rect\r\w = Swap16IfLE(screenWidth)
            rect\r\h = Swap16IfLE(screenHeight)
            rect\encoding = Swap32IfLE(#rfbEncodingRRE)
            WriteExact(@sock, @rect, #sz_rfbFramebufferUpdateRectHeader)
            hdr\nSubrects = Swap32IfLE(0)
            WriteExact(@sock, @hdr, #sz_rfbRREHeader)
            colour = bg
            WriteExact(@sock, @colour, 1)
            oldcounterval = 0

          EndIf
         
         
       Case #rfbKeyEvent
        
        ; Read And ignore key events, except For Q, which quits

        Protected key.rfbKeyEventMsg
       
        n = ReadExact(@sock, @key + 1, SizeOf(rfbKeyEventMsg) - 1)
          If n <= 0
            If n = 0
               PrintN("rfbProcessClientMessage: client gone")
            Else
              PrintN("Error: rfbProcessClientMessage: read")
            EndIf
            ProcedureReturn
          EndIf
         
          key\key = Swap32IfLE(key\key)
          key\key = key\key & $ff
          If key\key = 'q' Or key\key = 'Q'
            ProcedureReturn
          EndIf
         
          
       Case #rfbPointerEvent
        
        ; Read And ignore pointer events
       
        Protected ptr.rfbPointerEventMsg
       
        n = ReadExact(@sock, @ptr + 1, SizeOf(rfbPointerEventMsg) - 1)
          If n <= 0
            If n = 0
               PrintN("rfbProcessClientMessage: client gone")
            Else
              PrintN("Error: rfbProcessClientMessage: read")
            EndIf
            ProcedureReturn
          EndIf
         
         
       Case #rfbClientCutText
        
        ; Read And ignore clipboard messages
       
          Protected ct.rfbClientCutTextMsg
          Protected *buf
         
          n = ReadExact(@sock, @ct + 1, SizeOf(rfbClientCutTextMsg) - 1)
          If n <= 0
            If n = 0
               PrintN("rfbProcessClientMessage: client gone")
            Else
              PrintN("Error: rfbProcessClientMessage: read")
            EndIf
            ProcedureReturn
          EndIf
            
          ct\length = Swap32IfLE(ct\length)
          *buf = AllocateMemory(ct\length)
          If *buf = #Null
            PrintN("Error: Cannot allocate " + Str(ct\length) + " bytes")
            ProcedureReturn
          EndIf
         
          n = ReadExact(@sock, *buf, ct\length)
          If n <= 0
            If n = 0
               PrintN("rfbProcessClientMessage: client gone")
            Else
              PrintN("Error: rfbProcessClientMessage: read")
            EndIf
            ProcedureReturn
          EndIf
            
          FreeMemory(*buf)
          
          
       Default:
         PrintN("rfbProcessClientMessage: unknown message type " + Str(msgType))
         PrintN("rfbProcessClientMessage: ... closing connection")
         ProcedureReturn
      
     EndSelect
    
   Wend
   
EndProcedure




;
; ListenAtTcpAddr starts listening at the given TCP port.
;

Macro DO(x)
  If ((x) < 0) { close(sock); return -1; }
EndMacro

Procedure.i ListenAtTcpAddr(port.i)
  ProcedureReturn CreateNetworkServer(#PB_Any, port, #PB_Network_TCP)
EndProcedure




Procedure.i draw_counter(sock.i, value.i, numdigits.i, segl.i, segw.i, fg.i, bg.i)
 
  Protected su.rfbFramebufferUpdateMsg
  Protected xoffset.i = border
  Protected yoffset.i = border
  Protected i.i
 
  ; This one update will consist of a separate rectangle For each digit
  ; Each rectangle uses RRE encoding, And the subrects draw the segments
 
  su\type = #rfbFramebufferUpdate
  su\nRects = Swap16IfLE(numdigits);
  WriteExact(@sock, @su, #sz_rfbFramebufferUpdateMsg)
 
  ; We draw the digits right To left
  ; The rightmost gopes here:
  xoffset + (numdigits - 1) * (segl + 2 * segw + digit_spacing)
 
  For i = 0 To numdigits - 1
     If Not draw_digit(sock, value % 10, segl, segw, fg, bg, xoffset, yoffset)
       ProcedureReturn 0
     EndIf
     xoffset - segl * ((2 + segment_aspect) + digit_spacing)
    value = value / 10
  Next i
 
  ProcedureReturn 1
 
EndProcedure

Procedure.i draw_digit(sock.i, digit.i, segl.i, segw.i, fg.i, bg.i, xoffset.i, yoffset.i)
 
  Protected rect.rfbFramebufferUpdateRectHeader
  Protected hdr.rfbRREHeader
  Protected Dim buf.a(256)
  Protected len.i = 0
  Protected bits.i = digits(digit)
  Protected *rreheaderbuf
   
  ; A digit is made up of segments As follows:
  ;     -     
  ;    | |     where the length of each seg is segl
  ;     -      And the width is segw.
  ;    | |
  ;     -
 
  ; First calculate the overall dimensions of the segment
  rect\r\x = Swap16IfLE(xoffset)
  rect\r\y = Swap16IfLE(yoffset)
  rect\r\w = Swap16IfLE(2 * segl + segw)
  rect\r\h = Swap16IfLE(3 * segl + 2 * segw)
  rect\encoding = Swap32IfLE(#rfbEncodingRRE)
   
  ; Put this in the buffer ready To send
  CopyMemory(@rect, @buf(len), SizeOf(rfbFramebufferUpdateRectHeader))
  len + SizeOf(rfbFramebufferUpdateRectHeader)
   
  *rreheaderbuf = @buf(len)
  len + SizeOf(rfbRREHeader)
 
  ; background pixel value
  buf(len) = bg & $FF
  len + 1
   
  ; Now insert in the buffer the commands needed To
  ; draw each lit segment.
  hdr\nSubrects = 0
   
  If bits & #bottom
     putSubrect(@buf(0), @len, fg, segl, 2 * segl + 2 * segw, segw, segl)
     hdr\nSubrects + 1
   EndIf
   
  If bits & #bottomLeft
     putSubrect(@buf(0), @len, fg, 0, 2 * segl + segw, segl, segw)
     hdr\nSubrects + 1
   EndIf
   
  If bits & #bottomRight
     putSubrect(@buf(0), @len, fg, segl + segw, 2 * segl + segw, segl, segw)
     hdr\nSubrects + 1
   EndIf
   
  If bits & #middle
     putSubrect(@buf(0), @len, fg, segl, segl + segw, segw, segl)
     hdr\nSubrects + 1
   EndIf
   
  If bits & #topLeft
     putSubrect(@buf(0), @len, fg, 0, segl, segl, segw)
     hdr\nSubrects + 1
   EndIf
   
  If bits & #topRight
     putSubrect(@buf(0), @len, fg, segl+segw, segl, segl, segw)
     hdr\nSubrects + 1
   EndIf
   
  If bits & #top
     putSubrect(@buf(0), @len, fg, segl, 0, segw, segl);
     hdr\nSubrects + 1
  EndIf
   
  hdr\nSubrects = Swap32IfLE(hdr\nSubrects)
  CopyMemory(@hdr, *rreheaderbuf, SizeOf(rfbRREHeader))
   
  ; And then send the buffer To the viewer
 
  If WriteExact(@sock, @buf(0), len) < 0
     PrintN("Error: draw_digit: write")
     ProcedureReturn 0;
  EndIf
   
  ProcedureReturn 1
 
EndProcedure

Procedure putSubrect(*buf, *lenp, colour.i, x.i, y.i, w.i, h.i)
 
  Protected r.rfbRectangle
   
  PokeA(*buf + (PeekI(*lenp)), colour & $FF)
  PokeI(*lenp, PeekI(*lenp) + 1)
 
  r\x = Swap16IfLE(x)
  r\y = Swap16IfLE(y)
  r\w = Swap16IfLE(w)
  r\h = Swap16IfLE(h)
  CopyMemory(@r, *buf + PeekI(*lenp), SizeOf(rfbRectangle))
  PokeI(*lenp, PeekI(*lenp) + SizeOf(rfbRectangle))
EndProcedure



;
; ReadExact reads an exact number of bytes on a TCP socket.  Returns 1 If
; those bytes have been Read, 0 If the other End has closed, Or -1 If an error
; occurred (errno is set To ETIMEDOUT If it timed out).
;

Procedure.i ReadExact(*sock, *buf, len.i)
 
  Protected NServerEvent.i, sock.i, n.i
 
  While len > 0
    Repeat
       Delay(3)
       NServerEvent = NetworkServerEvent()
     Until NServerEvent = #PB_NetworkEvent_Data Or NServerEvent = #PB_NetworkEvent_Disconnect
     If NServerEvent = #PB_NetworkEvent_Data
       sock = EventClient()
       PokeI(*sock, sock)
      n = ReceiveNetworkData(sock, *buf, len)
;      Debug n
       If n > 0
         *buf + n
         len - n
      Else
        ProcedureReturn n
      EndIf
    Else
      ProcedureReturn -2
    EndIf
   Wend
   
  ProcedureReturn 1
 
EndProcedure

;
; WriteExact writes an exact number of bytes on a TCP socket.  Returns 1 If
; those bytes have been written, Or -1 If an error occurred (errno is set To
; ETIMEDOUT If it timed out).
;

Procedure.i WriteExact(*sock, *buf, len.i)
 
  Protected n.i, sock,i
 
   sock = PeekI(*sock)
  While len > 0
     n = SendNetworkData(sock, *buf, len)
      
     If n > 0
       *buf + n
       len - n
     ElseIf n = 0
      PrintN("Error: WriteExact: write returned 0?")
       End 1
    Else
      ProcedureReturn n
    EndIf
   
  Wend
 
  ProcedureReturn 1
   
EndProcedure

If you connect to your local ip address via VNC, than you will see a counter.

Btw. why you don't use VNC in general ?

Bernd

[Kwai chang caine]

Thanks a lot INFRATEC, you are a friend

that's the reason why only differences are transmitted and not always full pictures.

Yeees !!! you have right
I have read on internet, the desktop is cutting in little picture of 10 x 10 pixel i believe ....
And the only picture who is sending is if the picture is not the same on the client and the server

why you don't use VNC in general ?

For several reasons
First i can't install program on some pc i use in my job, because i'm not admin
And the proxy not allow me to download a prg if VNC letters are in the title
After i found using it, is not really easy, because there are too much option now, plugin etc...
And each time i want to use it, or install it i take too much time...
And also, i have try several time to remote pc of person worst than me...yes yes ..it's possible...with less knowledge
And a time, i have take one hour for just say to the user to send me a .DOC of world
I have try also remote directly with XP assistance but this time it's me..i have understand nothing for create an account
All this security unnerve me, because i just use it in local network, or just run it several minutes !!!

But me... i want just do a little thing and never have succés !!!


I have thinking to modify the source of VNC, remove the security, the pluggin, etc .. but i not know the C

So this time i say to me....i create my own VNC, simple, without security
And also a wrapper of main function of PB and create a PBScript, like this i can send a PB code by network, and the client run it

Like this KCC and all the persons i try to help are happy

[Kwai chang caine]

I have try your code...and even that... i cannot run it

I must compile it in console mode i suppose ?
After what is the parameter i must write ???

I have launching this sentence :
C:\VNCServer.exe 5900 800

And nothing

I have run VNC viewer, and it not want to connect