Code: Select all | Expand

ACTIVATE WINDOW oWnd maximized ;
                  ON INIT ( apertura( "A" ) ) ;  

                  ON RESIZE (definebar(oWnd:nWidth), oBmp:Center())
FreeLibrary(hBWC)
return nil


function defineBar(wnwidth)
  oBar:lVisible := .f.
   nSize = wnWidth / 9

DEFINE BUTTONBAR oBar OF oWnd SIZE nsize,80 2007
DEFINE BUTTON OF oBar resource "QUIT";  // FILE "Exit.bmp"      ;
   ACTION oWnd:End() ;
   MESSAGE "Finalizar El Programa";
   TOOLTIP "Salida" prompt "Salir"

y asi los demas botones 

al final:
 obar:update()
   obar:refresh()
   oBar:lVisible := .T.
   ownd:update()
   ownd:refresh()

Code: Select all | Expand

DEFINE WINDOW oWnd FROM 3,3 TO 25, 75 ;
   TITLE oemtoansi(" Facturaci¢n V 13.13") ;
   MENU BuildMenu()

   SET MESSAGE OF oWnd TO FWAUTOR centered
@ 5, 16 BITMAP oBmp FILENAME "logo.bmp" noborder
   DEFINE FONT jorfon NAME "Times New Roman" bold SIZE 25, 50
   @6, 1 say spac( 2 ) + xempresa + spac( 45 ) font jorfon color CLR_GRAY, CLR_WHITE

ACTIVATE WINDOW oWnd maximized ;
                  ON INIT ( apertura( "A" ) ) ;  // , prueba() pedro(),      , inicio()
                  ON RESIZE (definebar(oWnd:nWidth), oBmp:Center())

FreeLibrary(hBWC)
return nil


function defineBar(wnwidth)

   nSize = wnWidth / 9  

DEFINE BUTTONBAR oBar OF oWnd SIZE nsize,80 2007
*   oBar:SetFont( oFont )
*   oBar:SetColor( { |l,o| If( l, CLR_BLACK, CLR_WHITE ) }, oWnd:nClrPane )
*   oBar:bClrGrad := { |lInvert| If( lInvert, nArgb( 96, CLR_WHITE ), nArgb( nAlpha % 256, nBarClr ) ) }

DEFINE BUTTON OF oBar resource "QUIT";  // FILE "Exit.bmp"      ;
   ACTION oWnd:End() ;
   MESSAGE "Finalizar El Programa";
   TOOLTIP "Salida" prompt "Salir"

  DEFINE BUTTON OF oBar resource "users"; // FILE "Calc.bmp"      ;
  ACTION  clients() ;
  TOOLTIP "Clientes" prompt "Clientes"

  DEFINE BUTTON OF oBar resource "setup"; // FILE "Calc.bmp"      ;
  ACTION  val_stk2() ; // Modify first button text
   TOOLTIP "Consulta ficha de stock" ;
   PROMPT  "&Consulta Stock"


  DEFINE BUTTON OF oBar resource "presupu"; // FILE "Calc.bmp"      ;
  ACTION  facturas() ; // MsgInfo( "Search" ) ;
   TOOLTIP "Facturar" ;
   PROMPT  "Facturar"

   DEFINE BUTTON OF oBar prompt  "&Cambiar fondo"  resource "app" ACTION selcolorfondo() ;
   tooltip oemtoansi( "Cambiar color de fondo" )

   DEFINE BUTTON OF oBar prompt  "&Cambiar Empresa"  resource "setup" ACTION selempre() ;
   tooltip oemtoansi( "Cambiar Empresa vigente" )

   DEFINE BUTTON oBtn OF oBar PROMPT "Color"  resource "colors" ;
      ACTION ( nBarClr := ChooseColor( RGB( 0, 0x2E, 0x5C ) ), oBar:Refresh() )

  MENU oPopup POPUP 2007
          MENUITEM "&IVA Ventas" action librovta() ;
   message "IVA Ventas"

   MENUITEM "&Ventas anuales"  ACTION  vtastot() ;  //WinHelp( "ayudafac.hlp" );
      MESSAge "Ventas mensuales"

   MENUITEM "&Comprobantes en la AFIP " ACTION CompAFIP() ;
   message "Consulta de comprobantes emitidos"
   MENUITEM "&Comprobantes en la AFIP por fecha " ACTION CompAFIPFec() ;
   message "Consulta de comprobantes emitidos"

MENUITEM "&Archivos SQL"  ACTION ABMSQLAll() ;
   message oemtoansi( "Editar archivos" )

   MENUITEM "&Traductor"  ACTION traductor() ;
   message oemtoansi( "Editar archivos" )

   MENUITEM "&e-mail"  ACTION ConfEmail() ;
   message oemtoansi( "Configurar e-mail" )

ENDMENU
   DEFINE BUTTON oBtn OF oBar ACTION oBtn:ShowPopup() ;
      RESOURCE "print" PROMPT "Listados" GROUP ;
      MENU oPopup TOOLTIP "Listados"
   oBar:Adjust()
      ownd:refresh()

   retu .t.

Code: Select all | Expand

// C:\FWH2603\SAMPLES\JPJORGE1.PRG

#include "FiveWin.ch"

#define CLR_DARK_TEXT         nRGB( 220, 220, 220 )
#define CLR_DARK_BACK         nRGB( 030, 030, 030 )
#define CLR_DARK_BACK2        nRGB( 050, 050, 050 )
#define CLR_DARK_SEL          nRGB( 0x33, 0x33, 0x99 )
#define CLR_DARK_ORANGE       nRGB( 139, 064, 000 )

#define aPubGrad { | lInvert | If( ! lInvert, { { 0.50,16776960,16777215 }, ;
      { 0.50, 16777215, 16776960 } }, { { 0.50, 128, 16777215 },     ;
      { 0.50, 16777215, 128 } } ) }

STATIC oWnd, oFont, nHFont, cFont, nWFont, oBar, JorFon, oFnt
STATIC nTamano // := 64 // SIZE
STATIC nAlturA // := 70
STATIC wnWidth, nSize

FUNCTION Main()

   LOCAL oIco, oBmp, oBar, XEMPRESA
   LOCAL nSize := 40, nWidth := 44

   xEMPRESA := [FIVETECH SOFTWARE ENTENPRISE]

   cFont  := "Verdana"
   nHFont := 18 // 14

   SetBalloon( .T. ) // Balloon shape required for tooltips

   MsgRun( "AGUARDE... ABRINDO OS BANCOS DE DATOS.   ",                      ;
      "Por Favor, Espere Apertura. Pode Demorar.",                      ;
      { || WinExec( APERTURA() ), 3 } )

   DEFINE ICON oIco FILE "..\..\icons\fax.ico"
   DEFINE FONT oFont NAME cFont SIZE 0, - nHFont
   DEFINE FONT oFnt  NAME 'TAHOMA' SIZE 0, - 12 BOLD
   DEFINE FONT JorFon NAME "Times New Roman" bold SIZE 25, 50

   DEFINE WINDOW oWnd FROM 3, 3 TO 25, 75       ;
      TITLE oemtoansi( " Facturaci¢n V 13.13" ) ;
      MENU BuildMenu()

   // SET MESSAGE OF oWnd TO FWAUTOR centered
   DEFINE MESSAGE OF oWnd ;
      PROMPT FWVERSION + " " + FWCOPYRIGHT ;
      NOINSET CENTERED KEYBOARD DATE CLOCK 2007

   // @ 5, 16 BITMAP oBmp FILENAME "logo.bmp" noborder
   @ 5, 16 BITMAP oBmp FILENAME "logo.jpg" NOBORDER // .jpg es menor.

   @6, 18 SAY SPACE(02) + xEMPRESA + SPACE(45) FONT JorFon ;
      COLOR CLR_GRAY, CLR_WHITE TRANSPARENT CENTER

   ACTIVATE WINDOW oWnd MAXIMIZED ;
      ON INIT ( apertura( "A" ) ) ;
      ON RESIZE ( DEFINEBAr(), oBmp:Center() )

// FreeLibrary(hBWC)

oFont:End()
JorFon:End()
oFnt:End()

RETURN nil

FUNCTION DefineBar( )

   LOCAL nBarClr, oBtn, oPopup, oSalida
   LOCAL oBtn1, oBtn2, oBtn3, oBtn4, oBtn5, oBtn6
   LOCAL nResHoriz
   LOCAL nResVert

   nResHoriz := oWnd:nHorzRes()
   nResVert  := oWnd:nVertRes()

   nSize     := INT( nResHoriz ) / 20.00 // 64
   nTamano   := INT( nResHoriz ) / 20.00 // 64
   nAltura   := INT( nResVert  ) / 10.97 // 70

   // nTamano := 64 // SIZE
   // nAltura := 70
   DEFINE BUTTONBAR oBar OF oWnd SIZE nTamano, nAltura 2007  // FUNCIONA
   // O:
   // DEFINE BUTTONBAR oBar OF oWnd SIZE nSize, nAltura 2007 // FUNCIONA

   WITH OBJECT oBar

  oBar:bClrGrad := aPubGrad

  oBar:lVisible := .T.
  oBar:SetFont( oFnt  )
  oBar:nClrText := CLR_DARK_ORANGE
  oBar:Adjust()

   END

   DEFINE BUTTON oBtn1 OF oBar resource "users"                            ;
      ACTION  clients() GROUP TOP                                          ;
      TOOLTIP "Clientes" PROMPT "Clientes"

   DEFINE BUTTON oBtn2 OF oBar resource "setup"                            ;
      ACTION  val_stk2() GROUP TOP                                         ;
      TOOLTIP "Consulta ficha de stock"                                    ;
      PROMPT  "&Consulta Stock"

   DEFINE BUTTON oBtn3 OF oBar resource "presupu"                          ;
      ACTION  facturas() GROUP TOP                                         ;
      TOOLTIP "Facturar"                                                   ;
      PROMPT  "Facturar"

   DEFINE BUTTON oBtn4 OF oBar PROMPT  "&Cambiar fondo" resource "app"     ;
      ACTION selcolorfondo() GROUP TOP                                     ;
      tooltip oemtoansi( "Cambiar color de fondo" )

   DEFINE BUTTON oBtn5 OF oBar PROMPT  "&Cambiar Empresa" resource "setup" ;
      ACTION selempre() GROUP TOP  ;
      tooltip oemtoansi( "Cambiar Empresa vigente" )

   DEFINE BUTTON oBtn6 OF oBar PROMPT "Color" resource "colors" GROUP TOP  ;
      ACTION ( nBarClr := ChooseColor( RGB( 0, 0x2E, 0x5C ) ), oBar:Refresh() )

   MENU oPopup POPUP 2007

  MENUITEM "&IVA Ventas" ACTION librovta()       ;
     MESSAGE "IVA Ventas"

  MENUITEM "&Ventas anuales" ACTION  vtastot()   ;
     MESSAGE "Ventas mensuales"

  MENUITEM "&Comprobantes en la AFIP "           ;
     ACTION CompAFIP()                           ;
     MESSAGE "Consulta de comprobantes emitidos"

  MENUITEM "&Comprobantes en la AFIP por fecha " ;
     ACTION CompAFIPFec()                        ;
     MESSAGE "Consulta de comprobantes emitidos"

  MENUITEM "&Archivos SQL"  ACTION ABMSQLAll()   ;
     MESSAGE oemtoansi( "Editar archivos" )

  MENUITEM "&Traductor"  ACTION traductor()      ;
     MESSAGE oemtoansi( "Editar archivos" )

  MENUITEM "&e-mail"  ACTION ConfEmail()         ;
     MESSAGE oemtoansi( "Configurar e-mail" )

   ENDMENU

   DEFINE BUTTON oBtn OF oBar ACTION oBtn:ShowPopup() ;
      RESOURCE "print" PROMPT "Listados" GROUP TOP    ;
      MENU oPopup TOOLTIP "Listados"

   DEFINE BUTTON oSalida OF oBar resource "QUIT"      ;
      ACTION oWnd:End() GROUP TOP                     ;
      MESSAGE "Finalizar El Programa"                 ;
      TOOLTIP "Salida" PROMPT "Salir"

RETURN NIL

FUNCTION librovta()

  ? [GOOD1]

RETURN NIL

FUNCTION vtastot()

  ? [GOOD2]

RETURN NIL

FUNCTION clients()

  ? [GOOD3]

RETURN NIL

FUNCTION val_stk2()

  ? [GOOD4]

RETURN NIL

FUNCTION facturas()

  ? [GOOD5]

RETURN NIL

FUNCTION selcolorfondo()

  ? [GOOD6]

RETURN NIL

FUNCTION selempre()

  ? [GOOD7]

RETURN NIL

FUNCTION CompAFIP()

  ? [GOOD8]

RETURN NIL

FUNCTION CompAFIPFec()

  ? [GOOD9]

RETURN NIL

FUNCTION ABMSQLAll()

  ? [GOOD10]

RETURN NIL

FUNCTION traductor()

  ? [GOOD11]

RETURN NIL

FUNCTION ConfEmail()

  ? [EMAIL]

RETURN NIL

FUNCTION APERTURA()

RETURN NIL

FUNCTION BuildMenu()

   LOCAL oMenu

   GetnWidthItem( 0.8 ) // Ajusta con un valor < 1, y comprueba 0.8

   MENU oMenu FONT oFont 2013 ADJUST NOBORDER              ;
      COLORMENU CLR_DARK_BACK, CLR_DARK_TEXT               ;
      COLORLEFT CLR_DARK_BACK, CLR_DARK_BACK               ;
      COLORRIGHT CLR_DARK_TEXT, CLR_DARK_BACK              ;
      COLORSELECT CLR_DARK_SEL, CLR_DARK_SEL, CLR_WHITE    ;
      COLORSEPARATOR RGB( 80, 80, 80 )                     ;
      COLORBOX CLR_DARK_BACK                               ;
      ROUND 5                                              ;
      HEIGHT 1.0 * 2

   MENUITEM " &Information "
   MENU
   MENUITEM " &About... " ;
      ACTION MsgInfo( FWDESCRIPTION ) ;
      FILENAME "..\bitmaps\16x16\info.bmp"
   SEPARATOR
   MENUITEM " &End... "  ;
      ACTION oWnd:End() FILENAME "..\bitmaps\16x16\exit.bmp"

   ENDMENU

   MENUITEM " &Clients "
   MENU
   MENUITEM "&New..." ;
      ACTION ( MsgStop( "New Clients" ), ;
      oWnd:Say( 5, 5, "New Clients...", "GR+/G" ) ) ;
      FILENAME "..\bitmaps\16x16\faces.bmp"

   MENUITEM "&Modify..."  ACTION MsgInfo( "Modif. Clients" ) ;
      FILENAME "..\bitmaps\edit.bmp"

   MENUITEM "&Delete..."  ACTION MsgAlert( "Del Clients" ) ;
      FILENAME "..\bitmaps\16x16\delete.bmp"

   SEPARATOR

   MENUITEM " &Browse... "  ACTION MsgInfo( "Browse Clients" ) ;
      FILENAME "..\bitmaps\16x16\browse.bmp"

   ENDMENU

   MENUITEM " &Utilities "
   MENU
   MENUITEM "&Calculator..." ACTION WinExec( "Calc" ) ;
      FILENAME "..\bitmaps\16x16\calc.bmp"

   MENUITEM "&Internet..." ;
      ACTION WinExec( "start iexplore www.fivetech.com", 0 ) ;
      FILENAME "..\bitmaps\16x16\explorer.bmp"
   ENDMENU

   ENDMENU

RETURN( oMenu )

// FIN / END - kapiabafwh@gmail.com

Code: Select all | Expand

// C:\FWH2603\SAMPLES\JPJORGE1.PRG - Version: 1.2

#include "FiveWin.ch"

#define CLR_DARK_TEXT         nRGB( 220, 220, 220 )
#define CLR_DARK_BACK         nRGB( 030, 030, 030 )
#define CLR_DARK_BACK2        nRGB( 050, 050, 050 )
#define CLR_DARK_SEL          nRGB( 0x33, 0x33, 0x99 )
#define CLR_DARK_ORANGE       nRGB( 139, 064, 000 )

#Define aPubGrad {| lInvert | If( lInvert, ;
                 { { 1 / 3, nRGB( 255, 253, 222 ), nRGB( 255, 231, 151 ) }, ;
                 { 2 / 3, nRGB( 255, 215,  84 ), nRGB( 255, 233, 162 ) }    ;
                 },                                                         ;
                 { { 1 / 2, nRGB( 219, 230, 244 ), nRGB( 207 - 50, 221 - 25, 255 ) }, ;
                 { 1 / 2, nRGB( 201 - 50, 217 - 25, 255 ), nRGB( 231, 242, 255 ) }    ;
                 } ) }

EXTERNAL HB_LANG_PT, HB_CODEPAGE_PTISO, HB_CODEPAGE_PT850

#ifNdef __XHARBOUR__  // Somente para HARBOUR, XHARBOUR nao tem isso ainda.
   REQUEST HB_CODEPAGE_UTF8
   REQUEST HB_CODEPAGE_UTF8EX
#endif

EXTERNAL OrdKeyNo, OrdKeyCount, OrdCreate, OrdKeyGoto
EXTERNAL _DBF, DBFCDX, DBFFPT, DBFDBT
ANNOUNCE RDDSYS // ANNOUNCE FPTCDX

STATIC oWnd, oFont, nHFont, cFont, nWFont, oBar, JorFon, oFnt
STATIC nTamano // := 64 // SIZE
STATIC nAlturA // := 70
STATIC wnWidth, nSize

MEMVAR nResHoriz // aqui
MEMVAR nResVert

FUNCTION Main()

   LOCAL oIco, oBmp, oBar, XEMPRESA, xOFICINA
   LOCAL cTitle

   PRIVATE nResHoriz // aqui
   PRIVATE nResVert

   HB_GCALL( .F. )

   //   https://vivaclipper.wordpress.com/2014/01/16/hb_cdpselect/
   HB_LANGSELECT( 'PT' )     // Default language is now Portuguese
   HB_SETCODEPAGE( "PT850" )
   HB_CDPSELECT( "PTISO" )   // Para DBFCDX

   RDDSETDEFAULT("DBFCDX")
   RDDREGISTER( "DBFCDX", 1 ) // RDT_FULL -> 20/10/2022 Joao

   SET CENTURY ON
   SET DATE BRITISH
   SET TIME FORMAT TO "HH:MM:SS"
   SET EPOCH TO YEAR( DATE() ) - 30
   SET SOFTSEEK OFF
   SET WRAP ON
   SETCANCEL( .F. )
   SET CONFIRM OFF
   SET DELETED ON
   SET _3DLOOK ON
   SET UNIQUE OFF
   SET ESCAPE OFF
   SET EXACT ON       // CONTROLA O :=, = e ==
   SET EXCLUSIVE OFF
   SET MULTIPLE OFF
   SET OPTIMIZE ON    // OTIMIZA FILTROS NO BANCO DE DADOS
   SET BELL OFF

   FW_SetUnicode( .T. )

   xEMPRESA := [FIVETECH SOFTWARE ENTERPRISE]
   cTitle   :=  Oemtoansi( " Facturaci¢n V 13.13" )
   xOficina := "OFICINA BINARIA THE BIN LADEN CO. LTD."

   cFont  := "Verdana"
   nHFont := 18 // 14

   SetBalloon( .T. ) // Balloon shape required for tooltips

   MsgRun( "AGUARDE... ABRINDO OS BANCOS DE DATOS.   ",                      ;
      "Por Favor, Espere Apertura. Pode Demorar.",                      ;
      { || WinExec( APERTURA() ), 3 } )

   DEFINE ICON oIco FILE "..\..\icons\fax.ico"
   DEFINE FONT oFont NAME cFont SIZE 0, - nHFont
   DEFINE FONT oFnt  NAME 'TAHOMA' SIZE 0, - 12 BOLD
   DEFINE FONT JorFon NAME "Times New Roman" bold SIZE 25, 50

   DEFINE WINDOW oWnd FROM 3, 3 TO 25, 75 TITLE cTitle ICON oIco             ;
      MENU BuildMenu()

   // SET MESSAGE OF oWnd TO FWAUTOR centered
  SET MESSAGE OF oWnd TO STR(YEAR(DATE())) + " © João Santos: (11) 9.5150-7341 - kapiabafwh@gmail.com " ;
      FONT oFont NOINSET CLOCK DATE KEYBOARD COLOR METRO_COBALT, CLR_WHITE 2007 CENTERED

   @ 5, 16 BITMAP oBmp FILENAME "logo.jpg" NOBORDER // .jpg es menor.

   @ 6, 18 SAY SPACE(02) + xEMPRESA + SPACE(45) FONT JorFon ;
      COLOR CLR_GRAY, CLR_WHITE TRANSPARENT CENTER

   // Defecto en el FWH2603, una lástima. // aqui
   WITH OBJECT oWnd
      :bInit := {|| oWnd:Show(), oWnd:Center(), oWnd:Maximize(), DEFINEBAr(), oBmp:Center() }
   END

   nResHoriz := oWnd:nHorzRes() // aqui
   nResVert  := oWnd:nVertRes() // aqui

   @ 37, 02 SAY SPACE(02) + xOFICINA + SPACE(45) FONT JorFon ;
      COLOR CLR_GRAY, CLR_WHITE TRANSPARENT CENTER

   ACTIVATE WINDOW oWnd MAXIMIZED

   oFont:End()
   JorFon:End()
   oFnt:End()

RETURN NIL

FUNCTION DefineBar( )

   LOCAL nBarClr, oBtn, oPopup, oSalida
   LOCAL oBtn1, oBtn2, oBtn3, oBtn4, oBtn5, oBtn6

   nSize     := INT( nResHoriz ) / 20.00 // 64
   nTamano   := INT( nResHoriz ) / 20.00 // 64
   nAltura   := INT( nResVert  ) / 10.97 // 70

   // nTamano := 64 // SIZE
   // nAltura := 70
   DEFINE BUTTONBAR oBar OF oWnd SIZE nTamano, nAltura 2007  // FUNCIONA
   // O:
   // DEFINE BUTTONBAR oBar OF oWnd SIZE nSize, nAltura 2007 // FUNCIONA

   WITH OBJECT oBar

  oBar:bClrGrad := aPubGrad

  oBar:lVisible := .T.
  oBar:SetFont( oFnt  )
  oBar:nClrText := CLR_DARK_ORANGE
  oBar:Adjust()

   END

   /*
   DEFINE BUTTON oBtn1 OF oBar resource "users"                            ;
      ACTION  clients() GROUP TOP                                          ;
      TOOLTIP "Clientes" PROMPT "Clientes"
   */
   DEFINE BUTTON OF oBar FILENAME "..\bitmaps\32x32\Fivetech.bmp"          ;
      ACTION  clients() GROUP TOP                                          ;
      TOOLTIP "Clientes" PROMPT "Clientes"

   DEFINE BUTTON oBtn2 OF oBar resource "setup"                            ;
      ACTION  val_stk2() GROUP TOP                                         ;
      TOOLTIP "Consulta ficha de stock"                                    ;
      PROMPT  "&Consulta Stock"

   DEFINE BUTTON oBtn3 OF oBar resource "presupu"                          ;
      ACTION  facturas() GROUP TOP                                         ;
      TOOLTIP "Facturar"                                                   ;
      PROMPT  "Facturar"

   DEFINE BUTTON oBtn4 OF oBar PROMPT  "&Cambiar fondo" resource "app"     ;
      ACTION selcolorfondo() GROUP TOP                                     ;
      tooltip oemtoansi( "Cambiar color de fondo" )

   DEFINE BUTTON oBtn5 OF oBar PROMPT  "&Cambiar Empresa" resource "setup" ;
      ACTION selempre() GROUP TOP  ;
      tooltip oemtoansi( "Cambiar Empresa vigente" )

   DEFINE BUTTON oBtn6 OF oBar PROMPT "Color" resource "colors" GROUP TOP  ;
      ACTION ( nBarClr := ChooseColor( RGB( 0, 0x2E, 0x5C ) ), oBar:Refresh() )

   MENU oPopup POPUP FONT oFont 2013 ADJUST NOBORDER       ;
      COLORMENU CLR_DARK_BACK, CLR_DARK_TEXT               ;
      COLORLEFT CLR_DARK_BACK, CLR_DARK_BACK               ;
      COLORRIGHT CLR_DARK_TEXT, CLR_DARK_BACK              ;
      COLORSELECT CLR_DARK_SEL, CLR_DARK_SEL, CLR_WHITE    ;
      COLORSEPARATOR RGB( 80, 80, 80 )                     ;
      COLORBOX CLR_DARK_BACK                               ;
      ROUND 5                                              ;
      HEIGHT 1.0 * 2

  SEPARATOR
  MENUITEM "&IVA Ventas" ACTION librovta()       ;
     MESSAGE "IVA Ventas"

  SEPARATOR
  MENUITEM "&Ventas anuales" ACTION  vtastot()   ;
     MESSAGE "Ventas mensuales"

  SEPARATOR
  MENUITEM "&Comprobantes en la AFIP "           ;
     ACTION CompAFIP()                           ;
     MESSAGE "Consulta de comprobantes emitidos"

  SEPARATOR
  MENUITEM "&Comprobantes en la AFIP por fecha " ;
     ACTION CompAFIPFec()                        ;
     MESSAGE "Consulta de comprobantes emitidos"

  SEPARATOR
  MENUITEM "&Archivos SQL"  ACTION ABMSQLAll()   ;
     MESSAGE oemtoansi( "Editar archivos" )

  SEPARATOR
  MENUITEM "&Traductor"  ACTION traductor()      ;
     MESSAGE oemtoansi( "Editar archivos" )

  SEPARATOR
  MENUITEM "&e-mail"  ACTION ConfEmail()         ;
     MESSAGE oemtoansi( "Configurar e-mail" )

   ENDMENU

   DEFINE BUTTON oBtn OF oBar ACTION oBtn:ShowPopup() ;
      RESOURCE "print" PROMPT "Listados" GROUP TOP    ;
      MENU oPopup TOOLTIP "Listados"

   DEFINE BUTTON oSalida OF oBar resource "QUIT"      ;
      ACTION oWnd:End() GROUP TOP                     ;
      MESSAGE "Finalizar El Programa"                 ;
      TOOLTIP "Salida" PROMPT "Salir"

RETURN NIL

FUNCTION clients()

   LOCAL oDlg
   LOCAL oGet1, oGet2, oGet3, oGet4
   LOCAL cVar1, cVar2, cVar3, cVar4
   LOCAL lActive := .F.
   

   cVar1 := 0
   cVar2 := 0
   cVar3 := 0
   cVar4 := 0
   

   DEFINE DIALOG oDlg TITLE "From Code" PIXEL SIZE 300, 300

   @ 10, 10 GET oGet1 var cVar1 PICTURE "@E 99,999.99" of oDlg pixel size 70, 12 ;
      bitmap "..\bitmaps\on.bmp" action( msginfo( "With Transparent" ) )

   @ 40, 10 GET oGet2 var cVar2 bitmap "..\bitmaps\on.bmp" action( msginfo( "Without Transparent" ) ) of oDlg pixel size 60, 12

   @ 70, 10 GET oGet3 var cVar3 bitmap "..\bitmaps\chkyes.bmp" action( msginfo( "With Adjust-Transparent" ) ) of oDlg pixel size 120, 12

   @ 100, 10 GET oGet4 var cVar4 bitmap "..\bitmaps\chkyes.bmp" ;
      action( if( lActive,oGet3:disable(),oGet3:enable() ), lActive := !lActive, oDlg:update() ) of oDlg pixel size 120, 12
   

   oGet3:disable()
   oGet3:lBtnTransparent := .T.       // transparent button get oGet3
   oGet3:lAdjustBtn      := .T.       // Button Get Adjust Witdh oGet3
   oGet3:lDisColors      := .F.       // Deactive disable color
   oGet3:nClrTextDis     := CLR_WHITE // Color text disable status
   oGet3:nClrPaneDis     := CLR_BLUE  // Color Pane disable status
   

   oGet4:lAdjustBtn      := .T.
   

   ACTIVATE DIALOG oDlg CENTERED

RETURN NIL

FUNCTION librovta()

  ? [GOOD1]

RETURN NIL

FUNCTION vtastot()

  ? [GOOD2]

RETURN NIL

FUNCTION val_stk2()

  ? [GOOD4]

RETURN NIL

FUNCTION facturas()

  ? [GOOD5]

RETURN NIL

FUNCTION selcolorfondo()

  ? [GOOD6]

RETURN NIL

FUNCTION selempre()

  ? [GOOD7]

RETURN NIL

FUNCTION CompAFIP()

  ? [GOOD8]

RETURN NIL

FUNCTION CompAFIPFec()

  ? [GOOD9]

RETURN NIL

FUNCTION ABMSQLAll()

  ? [GOOD10]

RETURN NIL

FUNCTION traductor()

  ? [GOOD11]

RETURN NIL

FUNCTION ConfEmail()

  ? [EMAIL]

RETURN NIL

FUNCTION APERTURA()

RETURN NIL

FUNCTION BuildMenu()

   LOCAL oMenu

//   GetnWidthItem( 0.8 ) // Ajusta con un valor < 1, y comprueba 0.8

   IF Type( "SetMenuItemWidth" ) == "UI"
      // SetMenuItemWidth( 0.8 )
      GetnWidthItem( 0.8 ) // Ajusta con un valor < 1, y comprueba 0.8
   ENDIF

   MENU oMenu FONT oFont 2013 ADJUST NOBORDER              ;
      COLORMENU CLR_DARK_BACK, CLR_DARK_TEXT               ;
      COLORLEFT CLR_DARK_BACK, CLR_DARK_BACK               ;
      COLORRIGHT CLR_DARK_TEXT, CLR_DARK_BACK              ;
      COLORSELECT CLR_DARK_SEL, CLR_DARK_SEL, CLR_WHITE    ;
      COLORSEPARATOR RGB( 80, 80, 80 )                     ;
      COLORBOX CLR_DARK_BACK                               ;
      ROUND 5                                              ;
      HEIGHT 1.0 * 2

   /*
   MENU oMenu FONT oFont ADJUST NOBORDER ;
      COLORMENU CLR_DARK_BACK, CLR_DARK_TEXT ;
      COLORLEFT CLR_DARK_BACK, CLR_DARK_BACK ;
      COLORRIGHT CLR_DARK_TEXT, CLR_DARK_BACK ;
      COLORSELECT CLR_DARK_SEL, CLR_DARK_SEL, CLR_WHITE ;
      COLORSEPARATOR RGB( 80, 80, 80 ) ;
      COLORBOX CLR_DARK_BACK ;
      ROUND 5 ;
      HEIGHT 32
   */

   MENUITEM " &Information "
   MENU
   MENUITEM " &About... " ;
      ACTION MsgInfo( FWDESCRIPTION ) ;
      FILENAME "..\bitmaps\16x16\info.bmp"
   SEPARATOR
   MENUITEM " &End... "  ;
      ACTION oWnd:End() FILENAME "..\bitmaps\16x16\exit.bmp"

   ENDMENU

   MENUITEM " &Clients "
   MENU
   MENUITEM "&New..." ;
      ACTION ( MsgStop( "New Clients" ), ;
      oWnd:Say( 5, 5, "New Clients...", "GR+/G" ) ) ;
      FILENAME "..\bitmaps\16x16\faces.bmp"

   MENUITEM "&Modify..."  ACTION MsgInfo( "Modif. Clients" ) ;
      FILENAME "..\bitmaps\edit.bmp"

   MENUITEM "&Delete..."  ACTION MsgAlert( "Del Clients" ) ;
      FILENAME "..\bitmaps\16x16\delete.bmp"

   SEPARATOR

   MENUITEM " &Browse... "  ACTION MsgInfo( "Browse Clients" ) ;
      FILENAME "..\bitmaps\16x16\browse.bmp"

   ENDMENU

   MENUITEM " &Utilities "
   MENU
   MENUITEM "&Calculator..." ACTION WinExec( "Calc" ) ;
      FILENAME "..\bitmaps\16x16\calc.bmp"

   MENUITEM "&Internet..." ;
      ACTION WinExec( "start iexplore www.fivetech.com", 0 ) ;
      FILENAME "..\bitmaps\16x16\explorer.bmp"
   ENDMENU

   ENDMENU

RETURN( oMenu )

// FIN / END - kapiabafwh@gmail.com

Code: Select all | Expand

// C:\FWH2603\SAMPLES\JPJORGE1.PRG - Version: 1.2

#include "FiveWin.ch"

#define CLR_DARK_TEXT         nRGB( 220, 220, 220 )
#define CLR_DARK_BACK         nRGB( 030, 030, 030 )
#define CLR_DARK_BACK2        nRGB( 050, 050, 050 )
#define CLR_DARK_SEL          nRGB( 0x33, 0x33, 0x99 )
#define CLR_DARK_ORANGE       nRGB( 139, 064, 000 )

#Define aPubGrad {| lInvert | If( lInvert, ;
                 { { 1 / 3, nRGB( 255, 253, 222 ), nRGB( 255, 231, 151 ) }, ;
                 { 2 / 3, nRGB( 255, 215,  84 ), nRGB( 255, 233, 162 ) }    ;
                 },                                                         ;
                 { { 1 / 2, nRGB( 219, 230, 244 ), nRGB( 207 - 50, 221 - 25, 255 ) }, ;
                 { 1 / 2, nRGB( 201 - 50, 217 - 25, 255 ), nRGB( 231, 242, 255 ) }    ;
                 } ) }

EXTERNAL HB_LANG_PT, HB_CODEPAGE_PTISO, HB_CODEPAGE_PT850

#ifNdef __XHARBOUR__  // Somente para HARBOUR, XHARBOUR nao tem isso ainda.
   REQUEST HB_CODEPAGE_UTF8
   REQUEST HB_CODEPAGE_UTF8EX
#endif

EXTERNAL OrdKeyNo, OrdKeyCount, OrdCreate, OrdKeyGoto
EXTERNAL _DBF, DBFCDX, DBFFPT, DBFDBT
ANNOUNCE RDDSYS // ANNOUNCE FPTCDX

STATIC oWnd, oFont, nHFont, cFont, nWFont, oBar, JorFon, oFnt
STATIC nTamano // := 64 // SIZE
STATIC nAlturA // := 70
STATIC wnWidth, nSize

MEMVAR nResHoriz // aqui
MEMVAR nResVert

FUNCTION Main()

   LOCAL oIco, oBmp, oBar, XEMPRESA, xOFICINA
   LOCAL cTitle

   PRIVATE nResHoriz // aqui
   PRIVATE nResVert

   HB_GCALL( .F. )

   //   https://vivaclipper.wordpress.com/2014/01/16/hb_cdpselect/
   HB_LANGSELECT( 'PT' )     // Default language is now Portuguese
   HB_SETCODEPAGE( "PT850" )
   HB_CDPSELECT( "PTISO" )   // Para DBFCDX

   RDDSETDEFAULT("DBFCDX")
   RDDREGISTER( "DBFCDX", 1 ) // RDT_FULL -> 20/10/2022 Joao

   SET CENTURY ON
   SET DATE BRITISH
   SET TIME FORMAT TO "HH:MM:SS"
   SET EPOCH TO YEAR( DATE() ) - 30
   SET SOFTSEEK OFF
   SET WRAP ON
   SETCANCEL( .F. )
   SET CONFIRM OFF
   SET DELETED ON
   SET _3DLOOK ON
   SET UNIQUE OFF
   SET ESCAPE OFF
   SET EXACT ON       // CONTROLA O :=, = e ==
   SET EXCLUSIVE OFF
   SET MULTIPLE OFF
   SET OPTIMIZE ON    // OTIMIZA FILTROS NO BANCO DE DADOS
   SET BELL OFF

   FW_SetUnicode( .T. )

   xEMPRESA := [FIVETECH SOFTWARE ENTERPRISE]
   cTitle   :=  Oemtoansi( " Facturaci¢n V 13.13" )
   xOficina := "OFICINA BINARIA THE BIN LADEN CO. LTD."

   cFont  := "Verdana"
   nHFont := 18 // 14

   SetBalloon( .T. ) // Balloon shape required for tooltips

   MsgRun( "AGUARDE... ABRINDO OS BANCOS DE DATOS.   ",                      ;
      "Por Favor, Espere Apertura. Pode Demorar.",                      ;
      { || WinExec( APERTURA() ), 3 } )

   DEFINE ICON oIco FILE "..\..\icons\fax.ico"
   DEFINE FONT oFont NAME cFont SIZE 0, - nHFont
   DEFINE FONT oFnt  NAME 'TAHOMA' SIZE 0, - 12 BOLD
   DEFINE FONT JorFon NAME "Times New Roman" bold SIZE 25, 50

   DEFINE WINDOW oWnd FROM 3, 3 TO 25, 75 TITLE cTitle ICON oIco             ;
      MENU BuildMenu()

   // SET MESSAGE OF oWnd TO FWAUTOR centered
  SET MESSAGE OF oWnd TO STR(YEAR(DATE())) + " © João Santos: (11) 9.5150-7341 - kapiabafwh@gmail.com " ;
      FONT oFont NOINSET CLOCK DATE KEYBOARD COLOR METRO_COBALT, CLR_WHITE 2007 CENTERED

   @ 5, 16 BITMAP oBmp FILENAME "logo.jpg" NOBORDER // .jpg es menor.

   @ 6, 18 SAY SPACE(02) + xEMPRESA + SPACE(45) FONT JorFon ;
      COLOR CLR_GRAY, CLR_WHITE TRANSPARENT CENTER


   nResHoriz := oWnd:nHorzRes() // aqui
   nResVert  := oWnd:nVertRes() // aqui

   @ 37, 02 SAY SPACE(02) + xOFICINA + SPACE(45) FONT JorFon ;
      COLOR CLR_GRAY, CLR_WHITE TRANSPARENT CENTER

   ACTIVATE WINDOW oWnd  on resize DefineBar(oWnd:nWidth )

   oFont:End()
   JorFon:End()
   oFnt:End()

RETURN NIL

FUNCTION DefineBar(wnWidth )

   LOCAL nBarClr, oBtn, oPopup, oSalida
   LOCAL oBtn1, oBtn2, oBtn3, oBtn4, oBtn5, oBtn6

   nSize     := INT( nResHoriz ) / 20.00 
   nTamano   :=  wnWidth / 10 
   nAltura   := INT( oWnd:nHeight   ) / 10.97 

   DEFINE BUTTONBAR oBar OF oWnd SIZE nTamano, nAltura 2007  // FUNCIONA

   WITH OBJECT oBar

  oBar:bClrGrad := aPubGrad

  oBar:lVisible := .T.
  oBar:SetFont( oFnt  )
  oBar:nClrText := CLR_DARK_ORANGE
  oBar:Adjust()

   END

   /*
   DEFINE BUTTON oBtn1 OF oBar resource "users"                            ;
      ACTION  clients() GROUP TOP                                          ;
      TOOLTIP "Clientes" PROMPT "Clientes"
   */
   DEFINE BUTTON OF oBar FILENAME "..\bitmaps\32x32\Fivetech.bmp"          ;
      ACTION  clients() GROUP TOP                                          ;
      TOOLTIP "Clientes" PROMPT "Clientes"

   DEFINE BUTTON oBtn2 OF oBar resource "setup"                            ;
      ACTION  val_stk2() GROUP TOP                                         ;
      TOOLTIP "Consulta ficha de stock"                                    ;
      PROMPT  "&Consulta Stock"

   DEFINE BUTTON oBtn3 OF oBar resource "presupu"                          ;
      ACTION  facturas() GROUP TOP                                         ;
      TOOLTIP "Facturar"                                                   ;
      PROMPT  "Facturar"

   DEFINE BUTTON oBtn4 OF oBar PROMPT  "&Cambiar fondo" resource "app"     ;
      ACTION selcolorfondo() GROUP TOP                                     ;
      tooltip oemtoansi( "Cambiar color de fondo" )

   DEFINE BUTTON oBtn5 OF oBar PROMPT  "&Cambiar Empresa" resource "setup" ;
      ACTION selempre() GROUP TOP  ;
      tooltip oemtoansi( "Cambiar Empresa vigente" )

   DEFINE BUTTON oBtn6 OF oBar PROMPT "Color" resource "colors" GROUP TOP  ;
      ACTION ( nBarClr := ChooseColor( RGB( 0, 0x2E, 0x5C ) ), oBar:Refresh() )

   MENU oPopup POPUP FONT oFont 2013 ADJUST NOBORDER       ;
      COLORMENU CLR_DARK_BACK, CLR_DARK_TEXT               ;
      COLORLEFT CLR_DARK_BACK, CLR_DARK_BACK               ;
      COLORRIGHT CLR_DARK_TEXT, CLR_DARK_BACK              ;
      COLORSELECT CLR_DARK_SEL, CLR_DARK_SEL, CLR_WHITE    ;
      COLORSEPARATOR RGB( 80, 80, 80 )                     ;
      COLORBOX CLR_DARK_BACK                               ;
      ROUND 5                                              ;
      HEIGHT 1.0 * 2

  SEPARATOR
  MENUITEM "&IVA Ventas" ACTION librovta()       ;
     MESSAGE "IVA Ventas"

  SEPARATOR
  MENUITEM "&Ventas anuales" ACTION  vtastot()   ;
     MESSAGE "Ventas mensuales"

  SEPARATOR
  MENUITEM "&Comprobantes en la AFIP "           ;
     ACTION CompAFIP()                           ;
     MESSAGE "Consulta de comprobantes emitidos"

  SEPARATOR
  MENUITEM "&Comprobantes en la AFIP por fecha " ;
     ACTION CompAFIPFec()                        ;
     MESSAGE "Consulta de comprobantes emitidos"

  SEPARATOR
  MENUITEM "&Archivos SQL"  ACTION ABMSQLAll()   ;
     MESSAGE oemtoansi( "Editar archivos" )

  SEPARATOR
  MENUITEM "&Traductor"  ACTION traductor()      ;
     MESSAGE oemtoansi( "Editar archivos" )

  SEPARATOR
  MENUITEM "&e-mail"  ACTION ConfEmail()         ;
     MESSAGE oemtoansi( "Configurar e-mail" )

   ENDMENU

   DEFINE BUTTON oBtn OF oBar ACTION oBtn:ShowPopup() ;
      RESOURCE "print" PROMPT "Listados" GROUP TOP    ;
      MENU oPopup TOOLTIP "Listados"

   DEFINE BUTTON oSalida OF oBar resource "QUIT"      ;
      ACTION oWnd:End() GROUP TOP                     ;
      MESSAGE "Finalizar El Programa"                 ;
      TOOLTIP "Salida" PROMPT "Salir"

RETURN NIL

FUNCTION clients()

   LOCAL oDlg
   LOCAL oGet1, oGet2, oGet3, oGet4
   LOCAL cVar1, cVar2, cVar3, cVar4
   LOCAL lActive := .F.
   

   cVar1 := 0
   cVar2 := 0
   cVar3 := 0
   cVar4 := 0
   

   DEFINE DIALOG oDlg TITLE "From Code" PIXEL SIZE 300, 300

   @ 10, 10 GET oGet1 var cVar1 PICTURE "@E 99,999.99" of oDlg pixel size 70, 12 ;
      bitmap "..\bitmaps\on.bmp" action( msginfo( "With Transparent" ) )

   @ 40, 10 GET oGet2 var cVar2 bitmap "..\bitmaps\on.bmp" action( msginfo( "Without Transparent" ) ) of oDlg pixel size 60, 12

   @ 70, 10 GET oGet3 var cVar3 bitmap "..\bitmaps\chkyes.bmp" action( msginfo( "With Adjust-Transparent" ) ) of oDlg pixel size 120, 12

   @ 100, 10 GET oGet4 var cVar4 bitmap "..\bitmaps\chkyes.bmp" ;
      action( if( lActive,oGet3:disable(),oGet3:enable() ), lActive := !lActive, oDlg:update() ) of oDlg pixel size 120, 12
   

   oGet3:disable()
   oGet3:lBtnTransparent := .T.       // transparent button get oGet3
   oGet3:lAdjustBtn      := .T.       // Button Get Adjust Witdh oGet3
   oGet3:lDisColors      := .F.       // Deactive disable color
   oGet3:nClrTextDis     := CLR_WHITE // Color text disable status
   oGet3:nClrPaneDis     := CLR_BLUE  // Color Pane disable status
   

   oGet4:lAdjustBtn      := .T.
   

   ACTIVATE DIALOG oDlg CENTERED

RETURN NIL

FUNCTION librovta()

  ? [GOOD1]

RETURN NIL

FUNCTION vtastot()

  ? [GOOD2]

RETURN NIL

FUNCTION val_stk2()

  ? [GOOD4]

RETURN NIL

FUNCTION facturas()

  ? [GOOD5]

RETURN NIL

FUNCTION selcolorfondo()

  ? [GOOD6]

RETURN NIL

FUNCTION selempre()

  ? [GOOD7]

RETURN NIL

FUNCTION CompAFIP()

  ? [GOOD8]

RETURN NIL

FUNCTION CompAFIPFec()

  ? [GOOD9]

RETURN NIL

FUNCTION ABMSQLAll()

  ? [GOOD10]

RETURN NIL

FUNCTION traductor()

  ? [GOOD11]

RETURN NIL

FUNCTION ConfEmail()

  ? [EMAIL]

RETURN NIL

FUNCTION APERTURA()

RETURN NIL

FUNCTION BuildMenu()

   LOCAL oMenu

//   GetnWidthItem( 0.8 ) // Ajusta con un valor < 1, y comprueba 0.8

   IF Type( "SetMenuItemWidth" ) == "UI"
      // SetMenuItemWidth( 0.8 )
      GetnWidthItem( 0.8 ) // Ajusta con un valor < 1, y comprueba 0.8
   ENDIF

   MENU oMenu FONT oFont 2013 ADJUST NOBORDER              ;
      COLORMENU CLR_DARK_BACK, CLR_DARK_TEXT               ;
      COLORLEFT CLR_DARK_BACK, CLR_DARK_BACK               ;
      COLORRIGHT CLR_DARK_TEXT, CLR_DARK_BACK              ;
      COLORSELECT CLR_DARK_SEL, CLR_DARK_SEL, CLR_WHITE    ;
      COLORSEPARATOR RGB( 80, 80, 80 )                     ;
      COLORBOX CLR_DARK_BACK                               ;
      ROUND 5                                              ;
      HEIGHT 1.0 * 2

   /*
   MENU oMenu FONT oFont ADJUST NOBORDER ;
      COLORMENU CLR_DARK_BACK, CLR_DARK_TEXT ;
      COLORLEFT CLR_DARK_BACK, CLR_DARK_BACK ;
      COLORRIGHT CLR_DARK_TEXT, CLR_DARK_BACK ;
      COLORSELECT CLR_DARK_SEL, CLR_DARK_SEL, CLR_WHITE ;
      COLORSEPARATOR RGB( 80, 80, 80 ) ;
      COLORBOX CLR_DARK_BACK ;
      ROUND 5 ;
      HEIGHT 32
   */

   MENUITEM " &Information "
   MENU
   MENUITEM " &About... " ;
      ACTION MsgInfo( FWDESCRIPTION ) ;
      FILENAME "..\bitmaps\16x16\info.bmp"
   SEPARATOR
   MENUITEM " &End... "  ;
      ACTION oWnd:End() FILENAME "..\bitmaps\16x16\exit.bmp"

   ENDMENU

   MENUITEM " &Clients "
   MENU
   MENUITEM "&New..." ;
      ACTION ( MsgStop( "New Clients" ), ;
      oWnd:Say( 5, 5, "New Clients...", "GR+/G" ) ) ;
      FILENAME "..\bitmaps\16x16\faces.bmp"

   MENUITEM "&Modify..."  ACTION MsgInfo( "Modif. Clients" ) ;
      FILENAME "..\bitmaps\edit.bmp"

   MENUITEM "&Delete..."  ACTION MsgAlert( "Del Clients" ) ;
      FILENAME "..\bitmaps\16x16\delete.bmp"

   SEPARATOR

   MENUITEM " &Browse... "  ACTION MsgInfo( "Browse Clients" ) ;
      FILENAME "..\bitmaps\16x16\browse.bmp"

   ENDMENU

   MENUITEM " &Utilities "
   MENU
   MENUITEM "&Calculator..." ACTION WinExec( "Calc" ) ;
      FILENAME "..\bitmaps\16x16\calc.bmp"

   MENUITEM "&Internet..." ;
      ACTION WinExec( "start iexplore www.fivetech.com", 0 ) ;
      FILENAME "..\bitmaps\16x16\explorer.bmp"
   ENDMENU

   ENDMENU

RETURN( oMenu )

// FIN / END - kapiabafwh@gmail.com

Code: Select all | Expand

// C:\FWH2603\SAMPLES\JPJORGE1.PRG - Version: 1.3 - By Kapiaba.

#include "FiveWin.ch"

#define CLR_DARK_TEXT         nRGB( 220, 220, 220 )
#define CLR_DARK_BACK         nRGB( 030, 030, 030 )
#define CLR_DARK_BACK2        nRGB( 050, 050, 050 )
#define CLR_DARK_SEL          nRGB( 0x33, 0x33, 0x99 )
#define CLR_DARK_ORANGE       nRGB( 139, 064, 000 )
#Define CLR_TANGERINE         nRGB( 240, 128, 000 )
#define METRO_TURQUE          nRGB( 000, 128, 128 )

#Define aPubGrad {| lInvert | If( lInvert, ;
                 { { 1 / 3, nRGB( 255, 253, 222 ), nRGB( 255, 231, 151 ) }, ;
                 { 2 / 3, nRGB( 255, 215,  84 ), nRGB( 255, 233, 162 ) }    ;
                 },                                                         ;
                 { { 1 / 2, nRGB( 219, 230, 244 ), nRGB( 207 - 50, 221 - 25, 255 ) }, ;
                 { 1 / 2, nRGB( 201 - 50, 217 - 25, 255 ), nRGB( 231, 242, 255 ) }    ;
                 } ) }

EXTERNAL HB_LANG_PT, HB_CODEPAGE_PTISO, HB_CODEPAGE_PT850

#ifNdef __XHARBOUR__  // Somente para HARBOUR, XHARBOUR nao tem isso ainda.
   REQUEST HB_CODEPAGE_UTF8
   REQUEST HB_CODEPAGE_UTF8EX
#endif

EXTERNAL OrdKeyNo, OrdKeyCount, OrdCreate, OrdKeyGoto
EXTERNAL _DBF, DBFCDX, DBFFPT, DBFDBT
ANNOUNCE RDDSYS // ANNOUNCE FPTCDX

STATIC oWnd, oFont, nHFont, cFont, nWFont, oBar, JorFon, oFnt
STATIC nTamano // := 64 // SIZE aqui
STATIC nAlturA // := 70 //      aqui
STATIC wnWidth, nSize   //      aqui  STATIC o PUBLIC, ok?

MEMVAR nResHoriz // aqui
MEMVAR nResVert

FUNCTION Main()

   LOCAL oIco, oBmp, oBar, XEMPRESA, xOFICINA
   LOCAL cTitle

   PRIVATE nResHoriz // aqui
   PRIVATE nResVert

   HB_GCALL( .F. )

   //   https://vivaclipper.wordpress.com/2014/01/16/hb_cdpselect/
   HB_LANGSELECT( 'PT' )     // Default language is now Portuguese
   HB_SETCODEPAGE( "PT850" ) // CAMBIAR A ESPANOL.
   HB_CDPSELECT( "PTISO" )   // Para DBFCDX

   RDDSETDEFAULT("DBFCDX")
   RDDREGISTER( "DBFCDX", 1 ) // RDT_FULL -> 20/10/2022 Joao

   SET CENTURY ON
   SET DATE BRITISH
   SET TIME FORMAT TO "HH:MM:SS"
   SET EPOCH TO YEAR( DATE() ) - 30
   SET SOFTSEEK OFF
   SET WRAP ON
   SETCANCEL( .F. )
   SET CONFIRM OFF
   SET DELETED ON
   SET _3DLOOK ON
   SET UNIQUE OFF
   SET ESCAPE OFF
   SET EXACT ON
   SET EXCLUSIVE OFF
   SET MULTIPLE OFF
   SET OPTIMIZE ON
   SET BELL OFF

   FW_SetUnicode( .T. )

   xEMPRESA := [FIVETECH SOFTWARE ENTERPRISE]
   cTitle   :=  Oemtoansi( " Facturaci¢n V 13.13" )
   xOficina := "OFICINA BINARIA THE BIN LADEN CO. LTD."

   cFont  := "Verdana"
   nHFont := 18 // 14

   SetBalloon( .T. ) // Balloon shape required for tooltips

   MsgRun( "AGUARDE... ABRINDO OS BANCOS DE DATOS.   ",                      ;
      "Por Favor, Espere Apertura. Pode Demorar.",                      ;
      { || WinExec( APERTURA() ), 3 } )

   DEFINE ICON oIco FILE "..\..\icons\fax.ico"
   DEFINE FONT oFont NAME cFont SIZE 0, - nHFont
   DEFINE FONT oFnt  NAME 'TAHOMA' SIZE 0, - 12 BOLD
   DEFINE FONT JorFon NAME "Times New Roman" bold SIZE 25, 50

   DEFINE WINDOW oWnd FROM 3, 3 TO 25, 75 TITLE cTitle ICON oIco             ;
      MENU BuildMenu()

  // NO FUNCIONA CON FWH19.05 -> SE USO: :bInit MODIFICADO EN: ACTIVATE WINDOW.
  SET MESSAGE OF oWnd TO STR(YEAR(DATE())) + " © João Santos: (11) 9.5150-7341 - kapiabafwh@gmail.com " ;
      FONT oFont NOINSET CLOCK DATE KEYBOARD COLOR METRO_COBALT, CLR_WHITE 2007 CENTERED

   @ 5, 16 BITMAP oBmp FILENAME "logo.jpg" NOBORDER // .jpg es menor.

   @ 6, 18 SAY SPACE(02) + xEMPRESA + SPACE(45) FONT JorFon ;
      COLOR CLR_GRAY, CLR_WHITE TRANSPARENT CENTER

   // Defecto en el FWH2603, una lástima. // aqui - 24/09/2026 - Joao.
   IF FWVERSION >= "FWH 26.03"

  WITH OBJECT oWnd
     :bInit := {|| oWnd:Show(), oWnd:Center(), oWnd:Maximize(), DEFINEBAr(), oBmp:Center() }
  END

   ENDIF

   /*
   nResHoriz := oWnd:nHorzRes() // aqui - Camabiado para otras
   nResVert  := oWnd:nVertRes() // aqui - resoluciones de video.
   */

   @ 37, 02 SAY SPACE(02) + xOFICINA + SPACE(45) FONT JorFon ;
      COLOR CLR_GRAY, CLR_WHITE TRANSPARENT CENTER

   IF FWVERSION >= "FWH 26.03" // FUNCIONA - TERRIBLE DEFECTO VIA IA.

  ACTIVATE WINDOW oWnd MAXIMIZED // USAR bInit(). Habla serio...

   ELSE // FUNCIONA MUI BIEN COMO SIEMPRE HA SIDO.

  ACTIVATE WINDOW oWnd MAXIMIZED ON INIT( DEFINEBAr(), oBmp:Center() )

   ENDIF

   oFont:End()
   JorFon:End()
   oFnt:End()

RETURN NIL

FUNCTION DefineBar( )

   LOCAL nBarClr, oBtn, oPopup, oSalida
   LOCAL oBtn1, oBtn2, oBtn3, oBtn4, oBtn5, oBtn6

   /* // Cambiado en: 24/09/2026 By Kapiaba. Para: SRC_RESOLUTION()
   nSize     := INT( nResHoriz ) / 20.00 // 64
   nTamano   := INT( nResHoriz ) / 20.00 // 64
   nAltura   := INT( nResVert  ) / 10.97 // 70
   */

   SRC_RESOLUTION() // Configuracion de video. 24/09/2026 - Joao.

   // nTamano := 64 // SIZE
   // nAltura := 70
   DEFINE BUTTONBAR oBar OF oWnd SIZE nTamano, nAltura 2007  // FUNCIONA
   // O:
   // DEFINE BUTTONBAR oBar OF oWnd SIZE nSize, nAltura 2007 // FUNCIONA

   WITH OBJECT oBar

  oBar:bClrGrad := aPubGrad

  oBar:lVisible := .T.
  oBar:SetFont( oFnt  )
  oBar:nClrText := CLR_DARK_ORANGE
  oBar:Adjust()

   END

   /* // No realicé pruebas con recursos.
   DEFINE BUTTON oBtn1 OF oBar resource "users"                            ;
      ACTION  clients() GROUP TOP                                          ;
      TOOLTIP "Clientes" PROMPT "Clientes"
   */
   DEFINE BUTTON oBtn1 OF oBar FILENAME "..\bitmaps\32x32\Fivetech.bmp"    ;
      ACTION  clients() GROUP TOP                                          ;
      TOOLTIP "Clientes" PROMPT "Clientes"

   oBtn1:SetColor( CLR_TANGERINE, METRO_TURQUE ) // 24/09/2026 - Joao FUNCIONA.

   oBtn1:lThemed := .T.
   oBtn1:SetThemed( .T. ) // Bien en ambas versiones.

   DEFINE BUTTON oBtn2 OF oBar resource "setup"                            ;
      ACTION  val_stk2() GROUP TOP                                         ;
      TOOLTIP "Consulta ficha de stock"                                    ;
      PROMPT  "&Consulta Stock"

   DEFINE BUTTON oBtn3 OF oBar resource "presupu"                          ;
      ACTION  facturas() GROUP TOP                                         ;
      TOOLTIP "Facturar"                                                   ;
      PROMPT  "Facturar"

   DEFINE BUTTON oBtn4 OF oBar PROMPT  "&Cambiar fondo" resource "app"     ;
      ACTION selcolorfondo() GROUP TOP                                     ;
      tooltip oemtoansi( "Cambiar color de fondo" )

   DEFINE BUTTON oBtn5 OF oBar PROMPT  "&Cambiar Empresa" resource "setup" ;
      ACTION selempre() GROUP TOP  ;
      tooltip oemtoansi( "Cambiar Empresa vigente" )

   DEFINE BUTTON oBtn6 OF oBar PROMPT "Color" resource "colors" GROUP TOP  ;
      ACTION ( nBarClr := ChooseColor( RGB( 0, 0x2E, 0x5C ) ), oBar:Refresh() )

   MENU oPopup POPUP FONT oFont 2013 ADJUST NOBORDER       ;
      COLORMENU CLR_DARK_BACK, CLR_DARK_TEXT               ;
      COLORLEFT CLR_DARK_BACK, CLR_DARK_BACK               ;
      COLORRIGHT CLR_DARK_TEXT, CLR_DARK_BACK              ;
      COLORSELECT CLR_DARK_SEL, CLR_DARK_SEL, CLR_WHITE    ;
      COLORSEPARATOR RGB( 80, 80, 80 )                     ;
      COLORBOX CLR_DARK_BACK                               ;
      ROUND 5                                              ;
      HEIGHT 1.0 * 2

  SEPARATOR
  MENUITEM "&IVA Ventas" ACTION librovta()       ;
     MESSAGE "IVA Ventas"

  SEPARATOR
  MENUITEM "&Ventas anuales" ACTION  vtastot()   ;
     MESSAGE "Ventas mensuales"

  SEPARATOR
  MENUITEM "&Comprobantes en la AFIP "           ;
     ACTION CompAFIP()                           ;
     MESSAGE "Consulta de comprobantes emitidos"

  SEPARATOR
  MENUITEM "&Comprobantes en la AFIP por fecha " ;
     ACTION CompAFIPFec()                        ;
     MESSAGE "Consulta de comprobantes emitidos"

  SEPARATOR
  MENUITEM "&Archivos SQL"  ACTION ABMSQLAll()   ;
     MESSAGE oemtoansi( "Editar archivos" )

  SEPARATOR
  MENUITEM "&Traductor"  ACTION traductor()      ;
     MESSAGE oemtoansi( "Editar archivos" )

  SEPARATOR
  MENUITEM "&e-mail"  ACTION ConfEmail()         ;
     MESSAGE oemtoansi( "Configurar e-mail" )

   ENDMENU

   DEFINE BUTTON oBtn OF oBar ACTION oBtn:ShowPopup() ;
      RESOURCE "print" PROMPT "Listados" GROUP TOP    ;
      MENU oPopup TOOLTIP "Listados"

   DEFINE BUTTON oSalida OF oBar resource "QUIT"      ;
      ACTION oWnd:End() GROUP TOP                     ;
      MESSAGE "Finalizar El Programa"                 ;
      TOOLTIP "Salida" PROMPT "Salir"

RETURN NIL

FUNCTION clients()

   LOCAL oDlg
   LOCAL oGet1, oGet2, oGet3, oGet4
   LOCAL cVar1, cVar2, cVar3, cVar4
   LOCAL lActive := .F.
   

   cVar1 := 0
   cVar2 := 0
   cVar3 := 0
   cVar4 := 0
   

   DEFINE DIALOG oDlg TITLE "From Code" PIXEL SIZE 300, 300

   @ 10, 10 GET oGet1 var cVar1 PICTURE "@E 99,999.99" of oDlg pixel size 70, 12 ;
      bitmap "..\bitmaps\on.bmp" action( msginfo( "With Transparent" ) )

   @ 40, 10 GET oGet2 var cVar2 bitmap "..\bitmaps\on.bmp" action( msginfo( "Without Transparent" ) ) of oDlg pixel size 60, 12

   @ 70, 10 GET oGet3 var cVar3 bitmap "..\bitmaps\chkyes.bmp" action( msginfo( "With Adjust-Transparent" ) ) of oDlg pixel size 120, 12

   @ 100, 10 GET oGet4 var cVar4 bitmap "..\bitmaps\chkyes.bmp" ;
      action( if( lActive,oGet3:disable(),oGet3:enable() ), lActive := !lActive, oDlg:update() ) of oDlg pixel size 120, 12
   

   oGet3:disable()
   oGet3:lBtnTransparent := .T.       // transparent button get oGet3
   oGet3:lAdjustBtn      := .T.       // Button Get Adjust Witdh oGet3
   oGet3:lDisColors      := .F.       // Deactive disable color
   oGet3:nClrTextDis     := CLR_WHITE // Color text disable status
   oGet3:nClrPaneDis     := CLR_BLUE  // Color Pane disable status
   

   oGet4:lAdjustBtn      := .T.
   

   ACTIVATE DIALOG oDlg CENTERED

RETURN NIL

FUNCTION librovta()

  ? [GOOD1]

RETURN NIL

FUNCTION vtastot()

  ? [GOOD2]

RETURN NIL

FUNCTION val_stk2()

  ? [GOOD4]

RETURN NIL

FUNCTION facturas()

  ? [GOOD5]

RETURN NIL

FUNCTION selcolorfondo()

  ? [GOOD6]

RETURN NIL

FUNCTION selempre()

  ? [GOOD7]

RETURN NIL

FUNCTION CompAFIP()

  ? [GOOD8]

RETURN NIL

FUNCTION CompAFIPFec()

  ? [GOOD9]

RETURN NIL

FUNCTION ABMSQLAll()

  ? [GOOD10]

RETURN NIL

FUNCTION traductor()

  ? [GOOD11]

RETURN NIL

FUNCTION ConfEmail()

  ? [EMAIL]

RETURN NIL

FUNCTION APERTURA()

RETURN NIL

FUNCTION BuildMenu()

   LOCAL oMenu

//   GetnWidthItem( 0.8 ) // Ajusta con un valor < 1, y comprueba 0.8

   IF Type( "SetMenuItemWidth" ) == "UI"
      // SetMenuItemWidth( 0.8 )
      GetnWidthItem( 0.8 ) // Ajusta con un valor < 1, y comprueba 0.8
   ENDIF

   MENU oMenu FONT oFont 2013 ADJUST NOBORDER              ;
      COLORMENU CLR_DARK_BACK, CLR_DARK_TEXT               ;
      COLORLEFT CLR_DARK_BACK, CLR_DARK_BACK               ;
      COLORRIGHT CLR_DARK_TEXT, CLR_DARK_BACK              ;
      COLORSELECT CLR_DARK_SEL, CLR_DARK_SEL, CLR_WHITE    ;
      COLORSEPARATOR RGB( 80, 80, 80 )                     ;
      COLORBOX CLR_DARK_BACK                               ;
      ROUND 5                                              ;
      HEIGHT 1.0 * 2

   /*
   MENU oMenu FONT oFont ADJUST NOBORDER ;
      COLORMENU CLR_DARK_BACK, CLR_DARK_TEXT ;
      COLORLEFT CLR_DARK_BACK, CLR_DARK_BACK ;
      COLORRIGHT CLR_DARK_TEXT, CLR_DARK_BACK ;
      COLORSELECT CLR_DARK_SEL, CLR_DARK_SEL, CLR_WHITE ;
      COLORSEPARATOR RGB( 80, 80, 80 ) ;
      COLORBOX CLR_DARK_BACK ;
      ROUND 5 ;
      HEIGHT 32
   */

   MENUITEM " &Information "
   MENU
   MENUITEM " &About... " ;
      ACTION MsgInfo( FWDESCRIPTION ) ;
      FILENAME "..\bitmaps\16x16\info.bmp"
   SEPARATOR
   MENUITEM " &End... "  ;
      ACTION oWnd:End() FILENAME "..\bitmaps\16x16\exit.bmp"

   ENDMENU

   MENUITEM " &Clients "
   MENU
   MENUITEM "&New..." ;
      ACTION ( MsgStop( "New Clients" ), ;
      oWnd:Say( 5, 5, "New Clients...", "GR+/G" ) ) ;
      FILENAME "..\bitmaps\16x16\faces.bmp"

   MENUITEM "&Modify..."  ACTION MsgInfo( "Modif. Clients" ) ;
      FILENAME "..\bitmaps\edit.bmp"

   MENUITEM "&Delete..."  ACTION MsgAlert( "Del Clients" ) ;
      FILENAME "..\bitmaps\16x16\delete.bmp"

   SEPARATOR

   MENUITEM " &Browse... "  ACTION MsgInfo( "Browse Clients" ) ;
      FILENAME "..\bitmaps\16x16\browse.bmp"

   ENDMENU

   MENUITEM " &Utilities "
   MENU
   MENUITEM "&Calculator..." ACTION WinExec( "Calc" ) ;
      FILENAME "..\bitmaps\16x16\calc.bmp"

   MENUITEM "&Internet..." ;
      ACTION WinExec( "start iexplore www.fivetech.com", 0 ) ;
      FILENAME "..\bitmaps\16x16\explorer.bmp"
   ENDMENU

   ENDMENU

RETURN( oMenu )
// Aquí, cambie a su gusto el tamaño de los botones de la barra de botones,
// según la resolución de vídeo. -> Soy terrible. jajajajajaja.
FUNCTION SRC_RESOLUTION() //

   nResHoriz := oWnd:nHorzRes() // retorna a resolucao horizontal
   nResVert  := oWnd:nVertRes() // retorna a resolucao vertical

   IF nResHoriz     = 2560 .AND. nResVert = 1600

  nSize     := INT( nResHoriz ) / 20.00 // 64
  nTamano   := INT( nResHoriz ) / 20.00 // 64
  nAltura   := INT( nResVert  ) / 10.97 // 70

  oWnd:Update()
  oWnd:Refresh()

   ELSEIF nResHoriz = 1440 .AND. nResVert = 900

  nSize     := INT( nResHoriz ) / 20.00 // 64
  nTamano   := INT( nResHoriz ) / 20.00 // 64
  nAltura   := INT( nResVert  ) / 10.97 // 70

  oWnd:Update()
  oWnd:Refresh()

   ELSEIF nResHoriz = 1366 .AND. nResVert = 768

  nSize     := INT( nResHoriz ) / 20.00 // 64
  nTamano   := INT( nResHoriz ) / 20.00 // 64
  nAltura   := INT( nResVert  ) / 10.97 // 70

  oWnd:Update()
  oWnd:Refresh()

   ELSEIF nResHoriz = 1360 .AND. nResVert = 768

  nSize     := INT( nResHoriz ) / 20.00 // 64
  nTamano   := INT( nResHoriz ) / 20.00 // 64
  nAltura   := INT( nResVert  ) / 10.97 // 70

  oWnd:Update()
  oWnd:Refresh()

   ELSEIF nResHoriz = 1280 .AND. nResVert = 768 // Mi Resolucion.

  nSize     := INT( nResHoriz ) / 20.00 // 64
  nTamano   := INT( nResHoriz ) / 20.00 // 64
  nAltura   := INT( nResVert  ) / 10.97 // 70

  oWnd:Update()
  oWnd:Refresh()

   ELSEIF nResHoriz = 1280 .AND. nResVert = 720

  nSize     := INT( nResHoriz ) / 20.00 // 64
  nTamano   := INT( nResHoriz ) / 20.00 // 64
  nAltura   := INT( nResVert  ) / 10.97 // 70

  oWnd:Update()
  oWnd:Refresh()

   ELSEIF nResHoriz = 1280 .AND. nResVert = 960

  nSize     := INT( nResHoriz ) / 20.00 // 64
  nTamano   := INT( nResHoriz ) / 20.00 // 64
  nAltura   := INT( nResVert  ) / 10.97 // 70

  oWnd:Update()
  oWnd:Refresh()

   ELSEIF nResHoriz = 1280 .AND. nResVert = 800

  nSize     := INT( nResHoriz ) / 20.00 // 64
  nTamano   := INT( nResHoriz ) / 20.00 // 64
  nAltura   := INT( nResVert  ) / 10.97 // 70

  oWnd:Update()
  oWnd:Refresh()

   ELSEIF nResHoriz = 1280 .AND. nResVert = 720

   // continue...

   ELSEIF nResHoriz = 1280 .AND. nResVert = 600

   ELSEIF nResHoriz = 1600 .AND. nResVert = 1200

   ELSEIF nResHoriz = 1680 .AND. nResVert = 1050



   ELSEIF nResHoriz = 1024 .AND. nResVert = 768

   ELSE

   ENDIF

RETURN NIL

// FIN / END - kapiabafwh@gmail.com

Code: Select all | Expand

/*
 * Smart IsDialogMessage:
 *   FW_SetUnicode(.T.) -> IsDialogMessageW  (fixes Unicode modeless CJK IME)
 *   FW_SetUnicode(.F.) -> real IsDialogMessageA (ANSI/Big5 modeless must stay A)
 *
 * FWH message loop always imports IsDialogMessageA; we IAT-hook it.
 */
#include <Windows.h>
#include <hbapi.h>
#include "hbinit.h"

#ifndef _WIN64

#ifndef IMAGE_ORDINAL_FLAG32
#define IMAGE_ORDINAL_FLAG32 IMAGE_ORDINAL_FLAG
#endif

BOOL FW_GetUnicode( void );

typedef BOOL ( WINAPI * PFN_IsDialogMessageA )( HWND, LPMSG );

static PFN_IsDialogMessageA s_pRealIsDialogMessageA = NULL;

static BOOL WINAPI FW_IsDialogMessageDispatch( HWND hDlg, LPMSG lpMsg )
{
   if( FW_GetUnicode() )
      return IsDialogMessageW( hDlg, lpMsg );

   if( s_pRealIsDialogMessageA )
      return s_pRealIsDialogMessageA( hDlg, lpMsg );

   return IsDialogMessageA( hDlg, lpMsg );
}

static BOOL PatchIAT( HMODULE hMod, const char * cDll, const char * cFunc, PROC pNew )
{
   PIMAGE_DOS_HEADER pDos;
   PIMAGE_NT_HEADERS pNt;
   PIMAGE_IMPORT_DESCRIPTOR pImp;
   DWORD nImpRva;

   if( ! hMod )
      return FALSE;

   pDos = (PIMAGE_DOS_HEADER) hMod;
   if( pDos->e_magic != IMAGE_DOS_SIGNATURE )
      return FALSE;

   pNt = (PIMAGE_NT_HEADERS)( (BYTE *) hMod + pDos->e_lfanew );
   if( pNt->Signature != IMAGE_NT_SIGNATURE )
      return FALSE;

   nImpRva = pNt->OptionalHeader.DataDirectory[ IMAGE_DIRECTORY_ENTRY_IMPORT ].VirtualAddress;
   if( ! nImpRva )
      return FALSE;

   pImp = (PIMAGE_IMPORT_DESCRIPTOR)( (BYTE *) hMod + nImpRva );

   for( ; pImp->Name; pImp++ )
   {
      char * cName = (char *)( (BYTE *) hMod + pImp->Name );
      PIMAGE_THUNK_DATA pThunk;
      PIMAGE_THUNK_DATA pOrig;
      DWORD nOrigRva;

  if( lstrcmpiA( cName, cDll ) != 0 )
     continue;

  nOrigRva = pImp->OriginalFirstThunk ? pImp->OriginalFirstThunk : pImp->FirstThunk;
  pOrig  = (PIMAGE_THUNK_DATA)( (BYTE *) hMod + nOrigRva );
  pThunk = (PIMAGE_THUNK_DATA)( (BYTE *) hMod + pImp->FirstThunk );

  for( ; pOrig->u1.AddressOfData; pOrig++, pThunk++ )
  {
     PIMAGE_IMPORT_BY_NAME pBy;
     DWORD dwOld;

     if( pOrig->u1.Ordinal & IMAGE_ORDINAL_FLAG32 )
        continue;

     pBy = (PIMAGE_IMPORT_BY_NAME)( (BYTE *) hMod + pOrig->u1.AddressOfData );
     if( lstrcmpA( (char *) pBy->Name, cFunc ) != 0 )
        continue;

     if( VirtualProtect( &pThunk->u1.Function, sizeof( PROC ),
                         PAGE_READWRITE, &dwOld ) )
     {
        pThunk->u1.Function = (ULONG_PTR) pNew;
        VirtualProtect( &pThunk->u1.Function, sizeof( PROC ), dwOld, &dwOld );
        return TRUE;
     }
  }
   }
   return FALSE;
}

static void fw_patch_isdlg( void )
{
   HMODULE hUser;
   HMODULE hExe;

   if( s_pRealIsDialogMessageA == NULL )
   {
      hUser = GetModuleHandleA( "user32.dll" );
      if( hUser )
         s_pRealIsDialogMessageA =
            ( PFN_IsDialogMessageA ) GetProcAddress( hUser, "IsDialogMessageA" );
   }

   hExe = GetModuleHandleA( NULL );
   PatchIAT( hExe, "USER32.dll", "IsDialogMessageA",
             (PROC) FW_IsDialogMessageDispatch );
   PatchIAT( hExe, "user32.dll", "IsDialogMessageA",
             (PROC) FW_IsDialogMessageDispatch );
}

HB_CALL_ON_STARTUP_BEGIN( _fw_patch_isdialogmessage )
   fw_patch_isdlg();
HB_CALL_ON_STARTUP_END( _fw_patch_isdialogmessage )

#if defined( HB_PRAGMA_STARTUP )
   #pragma startup _fw_patch_isdialogmessage
#elif defined( HB_DATASEG_STARTUP )
   #define HB_DATASEG_BODY HB_DATASEG_FUNC( _fw_patch_isdialogmessage )
   #include "hbiniseg.h"
#endif

HB_FUNC( FW_PATCHISDIALOGMESSAGE )
{
   fw_patch_isdlg();
   hb_retl( TRUE );
}

#endif /* !_WIN64 */

Code: Select all | Expand

   HB_CDPSELECT( "UTF8" )
   FW_SetUnicode( .T. )
   FW_PatchIsDialogMessage()

Code: Select all | Expand

      if lSubClass
         // add:2026.09.23: 解決 folder 內的 tget 無法輸入中文字問題.
         //::nOldProc = XXChangeProc( ::hWnd, nAt, ::lxUnicode )
         // FW Unicode: always Unicode subclass so WM_CHAR delivers full codepoints
         // (Resource ANSI EDITTEXT otherwise LOBYTE-truncates Chinese to -:,f).
         ::nOldProc = XXChangeProc( ::hWnd, nAt,;
               IsWindowUnicode( ::hWnd ) .or. FW_SetUnicode() )
      endif

Code: Select all | Expand

 aImage   := oWnd:ReadImage( "c:\fwh\bitmaps\pngs\2.png", , .t. )
 WITH OBJECT oBrw
      :lTransparent  := .t.

  :bPaintBack := < |Self|
     FillRect( ::hDC, GetClientRect( ::hWnd ), ::oBrush:hBrush )
     ::DrawImage( aImage, ::DataRect():aRect, nil, nil, nAlphaLevel )
     ::lTransparent := .t.
     return nil
     >
  //
  :CreateFromCode()
   END 

Code: Select all | Expand

XB_WATERMARK RCDATA "2.png"

Code: Select all | Expand

aImage := oWnd:ReadImage( "XB_WATERMARK", , .t. )

Code: Select all | Expand

certutil -hashfile harbour_win32_bcc_20260829.zip SHA256

Code: Select all | Expand

86c85dc5f01171497ff9576a74d5afe30a1f61c7ce4a24e422dd7ac7a85dd4b2

Code: Select all | Expand

certutil -hashfile harbour.exe SHA256

Code: Select all | Expand

[C:\hb32_bcc_prod_my_version\bin]harbour
Harbour 3.2.0 (r2607071000)
Copyright (c) 1999-2025, https://harbour.github.io/

Syntax:  C:\hb32_bcc_prod_my_version\bin\harbour.exe <file[s][.prg]|@file> [options]

Options:  -a               automatic memvar declaration

Code: Select all | Expand

#IFDEF FULLDEMO

PROCEDURE Main
...
RETURN
#ENDIF

Code: Select all | Expand

COMPILE_FLAGS = /q /w /o\OBJ\ /DFULLDEMO

Code: Select all | Expand

#ifdef FULLDEMO
PROCEDURE Main
...
RETURN
#endif

Code: Select all | Expand

harbour myprog.prg /n /w /q /dFULLDEMO /i%HDIR%\include /i%FWDIR%\include

Code: Select all | Expand

IF IsMemvar("FULLAPP") 
#define Standalone
ENDIF

Code: Select all | Expand

#ifdef FULLAPP
   // code only for the full version
#endif

Code: Select all | Expand

PUBLIC FULLAPP := .T.      // somewhere at the start, if it is the full version

IF Type( "FULLAPP" ) != "U" .AND. FULLAPP
   // full version code
ELSE
   // standalone code
ENDIF

Code: Select all | Expand

 Indexes in use                        TagName
    => ORIGEM                             ORIGEM
       SIGLA                              SIGLA
       FANTASIA                           FANTASI
       UNIDADE                            UNIDADE
       NOMEUNID                           NOMEUNID

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
       TIPO+CONTROLE                      CTO02
       DTOS(DTEMIS)+CONHEC                CTO03
       CGCREM+DTOS(DTEMIS)                CTO04
       CGCDES+DTOS(DTEMIS)                CTO05
       NRMANIF+CONHEC                     CTO06
       CGCRESP+CONHEC                     CTO07
       BOLETO+CONHEC                      CTO08
       DTOS(DTBAIXA)+CONHEC               CTO09
       NRREL                              CTO10
       NRROMAN+CONHEC                     CTO11
       NOTAS                              CTO12
       FILIAL+BOLETO                      CTO13
       CGCRESP+BOLETO                     CTO14
       CGCRESP+DTOS(DTEMIS)               CTO15
       DTOS(DTENTRE)+CONHEC               CTO16

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO
       DTOS(DATALAN)                      DATALAN
       DTOS(DTPAGA)                       DTPAGA
       DTOS(VENCIMENTO)                   DTVENC
       DTOS(VENCIMENTO)+PAGO              DTVENCA
       DTOS(VENCIMENTO)+NOMEFOR           VENFOR
       DTOS(DTPAGA)+NOMEFOR               PAGFOR
       CNPJFOR+DTOS(VENCIMENTO)           VENFOR2
       PAGO+DTOS(VENCIMENTO)              PAGOVEN
       PLACA+DTOS(DTABA)                  DTABA
       COMPETEN                           COMPETEN
       CODCON                             CODCON
       ATU                                ATU
       NOMEFOR+DTOS(VENCIMENTO)           VENFOR3

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => NUMERO                             INDICE1
       AGENTE+NUMERO                      INDICE2
       DTOS(EMISSAO)+NUMERO               INDICE3
       DTOS(DTBAIXA)+NUMERO               INDICE4
       DTOS(VENCTO)+NUMERO                INDICE5
       CANCELADO+DTOS(EMISSAO)+NUMERO     INDICE6
       CANCELADO+DTOS(VENCTO)+NUMERO      INDICE7
       NRBANCO                            INDICE8
       EMITIDO+BANCO+NUMERO               INDICE9

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => TIPO                               TIPO

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => TIPO+CONTROLE                      CTO02
       DTOS(DTEMIS)+CONHEC                CTO03
       CGCREM+DTOS(DTEMIS)                CTO04
       CGCDES+DTOS(DTEMIS)                CTO05
       NRMANIF+CONHEC                     CTO06
       CGCRESP+CONHEC                     CTO07
       BOLETO+CONHEC                      CTO08
       DTOS(DTBAIXA)+CONHEC               CTO09
       NRREL                              CTO10
       NRROMAN+CONHEC                     CTO11
       NOTAS                              CTO12
       FILIAL+BOLETO                      CTO13
       CGCRESP+BOLETO                     CTO14
       CGCRESP+DTOS(DTEMIS)               CTO15
       DTOS(DTENTRE)+CONHEC               CTO16

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CNPJCPF                            ORIDES

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => ORI+DES                            ORIDES

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => NRCTRC                             NRCTRC
       NUMDOC+DTOS(DTEMIS)                NRNOTA
       CHAVE                              CHAVE

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => VENDEDOR                           VENDEDOR
       DTOS(DATACAD)+NOME                 DATACAD
       COBRADOR                           COBRADOR
       CEP                                CEP
       BAIRRO                             BAIRRO
       CODIGO                             CODIGO
       NOME                               NOME
       CGCCPF                             CGCCPF

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => VENDEDOR                           VENDEDOR
       DTOS(DATACAD)+NOME                 DATACAD
       COBRADOR                           COBRADOR
       CEP                                CEP
       BAIRRO                             BAIRRO
       CODIGO                             CODIGO
       NOME                               NOME
       CGCCPF                             CGCCPF

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => NOME                               NOME
       CODIGO                             CODIGO

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO
       NOME                               NOME

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO
       DESCRICAO                          DESCRICAO

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => PERIODO+PRAZO                      CHAVE1

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CIDADE                             CIDADE
       CIDADE+UF                          CIDADEUF

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
       CPF                                CPF
       NOME                               NOME
    => CNPJEMP                            CNPJ

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO
       NOME                               NOME
       CNPJ                               CNPJ
       CNPJ                               CGCCPF

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO
       NOME                               NOME
       CNPJ                               CNPJ
       CNPJ                               CGCCPF

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => PLACA                              PLACA
       PROPRIED+PLACA                     PROPRIED
       MARCA                              MARCA
       MODELO                             MODELO
       CHASSIS                            CHASSIS

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => PLACA                              PLACA
       PROPRIED+PLACA                     PROPRIED
       MARCA                              MARCA
       MODELO                             MODELO
       CHASSIS                            CHASSIS

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => DESCRICAO                          DESCRICAO

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CIDADE                             CIDADE
       CODIGO                             CODIGO
       CIDADE+UF                          CIDADEUF
       UF                                 UF

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO
       NOME                               NOME
       CPF                                CPF
       PLACAC                             PLACAC
       PLACACA                            PLACACA

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO
       NOME                               NOME
       CPF                                CPF
       PLACAC                             PLACAC
       PLACACA                            PLACACA

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO
       CNPJCPF+CODIGO                     CODCLI
       CNPJCPF                            CLIENTE
       CONTROLE+CNPJCPF                   CLIENTEC
       CNPJCPF+CODLOC+NOMCAR              CODLOC
       CODIGO+CNPJCPF+CODCAR+CODLOC       CODLOC1

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => CODIGO                             CODIGO
       DESCRICAO                          DESCRICAO

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
       CODIGO                             CODIGO
       CODIGO+CODCAR+CODLOC               CODLOC
       CODLOC+NOMCAR                      LOCCAR
       CODIGO+CODLOC+NOMCAR               CLOCCAR

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
       CODIGO                             CODIGO
       CIDADE+UF                          CIDADE
       LOCALIDADE+CIDADE+UF               LOCALIDADE

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => NRCTE+CNPJ+TIPO                    NRCTE

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
       CODPRO                             CODPRO
       NOME                               NOME
       CODCLI + CODPRO                    PROD
       CODCLI+NOME                        PROCLI

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
    => DESCRICAO                          DESCRICAO

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
       CFOP                               CFOP

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName
       CODIGO                             CODIGO
       SIGLAUF                            SIGLAUF

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName

 Relations in use

Code: Select all | Expand

 Indexes in use                        TagName

 Relations in use

Code: Select all | Expand

Called from: PROG256.PRG => CALCNOVO(9920)
Called from: PROG256.PRG => VETAB(8511)
Called from: PROG256.PRG => (b)PROG256(572))
Called from: PROG256.PRG => PROG256(578)
Called from: TRANSP32.PRG => HABIL(2404)
Called from: TRANSP32.PRG => (b)CTRC(930)

Code: Select all | Expand

dir C:\your_FW64_folder\lib\Five* /b

Code: Select all | Expand

dir C:\your_FW64_folder\lib\Five* /b

Code: Select all | Expand

// Antes de eliminar los controles, volver al origen
if ! Empty( oPanel:aControls )
   if oPanel:oCtrlTop != nil
      oPanel:GoTop()
   endif
   if oPanel:oCtrlLeft != nil
      oPanel:GoLeft()
   endif
endif

// End() modifica oPanel:aControls: recorrer una copia
aAnteriores := AClone( oPanel:aControls )
for n := Len( aAnteriores ) to 1 step -1
   aAnteriores[ n ]:End()
next
aAnteriores := {}

// Solo si utilizas AddText() o SetPage()
oPanel:aSays  := {}
oPanel:aPages := {}

// AQUI creas los controles de la nueva categoria OF oPanel
// ...

// Recalcular DESPUES de crear los nuevos controles
if ! Empty( oPanel:aControls )
   oPanel:SetRange()
endif
oPanel:Refresh()

Code: Select all | Expand

QRReadFile( cBmp )
QRDecodeGray( aGray, nW, nH )
QRDecodeMatrix( aMat, nDim )

Code: Select all | Expand

/*
 * qrread.prg - QR code reader in pure Harbour (no C, no FWH dependency).
 *
 * Pipeline:
 *   1. QRBmpLoad()       BMP (1/4/8/24/32 bit) -> gray array
 *   2. QRBinarize()      adaptive (block min/max) threshold -> black/white
 *   3. QRFindFinders()   1:1:3:1:1 finder patterns, QRLocate() orientation,
 *                        module size, grid, alignment pattern
 *   4. QRSampleGrid()    homography sampling -> bit matrix
 *   5. QRReadFormat()    15-bit BCH format info (EC level + mask)
 *   6. QRExtract()       unmask, zigzag, de-interleave blocks
 *   7. QRRsCorrect()     Reed-Solomon GF(256): syndromes, Berlekamp-Massey,
 *                        Chien search, Forney
 *   8. QRParsePayload()  numeric / alphanumeric / byte / kanji / ECI
 *
 * API:
 *   QRReadFile( cBmp )                 -> hResult | NIL
 *   QRDecodeGray( aGray, nW, nH )      -> hResult | NIL
 *   QRDecodeMatrix( aMat, nDim )       -> hResult | NIL   (stages 5-8 only)
 *   hResult keys: text version ecl mask errors dim modes
 *   text holds the raw bytes of the payload (UTF-8 for most generators; kanji
 *   mode returns Shift-JIS bytes).
 *   aMat[ nRow ][ nCol ] = 1 black / 0 white, 1-based.
 */


static s_aExp, s_aLog

//----------------------------------------------------------------------------//
// GF(256), primitive polynomial 0x11D
//----------------------------------------------------------------------------//

static function GFInit()
   local i, x := 1
   if s_aExp != NIL
      return nil
   endif
   s_aExp := Array( 512 )
   s_aLog := Array( 256 )
   AFill( s_aLog, 0 )
   for i := 0 to 254
      s_aExp[ i + 1 ] := x
      s_aLog[ x + 1 ] := i
      x := x * 2
      if x >= 256
         x := hb_bitXor( x, 285 )
      endif
   next
   for i := 255 to 511
      s_aExp[ i + 1 ] := s_aExp[ i - 255 + 1 ]
   next
return nil

static function GFMul( a, b )
   if a == 0 .or. b == 0
      return 0
   endif
return s_aExp[ s_aLog[ a + 1 ] + s_aLog[ b + 1 ] + 1 ]

static function GFDiv( a, b )
   if a == 0
      return 0
   endif
return s_aExp[ s_aLog[ a + 1 ] - s_aLog[ b + 1 ] + 255 + 1 ]

static function GFPow( n )          // alpha^n, any integer n
return s_aExp[ ( ( n % 255 ) + 255 ) % 255 + 1 ]

//----------------------------------------------------------------------------//
// Tables
//----------------------------------------------------------------------------//

// per version, per level L,M,Q,H: { nBlocksG1, totalCW, dataCW, nBlocksG2, totalCW, dataCW }
static function ECTable( nVer, nLevel )   // nLevel 1=L 2=M 3=Q 4=H
   static aT
   if aT == NIL
      aT := {;
   {{1,26,19,0,0,0},{1,26,16,0,0,0},{1,26,13,0,0,0},{1,26,9,0,0,0}},;
   {{1,44,34,0,0,0},{1,44,28,0,0,0},{1,44,22,0,0,0},{1,44,16,0,0,0}},;
   {{1,70,55,0,0,0},{1,70,44,0,0,0},{2,35,17,0,0,0},{2,35,13,0,0,0}},;
   {{1,100,80,0,0,0},{2,50,32,0,0,0},{2,50,24,0,0,0},{4,25,9,0,0,0}},;
   {{1,134,108,0,0,0},{2,67,43,0,0,0},{2,33,15,2,34,16},{2,33,11,2,34,12}},;
   {{2,86,68,0,0,0},{4,43,27,0,0,0},{4,43,19,0,0,0},{4,43,15,0,0,0}},;
   {{2,98,78,0,0,0},{4,49,31,0,0,0},{2,32,14,4,33,15},{4,39,13,1,40,14}},;
   {{2,121,97,0,0,0},{2,60,38,2,61,39},{4,40,18,2,41,19},{4,40,14,2,41,15}},;
   {{2,146,116,0,0,0},{3,58,36,2,59,37},{4,36,16,4,37,17},{4,36,12,4,37,13}},;
   {{2,86,68,2,87,69},{4,69,43,1,70,44},{6,43,19,2,44,20},{6,43,15,2,44,16}},;
   {{4,101,81,0,0,0},{1,80,50,4,81,51},{4,50,22,4,51,23},{3,36,12,8,37,13}},;
   {{2,116,92,2,117,93},{6,58,36,2,59,37},{4,46,20,6,47,21},{7,42,14,4,43,15}},;
   {{4,133,107,0,0,0},{8,59,37,1,60,38},{8,44,20,4,45,21},{12,33,11,4,34,12}},;
   {{3,145,115,1,146,116},{4,64,40,5,65,41},{11,36,16,5,37,17},{11,36,12,5,37,13}},;
   {{5,109,87,1,110,88},{5,65,41,5,66,42},{5,54,24,7,55,25},{11,36,12,7,37,13}},;
   {{5,122,98,1,123,99},{7,73,45,3,74,46},{15,43,19,2,44,20},{3,45,15,13,46,16}},;
   {{1,135,107,5,136,108},{10,74,46,1,75,47},{1,50,22,15,51,23},{2,42,14,17,43,15}},;
   {{5,150,120,1,151,121},{9,69,43,4,70,44},{17,50,22,1,51,23},{2,42,14,19,43,15}},;
   {{3,141,113,4,142,114},{3,70,44,11,71,45},{17,47,21,4,48,22},{9,39,13,16,40,14}},;
   {{3,135,107,5,136,108},{3,67,41,13,68,42},{15,54,24,5,55,25},{15,43,15,10,44,16}},;
   {{4,144,116,4,145,117},{17,68,42,0,0,0},{17,50,22,6,51,23},{19,46,16,6,47,17}},;
   {{2,139,111,7,140,112},{17,74,46,0,0,0},{7,54,24,16,55,25},{34,37,13,0,0,0}},;
   {{4,151,121,5,152,122},{4,75,47,14,76,48},{11,54,24,14,55,25},{16,45,15,14,46,16}},;
   {{6,147,117,4,148,118},{6,73,45,14,74,46},{11,54,24,16,55,25},{30,46,16,2,47,17}},;
   {{8,132,106,4,133,107},{8,75,47,13,76,48},{7,54,24,22,55,25},{22,45,15,13,46,16}},;
   {{10,142,114,2,143,115},{19,74,46,4,75,47},{28,50,22,6,51,23},{33,46,16,4,47,17}},;
   {{8,152,122,4,153,123},{22,73,45,3,74,46},{8,53,23,26,54,24},{12,45,15,28,46,16}},;
   {{3,147,117,10,148,118},{3,73,45,23,74,46},{4,54,24,31,55,25},{11,45,15,31,46,16}},;
   {{7,146,116,7,147,117},{21,73,45,7,74,46},{1,53,23,37,54,24},{19,45,15,26,46,16}},;
   {{5,145,115,10,146,116},{19,75,47,10,76,48},{15,54,24,25,55,25},{23,45,15,25,46,16}},;
   {{13,145,115,3,146,116},{2,74,46,29,75,47},{42,54,24,1,55,25},{23,45,15,28,46,16}},;
   {{17,145,115,0,0,0},{10,74,46,23,75,47},{10,54,24,35,55,25},{19,45,15,35,46,16}},;
   {{17,145,115,1,146,116},{14,74,46,21,75,47},{29,54,24,19,55,25},{11,45,15,46,46,16}},;
   {{13,145,115,6,146,116},{14,74,46,23,75,47},{44,54,24,7,55,25},{59,46,16,1,47,17}},;
   {{12,151,121,7,152,122},{12,75,47,26,76,48},{39,54,24,14,55,25},{22,45,15,41,46,16}},;
   {{6,151,121,14,152,122},{6,75,47,34,76,48},{46,54,24,10,55,25},{2,45,15,64,46,16}},;
   {{17,152,122,4,153,123},{29,74,46,14,75,47},{49,54,24,10,55,25},{24,45,15,46,46,16}},;
   {{4,152,122,18,153,123},{13,74,46,32,75,47},{48,54,24,14,55,25},{42,45,15,32,46,16}},;
   {{20,147,117,4,148,118},{40,75,47,7,76,48},{43,54,24,22,55,25},{10,45,15,67,46,16}},;
   {{19,148,118,6,149,119},{18,75,47,31,76,48},{34,54,24,34,55,25},{20,45,15,61,46,16}};
      }
   endif
return aT[ nVer ][ nLevel ]

static function AlignPos( nVer )
   local aP := {}, n, nLast, nStep, k
   if nVer < 2
      return aP
   endif
   n     := Int( nVer / 7 ) + 2
   nLast := 4 * nVer + 10
   if nVer == 32
      nStep := 26
   else
      nStep := Int( ( nLast - 6 + ( n - 1 ) * 2 - 1 ) / ( ( n - 1 ) * 2 ) ) * 2
   endif
   AAdd( aP, 6 )
   for k := n - 2 to 0 step -1
      AAdd( aP, nLast - k * nStep )
   next
return aP


//----------------------------------------------------------------------------//
// Portability helpers (Harbour 3.x and xHarbour)
//----------------------------------------------------------------------------//

function QRReadAll( cFile )       // binary-safe whole-file read
#ifdef __XHARBOUR__
   local nH := FOpen( cFile, 0 ), cBuf := "", cChunk, nRead
   if nH < 0
      return ""
   endif
   cChunk := Space( 65536 )
   do while ( nRead := FRead( nH, @cChunk, 65536 ) ) > 0
      cBuf += Left( cChunk, nRead )
   enddo
   FClose( nH )
return cBuf
#else
return hb_MemoRead( cFile )          // byte exact, also under UTF8 codepages
#endif

static function QRSub( c, n, l )
#ifdef __XHARBOUR__
return SubStr( c, n, l )
#else
return hb_BSubStr( c, n, l )
#endif

static function QRByte( cS, n )          // byte value at 1-based position n
#ifdef __XHARBOUR__
return Asc( SubStr( cS, n, 1 ) )
#else
return hb_BPeek( cS, n )
#endif

static function QRChr( n )
#ifdef __XHARBOUR__
return Chr( n )
#else
return hb_BChar( n )
#endif

static function QRBit( n, k )            // bit k (0 = LSB) of n set?
return Int( n / 2 ^ k ) % 2 == 1

//----------------------------------------------------------------------------//
// 1. BMP loader -> { nW, nH, aGray }  (aGray flat, row-major, top row first)
//----------------------------------------------------------------------------//

function QRBmpLoad( cFile )
   local cS := QRReadAll( cFile )
   local nOff, nHdr, nW, nH, nBpp, nComp, nClr, nStride, lTop
   local aPal, i, x, y, nPos, nR, nG, nB, aG, nRow, nB1, nIdx

   if Len( cS ) < 54 .or. QRSub( cS, 1, 2 ) != "BM"
      return nil
   endif
   nOff  := Bin2L( QRSub( cS, 11, 4 ) )
   nHdr  := Bin2L( QRSub( cS, 15, 4 ) )
   nW    := Bin2L( QRSub( cS, 19, 4 ) )
   nH    := Bin2L( QRSub( cS, 23, 4 ) )
   nBpp  := Bin2W( QRSub( cS, 29, 2 ) )
   nComp := Bin2L( QRSub( cS, 31, 4 ) )
   nClr  := Bin2L( QRSub( cS, 47, 4 ) )
   if nComp != 0 .and. ! ( nComp == 3 .and. nBpp == 32 )
      return nil
   endif
   lTop := ( nH < 0 )
   nH   := Abs( nH )
   if nW <= 0 .or. nH <= 0
      return nil
   endif
   nStride := Int( ( nW * nBpp + 31 ) / 32 ) * 4

   aPal := {}
   if nBpp <= 8
      if nClr == 0
         nClr := 2 ^ nBpp
      endif
      for i := 0 to nClr - 1
         nPos := 14 + nHdr + i * 4
         nB := QRByte( cS, nPos + 1 )
         nG := QRByte( cS, nPos + 2 )
         nR := QRByte( cS, nPos + 3 )
         AAdd( aPal, Int( ( 299 * nR + 587 * nG + 114 * nB ) / 1000 ) )
      next
   endif

   aG := Array( nW * nH )
   for y := 0 to nH - 1
      nRow := nOff + If( lTop, y, nH - 1 - y ) * nStride     // 0-based byte offset
      for x := 0 to nW - 1
         do case
         case nBpp == 24 .or. nBpp == 32
            nPos := nRow + x * ( nBpp / 8 )
            nB := QRByte( cS, nPos + 1 )
            nG := QRByte( cS, nPos + 2 )
            nR := QRByte( cS, nPos + 3 )
            aG[ y * nW + x + 1 ] := Int( ( 299 * nR + 587 * nG + 114 * nB ) / 1000 )
         case nBpp == 8
            nIdx := QRByte( cS, nRow + x + 1 )
            aG[ y * nW + x + 1 ] := If( nIdx < Len( aPal ), aPal[ nIdx + 1 ], 0 )
         case nBpp == 4
            nB1 := QRByte( cS, nRow + Int( x / 2 ) + 1 )
            nIdx := If( x % 2 == 0, Int( nB1 / 16 ), nB1 % 16 )
            aG[ y * nW + x + 1 ] := If( nIdx < Len( aPal ), aPal[ nIdx + 1 ], 0 )
         case nBpp == 1
            nB1 := QRByte( cS, nRow + Int( x / 8 ) + 1 )
            nIdx := If( QRBit( nB1, 7 - ( x % 8 ) ), 1, 0 )
            aG[ y * nW + x + 1 ] := If( nIdx < Len( aPal ), aPal[ nIdx + 1 ], 0 )
         otherwise
            return nil
         endcase
      next
   next
return { nW, nH, aG }

//----------------------------------------------------------------------------//
// 2. Binarization: Otsu global + local block min/max (3x3 blocks of 16 px)
//    returns flat array, 1 = black
//----------------------------------------------------------------------------//

function QRBinarize( aG, nW, nH )
   local aHist := Array( 256 ), i, nTot := nW * nH, nSum := 0, nSumB := 0
   local nWB := 0, nWF, nMax := -1, nOtsu := 128, nMB, nMF, nVar
   local nBS := 16, nBX := Int( ( nW + nBS - 1 ) / nBS ), nBY := Int( ( nH + nBS - 1 ) / nBS )
   local aMin := Array( nBX * nBY ), aMax := Array( nBX * nBY )
   local bx, by, x, y, g, k, lo, hi, thr, ix, iy, nB, aBin := Array( nTot )
   local aThr := Array( nBX * nBY ), x0, x1, y0, y1

   AFill( aHist, 0 )
   for i := 1 to nTot
      aHist[ aG[ i ] + 1 ]++
   next
   for i := 0 to 255
      nSum += i * aHist[ i + 1 ]
   next
   for i := 0 to 255
      nWB += aHist[ i + 1 ]
      if nWB == 0
         loop
      endif
      nWF := nTot - nWB
      if nWF == 0
         exit
      endif
      nSumB += i * aHist[ i + 1 ]
      nMB := nSumB / nWB
      nMF := ( nSum - nSumB ) / nWF
      nVar := nWB * nWF * ( nMB - nMF ) ^ 2
      if nVar > nMax
         nMax := nVar
         nOtsu := i
      endif
   next
   nOtsu++      // pixel < threshold  =>  black

   for by := 0 to nBY - 1
      for bx := 0 to nBX - 1
         lo := 255
         hi := 0
         x1 := Min( nW, ( bx + 1 ) * nBS ) - 1
         y1 := Min( nH, ( by + 1 ) * nBS ) - 1
         for y := by * nBS to y1
            for x := bx * nBS to x1
               g := aG[ y * nW + x + 1 ]
               if g < lo ; lo := g ; endif
               if g > hi ; hi := g ; endif
            next
         next
         aMin[ by * nBX + bx + 1 ] := lo
         aMax[ by * nBX + bx + 1 ] := hi
      next
   next
   for by := 0 to nBY - 1
      for bx := 0 to nBX - 1
         lo := 255
         hi := 0
         for iy := Max( 0, by - 1 ) to Min( nBY - 1, by + 1 )
            for ix := Max( 0, bx - 1 ) to Min( nBX - 1, bx + 1 )
               k := iy * nBX + ix + 1
               if aMin[ k ] < lo ; lo := aMin[ k ] ; endif
               if aMax[ k ] > hi ; hi := aMax[ k ] ; endif
            next
         next
         if hi - lo >= 40
            thr := ( lo + hi ) / 2
         else
            thr := nOtsu
         endif
         aThr[ by * nBX + bx + 1 ] := thr
      next
   next
   for y := 0 to nH - 1
      by := Int( y / nBS )
      for x := 0 to nW - 1
         bx := Int( x / nBS )
         aBin[ y * nW + x + 1 ] := If( aG[ y * nW + x + 1 ] < aThr[ by * nBX + bx + 1 ], 1, 0 )
      next
   next
return aBin

//----------------------------------------------------------------------------//
// 3. Finder patterns
//----------------------------------------------------------------------------//

Code: Select all | Expand

static function BinAt( aBin, nW, nH, x, y )
   if x < 0 .or. y < 0 .or. x >= nW .or. y >= nH
      return 0
   endif
return aBin[ y * nW + x + 1 ]

// module size if counts look like 1:1:3:1:1, else 0
static function RatioOk( a )
   local nTot := a[1] + a[2] + a[3] + a[4] + a[5], m, i
   if nTot < 7 .or. a[1] == 0 .or. a[2] == 0 .or. a[3] == 0 .or. a[4] == 0 .or. a[5] == 0
      return 0
   endif
   m := nTot / 7
   for i := 1 to 5
      if i == 3
         if Abs( a[3] - 3 * m ) > m * 1.0
            return 0
         endif
      elseif Abs( a[i] - m ) > m * 0.55
         return 0
      endif
   next
return m

// scan through (x,y) (black) along (dx,dy). returns { c1..c5, center } or NIL
static function ScanLine( aBin, nW, nH, nX, nY, dx, dy )
   local c := { 0, 0, 0, 0, 0 }, p, q, nLim := 4000
   // backward
   p := 0
   do while BinAt( aBin, nW, nH, nX - p * dx, nY - p * dy ) == 1 .and. p < nLim
      c[3]++ ; p++
   enddo
   nLim := p
   do while BinAt( aBin, nW, nH, nX - p * dx, nY - p * dy ) == 0 .and. c[2] < 4000
      if nX - p * dx < 0 .or. nY - p * dy < 0
         return nil
      endif
      c[2]++ ; p++
   enddo
   do while BinAt( aBin, nW, nH, nX - p * dx, nY - p * dy ) == 1 .and. c[1] < 4000
      c[1]++ ; p++
   enddo
   if c[1] == 0 .or. c[2] == 0
      return nil
   endif
   // forward
   q := 1
   do while BinAt( aBin, nW, nH, nX + q * dx, nY + q * dy ) == 1 .and. q < 4000
      c[3]++ ; q++
   enddo
   do while BinAt( aBin, nW, nH, nX + q * dx, nY + q * dy ) == 0 .and. c[4] < 4000
      if nX + q * dx >= nW .or. nY + q * dy >= nH
         return nil
      endif
      c[4]++ ; q++
   enddo
   do while BinAt( aBin, nW, nH, nX + q * dx, nY + q * dy ) == 1 .and. c[5] < 4000
      c[5]++ ; q++
   enddo
   if c[4] == 0 .or. c[5] == 0
      return nil
   endif
   // center along the axis: first pixel of run 3 is at offset -(c3 backward part)
   // backward part length = nLim (black pixels before center incl. center)
   // coordinate of run start along axis = axis - (nLim-1)
   p := If( dx != 0, nX, nY )
return { c[1], c[2], c[3], c[4], c[5], ( p - ( nLim - 1 ) ) + c[3] / 2 }

static function FindFinders( aBin, nW, nH )
   local aCand := {}, y, x, aL, aS, aC, nPrev, nRun, nStart, i, a, m, cx, cy
   local v, hz, m2, j, lMerged, ix, iy, o, n

   for y := 0 to nH - 1
      aL := {} ; aS := {} ; aC := {}
      nPrev := -1
      for x := 0 to nW - 1
         n := aBin[ y * nW + x + 1 ]
         if n != nPrev
            AAdd( aS, x ) ; AAdd( aL, 1 ) ; AAdd( aC, n )
            nPrev := n
         else
            aL[ Len( aL ) ]++
         endif
      next
      for i := 1 to Len( aL ) - 4
         if aC[ i ] != 1
            loop
         endif
         a := { aL[i], aL[i+1], aL[i+2], aL[i+3], aL[i+4] }
         m := RatioOk( a )
         if m == 0
            loop
         endif
         cx := aS[ i + 2 ] + aL[ i + 2 ] / 2
         ix := Int( cx )
         v := ScanLine( aBin, nW, nH, ix, y, 0, 1 )
         if v == nil
            loop
         endif
         m2 := RatioOk( v )
         if m2 == 0
            loop
         endif
         cy := v[ 6 ]
         iy := Int( cy )
         hz := ScanLine( aBin, nW, nH, ix, iy, 1, 0 )
         if hz == nil
            loop
         endif
         if RatioOk( hz ) == 0
            loop
         endif
         cx := hz[ 6 ]
         m  := ( m + m2 + RatioOk( hz ) ) / 3
         lMerged := .f.
         for j := 1 to Len( aCand )
            o := aCand[ j ]
            if Abs( o[1] - cx ) <= m .and. Abs( o[2] - cy ) <= m .and. Abs( o[3] - m ) <= m * 0.5
               o[1] := ( o[1] * o[4] + cx ) / ( o[4] + 1 )
               o[2] := ( o[2] * o[4] + cy ) / ( o[4] + 1 )
               o[3] := ( o[3] * o[4] + m  ) / ( o[4] + 1 )
               o[4]++
               lMerged := .t.
               exit
            endif
         next
         if ! lMerged
            AAdd( aCand, { cx, cy, m, 1 } )
         endif
      next
   next
   ASort( aCand,,, { |a,b| a[4] > b[4] } )
   if Len( aCand ) > 3 .and. aCand[ 3 ][ 4 ] >= 2
      // discard single-hit noise when real ones exist
      do while Len( aCand ) > 3 .and. ATail( aCand )[ 4 ] < 2
         ASize( aCand, Len( aCand ) - 1 )
      enddo
   endif
   if Len( aCand ) > 12
      ASize( aCand, 12 )
   endif
return aCand

static function Dist( a, b )
return Sqrt( ( a[1] - b[1] ) ^ 2 + ( a[2] - b[2] ) ^ 2 )

// choose the 3 candidates forming a right isosceles triangle.
// returns { TL, TR, BL } or NIL
static function PickTriple( aCand )
   local i, j, k, aD, d1, d2, d3, aS, nBest := 1000000000, aBest := nil, nScore
   local a, b, c, tmp, nCross, mx, mn, TL, TR, BL
   for i := 1 to Len( aCand ) - 2
      for j := i + 1 to Len( aCand ) - 1
         for k := j + 1 to Len( aCand )
            a := aCand[i] ; b := aCand[j] ; c := aCand[k]
            mx := Max( a[3], Max( b[3], c[3] ) )
            mn := Min( a[3], Min( b[3], c[3] ) )
            if mx > mn * 1.6
               loop
            endif
            // sides
            aS := { { Dist( b, c ), 1 }, { Dist( a, c ), 2 }, { Dist( a, b ), 3 } }
            ASort( aS,,, { |p,q| p[1] < q[1] } )
            if aS[1][1] < 1 .or. aS[2][1] > aS[1][1] * 1.3
               loop
            endif
            nScore := Abs( aS[3][1] / ( ( aS[1][1] + aS[2][1] ) / 2 ) - 1.4142 ) + ;
                      Abs( aS[2][1] / aS[1][1] - 1 )
            if nScore > 0.35
               loop
            endif
            if nScore < nBest
               nBest := nScore
               // vertex opposite the longest side = TL
               do case
               case aS[3][2] == 1 ; TL := a ; TR := b ; BL := c
               case aS[3][2] == 2 ; TL := b ; TR := a ; BL := c
               otherwise          ; TL := c ; TR := a ; BL := b
               endcase
               nCross := ( TR[1] - TL[1] ) * ( BL[2] - TL[2] ) - ( TR[2] - TL[2] ) * ( BL[1] - TL[1] )
               if nCross < 0
                  tmp := TR ; TR := BL ; BL := tmp
               endif
               aBest := { TL, TR, BL }
            endif
         next
      next
   next
return aBest

//----------------------------------------------------------------------------//
// Homography: module coords (u,v) -> pixel (x,y) from 4 point pairs
//----------------------------------------------------------------------------//

static function Homography( aUV, aXY )
   local A := Array( 8 ), i, r, c, f, p, t, aH
   for i := 1 to 4
      A[ 2*i-1 ] := { aUV[i][1], aUV[i][2], 1, 0, 0, 0, -aUV[i][1]*aXY[i][1], -aUV[i][2]*aXY[i][1], aXY[i][1] }
      A[ 2*i   ] := { 0, 0, 0, aUV[i][1], aUV[i][2], 1, -aUV[i][1]*aXY[i][2], -aUV[i][2]*aXY[i][2], aXY[i][2] }
   next
   for c := 1 to 8                      // gauss-jordan with pivoting
      p := c
      for r := c + 1 to 8
         if Abs( A[r][c] ) > Abs( A[p][c] ) ; p := r ; endif
      next
      if Abs( A[p][c] ) < 0.000000000001
         return nil
      endif
      t := A[c] ; A[c] := A[p] ; A[p] := t
      for r := 1 to 8
         if r != c
            f := A[r][c] / A[c][c]
            for i := c to 9
               A[r][i] -= f * A[c][i]
            next
         endif
      next
   next
   aH := Array( 8 )
   for i := 1 to 8
      aH[i] := A[i][9] / A[i][i]
   next
return aH

static function HMap( aH, u, v )
   local w := aH[7] * u + aH[8] * v + 1
return { ( aH[1]*u + aH[2]*v + aH[3] ) / w, ( aH[4]*u + aH[5]*v + aH[6] ) / w }

// look for the alignment pattern near its predicted position
// returns { x, y } pixel or NIL
static function FindAlign( aBin, nW, nH, TL, TR, BL, nDim )
   local ex, ey, pu, pv, px, py, nR, dx, dy, a, b, nSc, nBestSc := -1
   local nSx := 0, nSy := 0, nCnt := 0, sx, sy, nExp, lBlack, nMod
   nMod := ( nDim - 7 )
   ex := { ( TR[1] - TL[1] ) / nMod, ( TR[2] - TL[2] ) / nMod }
   ey := { ( BL[1] - TL[1] ) / nMod, ( BL[2] - TL[2] ) / nMod }
   pu := nDim - 6.5 - 3.5
   px := TL[1] + pu * ex[1] + pu * ey[1]
   py := TL[2] + pu * ex[2] + pu * ey[2]
   nR := Int( 3 * Max( Abs( ex[1] ) + Abs( ex[2] ), 1 ) ) + 1
   for dy := -nR to nR
      for dx := -nR to nR
         nSc := 0
         for a := -2 to 2
            for b := -2 to 2
               sx := px + dx + a * ex[1] + b * ey[1]
               sy := py + dy + a * ex[2] + b * ey[2]
               lBlack := ( BinAt( aBin, nW, nH, Int( sx ), Int( sy ) ) == 1 )
               nExp := ( Max( Abs( a ), Abs( b ) ) != 1 )
               if lBlack == nExp
                  nSc++
               endif
            next
         next
         if nSc > nBestSc
            nBestSc := nSc ; nSx := px + dx ; nSy := py + dy ; nCnt := 1
         elseif nSc == nBestSc
            nSx += px + dx ; nSy += py + dy ; nCnt++
         endif
      next
   next
   if nBestSc < 22
      return nil
   endif
return { nSx / nCnt, nSy / nCnt }

//----------------------------------------------------------------------------//
// 4. Sample the grid -> matrix aM[row][col]
//----------------------------------------------------------------------------//

static function SampleGrid( aBin, nW, nH, aH, nDim )
   local aM := Array( nDim ), r, c, p, n, k
   local aOff := { { 0, 0 }, { -0.25, 0 }, { 0.25, 0 }, { 0, -0.25 }, { 0, 0.25 } }
   for r := 1 to nDim
      aM[r] := Array( nDim )
      for c := 1 to nDim
         n := 0
         for k := 1 to 5
            p := HMap( aH, c - 0.5 + aOff[k][1], r - 0.5 + aOff[k][2] )
            n += BinAt( aBin, nW, nH, Int( p[1] ), Int( p[2] ) )
         next
         aM[r][c] := If( n >= 3, 1, 0 )
      next
   next
return aM

//----------------------------------------------------------------------------//
// 5. Format information
//----------------------------------------------------------------------------//

static function FormatCode( nData )        // 5 data bits -> 15-bit masked code
   local v := hb_bitShift( nData, 10 ), i
   for i := 14 to 10 step -1
      if QRBit( v, i )
         v := hb_bitXor( v, hb_bitShift( 1335, i - 10 ) )       // 0x537
      endif
   next
return hb_bitXor( hb_bitOr( hb_bitShift( nData, 10 ), v ), 21522 )   // 0x5412

static function BitCount( n )
   local c := 0
   do while n > 0
      c += n % 2
      n := Int( n / 2 )
   enddo
return c

static function MG( aM, nDim, x, y )       // x = column, y = row (0-based)
return aM[ y + 1 ][ x + 1 ]

// returns { nEcBits, nMask, nDist } or NIL.  EC bits: 1=L 0=M 3=Q 2=H
static function ReadFormat( aM, nDim )
   local b1 := 0, b2 := 0, i, j, nBest := 99, aRes := nil, d, nCode
   for i := 0 to 5
      b1 := b1 * 2 + MG( aM, nDim, i, 8 )
   next
   b1 := b1 * 2 + MG( aM, nDim, 7, 8 )
   b1 := b1 * 2 + MG( aM, nDim, 8, 8 )
   b1 := b1 * 2 + MG( aM, nDim, 8, 7 )
   for j := 5 to 0 step -1
      b1 := b1 * 2 + MG( aM, nDim, 8, j )
   next
   for j := nDim - 1 to nDim - 7 step -1
      b2 := b2 * 2 + MG( aM, nDim, 8, j )
   next
   for i := nDim - 8 to nDim - 1
      b2 := b2 * 2 + MG( aM, nDim, i, 8 )
   next
   for i := 0 to 31
      nCode := FormatCode( i )
      d := Min( BitCount( hb_bitXor( nCode, b1 ) ), BitCount( hb_bitXor( nCode, b2 ) ) )
      if d < nBest
         nBest := d
         aRes := { Int( i / 8 ), i % 8, d }
      endif
   next
   if nBest > 3
      return nil
   endif
return aRes

//----------------------------------------------------------------------------//
// 6. Function-pattern mask, unmask, zigzag, de-interleave
//----------------------------------------------------------------------------//

static function ReservedMap( nVer, nDim )
   local aR := Array( nDim ), r, c, aP, i, j, y, x
   for r := 1 to nDim
      aR[r] := Array( nDim )
      AFill( aR[r], .f. )
   next
   for y := 0 to 8                                   // finders + separators + format
      for x := 0 to 8
         aR[y+1][x+1] := .t.
      next
      for x := nDim - 8 to nDim - 1
         aR[y+1][x+1] := .t.
      next
   next
   for y := nDim - 8 to nDim - 1
      for x := 0 to 8
         aR[y+1][x+1] := .t.
      next
   next
   for i := 0 to nDim - 1                            // timing
      aR[7][i+1] := .t.
      aR[i+1][7] := .t.
   next
   aP := AlignPos( nVer )
   for i := 1 to Len( aP )
      for j := 1 to Len( aP )
         if ( i == 1 .and. j == 1 ) .or. ( i == 1 .and. j == Len( aP ) ) .or. ( i == Len( aP ) .and. j == 1 )
            loop
         endif
         for y := aP[i] - 2 to aP[i] + 2
            for x := aP[j] - 2 to aP[j] + 2
               aR[y+1][x+1] := .t.
            next
         next
      next
   next
   if nVer >= 7
      for y := 0 to 5
         for x := nDim - 11 to nDim - 9
            aR[y+1][x+1] := .t.
            aR[x+1][y+1] := .t.
         next
      next
   endif
return aR

static function MaskBit( nMask, i, j )     // i = row, j = col
   do case
   case nMask == 0 ; return ( i + j ) % 2 == 0
   case nMask == 1 ; return i % 2 == 0
   case nMask == 2 ; return j % 3 == 0
   case nMask == 3 ; return ( i + j ) % 3 == 0

Code: Select all | Expand

   case nMask == 4 ; return ( Int( i / 2 ) + Int( j / 3 ) ) % 2 == 0
   case nMask == 5 ; return ( i * j ) % 2 + ( i * j ) % 3 == 0
   case nMask == 6 ; return ( ( i * j ) % 2 + ( i * j ) % 3 ) % 2 == 0
   endcase
return ( ( i + j ) % 2 + ( i * j ) % 3 ) % 2 == 0

// returns array of codewords (1-based)
static function ExtractCodewords( aM, nDim, nVer, nMask )
   local aR := ReservedMap( nVer, nDim ), aCW := {}, nBit := 0, nCnt := 0, nVal := 0
   local x := nDim - 1, nDir := -1, y, dx, c, b, nRow

   do while x > 0
      if x == 6
         x--
      endif
      for nRow := 0 to nDim - 1
         y := If( nDir < 0, nDim - 1 - nRow, nRow )
         for dx := 0 to 1
            c := x - dx
            if ! aR[y+1][c+1]
               b := aM[y+1][c+1]
               if MaskBit( nMask, y, c )
                  b := 1 - b
               endif
               nVal := nVal * 2 + b
               nCnt++
               if nCnt == 8
                  AAdd( aCW, nVal )
                  nVal := 0 ; nCnt := 0
               endif
            endif
         next
      next
      nDir := - nDir
      x -= 2
   enddo
return aCW

// de-interleave: returns { aBlocks } each { aData, aEC }
static function Deinterleave( aCW, nVer, nLevel )
   local aE := ECTable( nVer, nLevel ), aBlk := {}, nB, i, j, nTot := 0
   local aLen := {}, nEC, nMaxD := 0, p := 1

   for i := 1 to aE[1]
      AAdd( aLen, aE[3] )
   next
   for i := 1 to aE[4]
      AAdd( aLen, aE[6] )
   next
   nEC := If( aE[1] > 0, aE[2] - aE[3], aE[5] - aE[6] )
   for i := 1 to Len( aLen )
      AAdd( aBlk, { Array( aLen[i] ), Array( nEC ) } )
      nMaxD := Max( nMaxD, aLen[i] )
      nTot += aLen[i] + nEC
   next
   if Len( aCW ) < nTot
      return nil
   endif
   for i := 1 to nMaxD
      for j := 1 to Len( aBlk )
         if i <= aLen[j]
            aBlk[j][1][i] := aCW[ p ] ; p++
         endif
      next
   next
   for i := 1 to nEC
      for j := 1 to Len( aBlk )
         aBlk[j][2][i] := aCW[ p ] ; p++
      next
   next
return aBlk

//----------------------------------------------------------------------------//
// 7. Reed-Solomon (GF 256, roots alpha^0 .. alpha^(nEC-1))
//    aR: received codeword (data + ec), highest degree first. Corrects in place.
//    returns number of corrected symbols, or -1 if uncorrectable
//----------------------------------------------------------------------------//

static function RsSyndromes( aR, nEC )
   local aS := Array( nEC ), j, i, v, lZero := .t.
   for j := 0 to nEC - 1
      v := 0
      for i := 1 to Len( aR )
         v := hb_bitXor( GFMul( v, GFPow( j ) ), aR[i] )
      next
      aS[ j + 1 ] := v
      if v != 0
         lZero := .f.
      endif
   next
return { aS, lZero }

function QRRsCorrect( aR, nEC )
   local aSyn, aS, nN := Len( aR ), n, i, d, L := 0, m := 1, b := 1
   local aC := { 1 }, aB := { 1 }, aT, nErr, aPos := {}, pos, x, aOm, aLam
   local xi, num, den, e, k, nFix := 0, v

   GFInit()
   aSyn := RsSyndromes( aR, nEC )
   if aSyn[2]
      return 0
   endif
   aS := aSyn[1]

   for n := 0 to nEC - 1                         // Berlekamp-Massey
      d := aS[ n + 1 ]
      for i := 1 to L
         if i + 1 <= Len( aC ) .and. n - i >= 0
            d := hb_bitXor( d, GFMul( aC[ i + 1 ], aS[ n - i + 1 ] ) )
         endif
      next
      if d == 0
         m++
      elseif 2 * L <= n
         aT := AClone( aC )
         k := GFDiv( d, b )
         do while Len( aC ) < Len( aB ) + m
            AAdd( aC, 0 )
         enddo
         for i := 1 to Len( aB )
            aC[ i + m ] := hb_bitXor( aC[ i + m ], GFMul( k, aB[i] ) )
         next
         L := n + 1 - L
         aB := aT ; b := d ; m := 1
      else
         k := GFDiv( d, b )
         do while Len( aC ) < Len( aB ) + m
            AAdd( aC, 0 )
         enddo
         for i := 1 to Len( aB )
            aC[ i + m ] := hb_bitXor( aC[ i + m ], GFMul( k, aB[i] ) )
         next
         m++
      endif
   next
   aLam := aC
   do while Len( aLam ) > 1 .and. ATail( aLam ) == 0
      ASize( aLam, Len( aLam ) - 1 )
   enddo
   nErr := Len( aLam ) - 1
   if nErr != L .or. 2 * nErr > nEC
      return -1
   endif

   for pos := 0 to nN - 1                        // Chien search
      v := 0
      for i := Len( aLam ) to 1 step -1
         v := hb_bitXor( GFMul( v, GFPow( -pos ) ), aLam[i] )
      next
      if v == 0
         AAdd( aPos, pos )
      endif
   next
   if Len( aPos ) != nErr
      return -1
   endif

   aOm := Array( nEC )                           // omega = S*Lambda mod x^nEC
   AFill( aOm, 0 )
   for i := 1 to nEC
      for k := 1 to Len( aLam )
         if i + k - 1 <= nEC
            aOm[ i + k - 1 ] := hb_bitXor( aOm[ i + k - 1 ], GFMul( aS[i], aLam[k] ) )
         endif
      next
   next
   for i := 1 to Len( aPos )                     // Forney
      pos := aPos[i]
      xi := GFPow( -pos )                        // X^-1
      num := 0
      for k := nEC to 1 step -1
         num := hb_bitXor( GFMul( num, xi ), aOm[k] )
      next
      den := 0
      for k := 2 to Len( aLam ) step 2           // odd powers of Lambda
         den := hb_bitXor( den, GFMul( aLam[k], GFPow( -pos * ( k - 2 ) ) ) )
      next
      if den == 0
         return -1
      endif
      e := GFMul( GFPow( pos ), GFDiv( num, den ) )
      aR[ nN - pos ] := hb_bitXor( aR[ nN - pos ], e )
      nFix++
   next
   aSyn := RsSyndromes( aR, nEC )
   if ! aSyn[2]
      return -1
   endif
return nFix

//----------------------------------------------------------------------------//
// 8. Payload
//----------------------------------------------------------------------------//

static function CountBits( nVer, nMode )   // nMode 1 num, 2 alnum, 4 byte, 8 kanji
   local k := If( nVer <= 9, 1, If( nVer <= 26, 2, 3 ) )
   do case
   case nMode == 1 ; return { 10, 12, 14 }[ k ]
   case nMode == 2 ; return { 9, 11, 13 }[ k ]
   case nMode == 4 ; return { 8, 16, 16 }[ k ]
   endcase
return { 8, 10, 12 }[ k ]

static function RdBits( oR, n )
   local v := 0, i
   if oR[2] + n - 1 > Len( oR[1] )
      return -1
   endif
   for i := 1 to n
      v := v * 2 + oR[1][ oR[2] ]
      oR[2]++
   next
return v

static function BitsOf( aData )
   local aB := {}, i, j, c
   for i := 1 to Len( aData )
      c := aData[i]
      for j := 7 to 0 step -1
         AAdd( aB, If( QRBit( c, j ), 1, 0 ) )
      next
   next
return aB

// returns { cText, cModes } or NIL
function QRParsePayload( aData, nVer )
   local oR := { BitsOf( aData ), 1 }, cOut := "", cModes := "", nMode, nCnt, v, i
   local cAlnum := "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-./:", n, w, hi, lo

   do while Len( oR[1] ) - oR[2] + 1 >= 4
      nMode := RdBits( oR, 4 )
      if nMode == 0
         exit
      endif
      do case
      case nMode == 1 .or. nMode == 2 .or. nMode == 4 .or. nMode == 8
         nCnt := RdBits( oR, CountBits( nVer, nMode ) )
         if nCnt < 0
            return nil
         endif
         do case
         case nMode == 1
            cModes += "N"
            do while nCnt >= 3
               v := RdBits( oR, 10 ) ; if v < 0 .or. v > 999 ; return nil ; endif
               cOut += PadL( hb_NToS( v ), 3, "0" ) ; nCnt -= 3
            enddo
            if nCnt == 2
               v := RdBits( oR, 7 ) ; if v < 0 .or. v > 99 ; return nil ; endif
               cOut += PadL( hb_NToS( v ), 2, "0" )
            elseif nCnt == 1
               v := RdBits( oR, 4 ) ; if v < 0 .or. v > 9 ; return nil ; endif
               cOut += hb_NToS( v )
            endif
         case nMode == 2
            cModes += "A"
            do while nCnt >= 2
               v := RdBits( oR, 11 ) ; if v < 0 .or. v >= 45 * 45 ; return nil ; endif
               cOut += SubStr( cAlnum, Int( v / 45 ) + 1, 1 ) + SubStr( cAlnum, v % 45 + 1, 1 )
               nCnt -= 2
            enddo
            if nCnt == 1
               v := RdBits( oR, 6 ) ; if v < 0 .or. v >= 45 ; return nil ; endif
               cOut += SubStr( cAlnum, v + 1, 1 )
            endif
         case nMode == 4
            cModes += "B"
            for i := 1 to nCnt
               v := RdBits( oR, 8 ) ; if v < 0 ; return nil ; endif
               cOut += QRChr( v )
            next
         otherwise
            cModes += "K"
            for i := 1 to nCnt
               v := RdBits( oR, 13 ) ; if v < 0 ; return nil ; endif
               hi := Int( v / 192 ) ; lo := v % 192
               n  := hi * 256 + lo
               if n + 33088 <= 40956                      // 0x8140 .. 0x9FFC
                  n += 33088
               else
                  n += 49472                              // 0xC140
               endif
               cOut += QRChr( Int( n / 256 ) ) + QRChr( n % 256 )
            next
         endcase
      case nMode == 7                                      // ECI
         v := RdBits( oR, 8 )
         if v < 0 ; return nil ; endif
         if v >= 192
            RdBits( oR, 16 )
         elseif v >= 128
            RdBits( oR, 8 )
         endif
         cModes += "E"
      case nMode == 3                                      // structured append
         RdBits( oR, 16 )
         cModes += "S"
      case nMode == 5
         cModes += "F"
      case nMode == 9
         RdBits( oR, 8 )
         cModes += "F"
      otherwise
         return nil
      endcase
   enddo
return { cOut, cModes }

//----------------------------------------------------------------------------//
// Stages 5-8 from a bit matrix
//----------------------------------------------------------------------------//

function QRDecodeMatrix( aM, nDim )
   local nVer, aF, nLevel, aCW, aBlk, aData := {}, i, j, aR, nFix := 0, n, aP, nEC
   local aLevels := { "M", "L", "H", "Q" }

   GFInit()
   if nDim < 21 .or. nDim > 177 .or. ( nDim - 17 ) % 4 != 0
      return nil
   endif
   nVer := ( nDim - 17 ) / 4
   aF := ReadFormat( aM, nDim )
   if aF == nil
      return nil
   endif
   nLevel := { 2, 1, 4, 3 }[ aF[1] + 1 ]        // ec bits 0=M 1=L 2=H 3=Q  -> index L1 M2 Q3 H4
   aCW := ExtractCodewords( aM, nDim, nVer, aF[2] )
   aBlk := Deinterleave( aCW, nVer, nLevel )
   if aBlk == nil
      return nil
   endif
   for i := 1 to Len( aBlk )
      nEC := Len( aBlk[i][2] )
      aR := ArrayJoin( aBlk[i][1], aBlk[i][2] )
      n := QRRsCorrect( aR, nEC )
      if n < 0
         return nil
      endif
      nFix += n
      for j := 1 to Len( aBlk[i][1] )
         AAdd( aData, aR[j] )
      next
   next
   aP := QRParsePayload( aData, nVer )
   if aP == nil
      return nil
   endif
return { "text" => aP[1], "version" => nVer, "ecl" => aLevels[ aF[1] + 1 ], "mask" => aF[2], ;
         "errors" => nFix, "dim" => nDim, "modes" => aP[2] }

static function ArrayJoin( a, b )
   local r := AClone( a ), i
   for i := 1 to Len( b )
      AAdd( r, b[i] )
   next
return r

//----------------------------------------------------------------------------//
// Stages 2-4 + decode
//----------------------------------------------------------------------------//

function QRDecodeGray( aG, nW, nH )
   local aBin := QRBinarize( aG, nW, nH ), aCand, aT, TL, TR, BL, nMod, nDimEst, nVEst
   local aTry, nV, nDim, aAP, aH, aM, aRes, k, aPts, aUV, aXY, nOff, lAlignTried

   aCand := FindFinders( aBin, nW, nH )
   if Len( aCand ) < 3
      return nil
   endif
   aT := PickTriple( aCand )
   if aT == nil
      return nil
   endif
   TL := aT[1] ; TR := aT[2] ; BL := aT[3]
   nMod := ( TL[3] + TR[3] + BL[3] ) / 3
   nDimEst := ( Dist( TL, TR ) + Dist( TL, BL ) ) / 2 / nMod + 7
   nVEst := Max( 1, Min( 40, Round( ( nDimEst - 17 ) / 4, 0 ) ) )

   aTry := { nVEst }
   for k := 1 to 3
      if nVEst - k >= 1 ; AAdd( aTry, nVEst - k ) ; endif
      if nVEst + k <= 40 ; AAdd( aTry, nVEst + k ) ; endif
   next
   for k := 1 to Len( aTry )
      nV := aTry[k]
      nDim := 17 + 4 * nV
      aAP := If( nV >= 2, FindAlign( aBin, nW, nH, TL, TR, BL, nDim ), nil )
      for nOff := 1 to 2
         if nOff == 1 .and. aAP == nil
            loop
         endif
         aUV := { { 3.5, 3.5 }, { nDim - 3.5, 3.5 }, { 3.5, nDim - 3.5 }, { nDim - 6.5, nDim - 6.5 } }
         aXY := { { TL[1], TL[2] }, { TR[1], TR[2] }, { BL[1], BL[2] }, Nil }
         if nOff == 1
            aXY[4] := aAP
         else
            aUV[4] := { nDim - 3.5, nDim - 3.5 }
            aXY[4] := { TR[1] + BL[1] - TL[1], TR[2] + BL[2] - TL[2] }
         endif
         aH := Homography( aUV, aXY )
         if aH == nil
            loop
         endif
         aM := SampleGrid( aBin, nW, nH, aH, nDim )
         aRes := QRDecodeMatrix( aM, nDim )
         if aRes != nil
            return aRes
         endif
      next
   next
return nil

function QRReadFile( cBmp )
   local aImg := QRBmpLoad( cBmp )
   if aImg == nil
      return nil
   endif
return QRDecodeGray( aImg[3], aImg[1], aImg[2] )

//----------------------------------------------------------------------------//

Code: Select all | Expand

REQUEST HB_GT_WIN

Code: Select all | Expand

function Main()

   local hRes := QRReadFile( "qr.bmp" )

   if hRes != NIL
      MsgInfo( hRes[ "text" ] )
   else
      MsgInfo( "No QR found" )
   endif

return nil

Code: Select all | Expand

CLS
ECHO ����������������������������������������������������������������������������Ŀ
ECHO � FWH 64 for Harbour 26.03 (VS64bits)  Mar. 2026  Harbour development power  ��
ECHO � (c) FiveTech 1993-2026 for Microsoft Windows 9X/NT/200X/ME/XP/Vista/7/8/10 ��
ECHO �������������������������������������������������������������������������������
ECHO   �����������������������������������������������������������������������������

if A%1 == A GOTO :SINTAX
if NOT EXIST %1.prg GOTO :NOEXIST

@set oldpath=%Path%
@set oldinclude=%include%
@set oldlib=%lib%
@set oldlibpath=%libpath%
@set current_dir=%cd%
setlocal
call "%ProgramFiles%\Microsoft Visual Studio\2022\Community\VC\Auxiliary\Build\vcvarsall.bat" amd64
if "%FWDIR%" == "" set FWDIR=c:\fwh64
if "%HBDIR%" == "" set HBDIR=c:\harbour64

ECHO Compiling...

set hdir=%HBDIR%
set hdirl=%hdir%\lib\win\msvc64

@cd %current_dir%
%hdir%\bin\win\msvc64\harbour %1 /n /i%fwdir%\include;%hdir%\include /w /p /d__64__ %2 %3 > comp.log 2> warnings.log
IF ERRORLEVEL 1 GOTO COMPILEERROR
@type comp.log
@type warnings.log

cl -TC -W3 -O2 -c -I%hdir%\include -D_WIN64 -D__FLAT__ -I%fwdir%\include -I-I"%ProgramFiles(x86)%\Windows Kits"\10\Include\10.0.18362.0\ucrt %1.c
:ENDCOMPILE

IF EXIST %1.rc rc -r -D__64__ %1

echo %1.obj  > msvc.tmp

echo %fwdir%\lib\FiveH64.lib %fwdir%\lib\FiveHC64.lib %fwdir%\lib\libmariadb64.lib >> msvc.tmp
rem echo %fwdir%\lib\drxlsx64.lib  >> msvc.tmp
rem echo %fwdir%\lib\xlsxlibhbmsvc64.lib  >> msvc.tmp
echo %fwdir%\lib\hbhpdf64.lib >> msvc.tmp
echo %fwdir%\lib\libhpdf64.lib >> msvc.tmp
echo %hdirl%\hbrtl.lib  >> msvc.tmp
echo %hdirl%\hbvm.lib  >> msvc.tmp
echo %hdirl%\gtgui.lib  >> msvc.tmp
echo %hdirl%\hblang.lib  >> msvc.tmp
echo %hdirl%\hbmacro.lib  >> msvc.tmp
echo %hdirl%\hbrdd.lib  >> msvc.tmp
echo %hdirl%\rddntx.lib  >> msvc.tmp
echo %hdirl%\rddcdx.lib  >> msvc.tmp
echo %hdirl%\rddfpt.lib  >> msvc.tmp
echo %hdirl%\hbsix.lib  >> msvc.tmp
echo %hdirl%\hbdebug.lib  >> msvc.tmp
echo %hdirl%\hbcommon.lib  >> msvc.tmp
echo %hdirl%\hbpp.lib  >> msvc.tmp
echo %hdirl%\hbcpage.lib  >> msvc.tmp
echo %hdirl%\hbwin.lib  >> msvc.tmp
echo %hdirl%\hbct.lib  >> msvc.tmp
echo %hdirl%\hbziparc.lib >> msvc.tmp
echo %hdirl%\hbmzip.lib >> msvc.tmp
echo %hdirl%\hbzlib.lib >> msvc.tmp
echo %hdirl%\hbpcre.lib >> msvc.tmp
echo %hdirl%\minizip.lib >> msvc.tmp
echo %hdirl%\xhb.lib >> msvc.tmp
echo %hdirl%\hbcplr.lib >> msvc.tmp
echo %hdirl%\png.lib >> msvc.tmp
echo %hdirl%\hbtip.lib >> msvc.tmp
echo %hdirl%\hbzebra.lib >> msvc.tmp
echo %hdirl%\hbcurl.lib >> msvc.tmp
echo %hdirl%\libcurl.lib >> msvc.tmp

rem Uncomment these two lines to use Advantage RDD
rem echo %hdirl%\rddads.lib >> msvc.tmp
rem echo %hdirl%\ace32.lib >> msvc.tmp

echo kernel32.lib  >> msvc.tmp
echo user32.lib    >> msvc.tmp
echo gdi32.lib     >> msvc.tmp
echo winspool.lib  >> msvc.tmp
echo comctl32.lib  >> msvc.tmp
echo comdlg32.lib  >> msvc.tmp
echo advapi32.lib  >> msvc.tmp
echo shell32.lib   >> msvc.tmp
echo ole32.lib     >> msvc.tmp
echo oleaut32.lib  >> msvc.tmp
echo uuid.lib      >> msvc.tmp
echo odbc32.lib    >> msvc.tmp
echo odbccp32.lib  >> msvc.tmp
echo iphlpapi.lib  >> msvc.tmp
echo mpr.lib       >> msvc.tmp
echo version.lib   >> msvc.tmp
echo wsock32.lib   >> msvc.tmp
echo msimg32.lib   >> msvc.tmp
echo oledlg.lib    >> msvc.tmp
echo psapi.lib     >> msvc.tmp
echo gdiplus.lib   >> msvc.tmp
echo winmm.lib     >> msvc.tmp
echo vfw32.lib     >> msvc.tmp
echo ws2_32.lib    >> msvc.tmp
echo strmiids.lib  >> msvc.tmp
echo ucrt.lib      >> msvc.tmp
echo UxTheme.lib   >> msvc.tmp

IF EXIST %1.res echo %1.res >> msvc.tmp

link @msvc.tmp /nologo /subsystem:windows /NODEFAULTLIB:libucrt /NODEFAULTLIB:msvcrt /force:multiple 
IF ERRORLEVEL 1 GOTO LINKERROR
ECHO * Application successfully built *
@set Path=%oldpath%
@set include=%oldinclude%
@set lib=%oldlib%
@set libpath=%oldlibpath%
@set oldpath=""
@set oldinclude=""
@set oldlib=
@set oldlibpath=
endlocal
start %1
GOTO EXIT
ECHO

rem delete temporary files
@del %1.c
@del msvc.tmp

:COMPILEERROR
@type comp.log
ECHO * Compiling errors *
GOTO EXIT

:LINKERROR
ECHO * Linking errors *
GOTO EXIT

:SINTAX
ECHO    SYNTAX: Build [Program]     {-- No especifiques la extensi?n PRG
ECHO                                {-- Don't specify .PRG extension
GOTO EXIT

:NOEXIST
ECHO The specified PRG %1 does not exist

:EXIT

Code: Select all | Expand

/*
blocks one after the other into a single file named qrread.prg. This is part 1 of 3.

[b]API[/b]
[list]
[*] QRReadFile( cBmp )
[*] QRDecodeGray( aGray, nW, nH )
[*] QRDecodeMatrix( aMat, nDim )
[/list]
Each returns a hash with {text, version, ecl, mask, errors, dim, modes}, or NIL if nothing could be decoded.

Notes: the text field holds raw bytes (UTF-8 for most generators, Shift-JIS for kanji). Mirrored, micro and inverted QR codes are not supported. For a webcam, capture a frame with TWebcam and pass it as a BMP, or as grayscale to QRDecodeGray().

*/

Code: Select all | Expand

" inside a sentence opened a code block too early, so the forum showed the intro text as part of the code. I have already corrected that post. Please copy the code again from the three posts (the first one is post 286564). The first line of the code must be "/*", followed by "* qrread.prg - QR code reader in pure Harbour...". Nothing of the introduction should be inside the file.

About the link error. Your BUILDH64.BAT is fine, and gtgui.lib is in the list. The message comes from hbrtl.lib(gtsys.obj), which asks for the default GT driver HB_GT_WIN. In a normal FWH program, FiveH64.lib provides the GUI as default GT (it has REQUEST HB_GT_GUI_DEFAULT in errsysw.prg). A program that does not use any FWH function never links that module, so Harbour falls back to HB_GT_WIN, and that library is not in your list.

Two ways to fix it, use either one:
[list=1]
[*] Add the line [b]echo %hdirl%\gtwin.lib >> msvc.tmp[/b] right after the gtgui.lib line of your BUILDH64.BAT.
[*] Or put this line at the top of your test program, before Main():
[/list]
[code]
REQUEST HB_GT_GUI_DEFAULT

Code: Select all | Expand

REQUEST HB_GT_GUI_DEFAULT

static s_aExp, s_aLog

function Main()

Code: Select all | Expand

echo %hdirl%\gtwin.lib  >> msvc.tmp

Code: Select all | Expand

echo %hdirl%\gtwin.lib  >> msvc.tmp

Code: Select all | Expand

#include "FiveWin.ch"

Code: Select all | Expand

function Main()
   local hRes := QRReadFile( "qr.bmp" )

Code: Select all | Expand

#include "FiveWin.ch"

function Main()

   local cFile := cGetFile( "*.bmp", "Select a QR image" )
   local hRes

   if ! Empty( cFile )
      hRes := QRReadFile( cFile )
      if hRes != NIL
         MsgInfo( hRes[ "text" ] )
      else
         MsgInfo( "No QR found" )
      endif
   endif

return nil

Code: Select all | Expand

#include "FiveWin.ch"
#include "WebCam.ch"

function Main()

   local oWnd, oWebCam
   local cTmp := hb_DirTemp() + "qrframe.bmp"

   DEFINE WINDOW oWnd TITLE "QR reader with webcam"

   @ 0, 0 WEBCAM oWebCam SIZE 640, 480 OF oWnd START ADJUST RATE 66

   // click on the camera image to read the QR that the camera is showing
   oWebCam:bLClicked := { || ReadQR( oWebCam, cTmp ) }

   ACTIVATE WINDOW oWnd

return nil

static function ReadQR( oWebCam, cTmp )

   local hRes

   FErase( cTmp )
   oWebCam:SaveFile( cTmp )          // saves the current frame as a BMP

   if ! File( cTmp )
      MsgStop( "The frame could not be saved" )
      return nil
   endif

   hRes := QRReadFile( cTmp )

   if hRes != NIL
      MsgInfo( hRes[ "text" ] )
   else
      MsgInfo( "No QR found, try again with more light or closer" )
   endif

return nil

Code: Select all | Expand

   @ nH + 180, nW + 150 BUTTON "Read &QR" OF oDlg SIZE 100, 28 PIXEL ;
      ACTION ReadQR( oCam )

Code: Select all | Expand

function ReadQR( oCam )

   local cTmp := hb_DirTemp() + "qrframe.bmp"
   local hRes

   FErase( cTmp )

   if ! oCam:Save( NIL, cTmp )        // current frame as BMP
      return nil                      // TMfWebCam already showed the error
   endif

   hRes := QRReadFile( cTmp )

   if hRes != NIL
      MsgInfo( hRes[ "text" ] )
   else
      MsgInfo( "No QR found, try again with more light or closer" )
   endif

return nil

Code: Select all | Expand

   local oScan                                  // add to the local list

   // after the IMAGE oLive line: draw the guide frame on top of the preview
   oLive:bPainted := { | hDC | DrawGuide( hDC, nW, nH ) }

   // bInit: start the scan timer after the camera is connected
   oDlg:bInit := {|| SetWindowLong( oDlg:hWnd, GWL_STYLE, ;
                      nOr( GetWindowLong( oDlg:hWnd, GWL_STYLE ), ;
                           WS_CLIPCHILDREN ) ), ;
                     oCam:Connect(), ;
                     oScan := TTimer():New( 400, {|| ScanQR( oCam, oScan ) }, oDlg ), ;
                     oScan:Activate() }

   ACTIVATE DIALOG oDlg CENTERED ;
      VALID ( If( oScan != NIL, oScan:Deactivate(), ), oCam:Disconnect(), .T. )

Code: Select all | Expand

static function DrawGuide( hDC, nW, nH )

   local nSize := 240
   local nTop  := ( nH - nSize ) / 2
   local nLeft := ( nW - nSize ) / 2
   local hPen  := CreatePen( 0, 3, nRGB( 0, 255, 0 ) )
   local hOldP := SelectObject( hDC, hPen )
   local hOldB := SelectObject( hDC, GetStockObject( 5 ) )   // 5 = NULL_BRUSH, no fill

   Rectangle( hDC, nTop, nLeft, nTop + nSize, nLeft + nSize )

   SelectObject( hDC, hOldB )
   SelectObject( hDC, hOldP )
   DeleteObject( hPen )

return nil

static function ScanQR( oCam, oScan )

   static lBusy := .F.
   local cTmp := hb_DirTemp() + "qrscan.bmp"
   local hRes

   if lBusy .or. ! oCam:isConnected
      return nil
   endif

   lBusy := .T.
   FErase( cTmp )

   if oCam:Save( NIL, cTmp )
      hRes := QRReadFile( cTmp )
      if hRes != NIL
         oScan:Deactivate()               // stop at the first QR found
         MsgInfo( hRes[ "text" ], "QR found" )
      endif
   endif

   lBusy := .F.

return nil

Code: Select all | Expand

#include "FiveWin.ch"

#define GWL_STYLE -16

function Main()

   local oWnd, hWnd, oCamera, pMediaControl
   

   DEFINE WINDOW oWnd

   oCamera = TControl()
   

   oCamera:bLClicked = { || TakePhoto( oCamera ) }

   ACTIVATE WINDOW oWnd MAXIMIZED ;
      ON INIT ( pMediaControl := DShowCamera(),;
                SetParent( hWnd := FindWindow( 0, "ActiveMovie Window" ), oWnd:hWnd ),;
                SetWindowLong( hWnd, GWL_STYLE, nOr( WS_CHILD, WS_VISIBLE ) ),;
                SetWindowPos( hWnd, 0, 15, 15, 300, 300 ),;
                oCamera:oWnd := oWnd, oCamera:hWnd := hWnd, oCamera:Link() )

return nil

function TakePhoto( oCamera )

   static oBmp

   oCamera:SaveToBmp( "photo.bmp" )
   

   if oBmp == nil
      @ 1, 60 BITMAP oBmp OF oCamera:oWnd FILENAME "photo.bmp"
   else   

      oBmp:LoadImage( , "photo.bmp" )
      oBmp:Refresh()
   endif   

return nil   

#pragma BEGINDUMP

#pragma warning(disable:4996)

#include <hbapi.h>
#include <dshow.h>
#include <uuids.h>
#include <objbase.h>

#import "qedit.dll" raw_interfaces_only named_guids

EXTERN_C const CLSID CLSID_NullRenderer;
EXTERN_C const CLSID CLSID_SampleGrabber;

HB_FUNC( DSHOWPLAY )
{
   IMediaControl * pMediaControl = ( IMediaControl * ) hb_parnll( 1 );

   pMediaControl->Run();
}   

HB_FUNC( DSHOWSTOP )
{
   IMediaControl * pMediaControl = ( IMediaControl * ) hb_parnll( 1 );

   pMediaControl->Stop();
}   

HB_FUNC( DSHOWCAMERA )
{
   HRESULT hr;
   ICreateDevEnum *pDevEnum = NULL;
   IEnumMoniker *pEnum = NULL;
   IMoniker *pMoniker = NULL;
   IPropertyBag *pPropBag = NULL;
   IGraphBuilder *pGraph = NULL;
   ICaptureGraphBuilder2 *pBuilder = NULL;
   IBaseFilter *pCap = NULL;
   IBaseFilter *pSampleGrabberFilter = NULL;
   IBaseFilter *pNullRenderer = NULL;
   IMediaControl *pMediaControl = NULL;
   char *pBuffer = NULL;
   VARIANT var;
	int n = 0;
	int device_number = 0;
	char device_name[ 100 ];
   char char_buffer[100];
   DexterLib::ISampleGrabber *pSampleGrabber = NULL;

   strcpy( device_name, "" );

   hr = CoInitializeEx( NULL, COINIT_MULTITHREADED );

   if( hr != S_OK )
      MessageBox( 0, "CoInitializeEx error", "ok", 0 );

   hr = CoCreateInstance( CLSID_FilterGraph, NULL,
 			  CLSCTX_INPROC_SERVER, IID_IGraphBuilder,
			  ( void ** ) &pGraph );
           

   if( hr != S_OK )
      MessageBox( 0, "CoCreateInstance error", "ok", 0 );
      

hr = CoCreateInstance( CLSID_CaptureGraphBuilder2, NULL,
		CLSCTX_INPROC_SERVER, IID_ICaptureGraphBuilder2,
		( void ** ) &pBuilder );      

   if( hr != S_OK )
      MessageBox( 0, "CoCreateInstance 2 error", "ok", 0 );

hr = ( ( ICaptureGraphBuilder * ) pBuilder )->SetFiltergraph( pGraph );
   
if( hr != S_OK )
	MessageBox( 0, "Could not attach capture graph builder to graph", "ok", 0 ); 
  
hr = CoCreateInstance( CLSID_SystemDeviceEnum, NULL,
		CLSCTX_INPROC_SERVER, IID_PPV_ARGS( &pDevEnum ) );
     
if( hr != S_OK )
	MessageBox( 0, "Could not crerate system device enumerator", "ok", 0 );
  
hr = pDevEnum->CreateClassEnumerator(
				CLSID_VideoInputDeviceCategory, &pEnum, 0 );
           
if( hr != S_OK )
	MessageBox( 0, "No video devices found", "ok", 0 );      
  
while(1)
{
	// Access next device
	hr = pEnum->Next(1, &pMoniker, NULL);
	if( hr == S_OK )
		n++; // increment device count
  else   
     break;
	
	// If device was specified by name rather than number...
	if( device_number == 0 )
	{
		// Get video input device name
		hr = pMoniker->BindToStorage(0, 0, IID_PPV_ARGS(&pPropBag));
		if (hr == S_OK)
		{
			// Get current device name
			VariantInit(&var);
			hr = pPropBag->Read(L"FriendlyName", &var, 0);
			
			// Convert to a normal C string, i.e. char*
			sprintf(char_buffer, "%ls", var.bstrVal);
			VariantClear(&var);
			pPropBag->Release();
			pPropBag = NULL;
			
			// Exit loop if current device name matched devname
        // MessageBox( 0, char_buffer, "device_name", 0 );
        
			if (strcmp(device_name, char_buffer) == 0) break;
		}
		else
     {
			MessageBox( 0, "Error getting device names", "ok", 0 );
        break;
     }   
	}
	else if (n >= device_number) break;
}   
   
// Get video input device name
hr = pMoniker->BindToStorage(0, 0, IID_PPV_ARGS(&pPropBag));
VariantInit(&var);
hr = pPropBag->Read(L"FriendlyName", &var, 0);
// MessageBoxW( 0, L"Capture device", var.bstrVal, 0 );
VariantClear(&var);   
   
// Create capture filter and add to graph
hr = pMoniker->BindToObject(0, 0,
				IID_IBaseFilter, (void**)&pCap);
           
if( hr != S_OK ) 
  MessageBox( 0, "Could not create capture filter", "ok", 0 );   

// Add capture filter to graph
hr = pGraph->AddFilter(pCap, L"Capture Filter");
   
if( hr != S_OK ) 
  MessageBox( 0, "Could not add capture filter to graph", "ok", 0 );

// Create sample grabber filter
hr = CoCreateInstance(CLSID_SampleGrabber, NULL,
	CLSCTX_INPROC_SERVER, IID_IBaseFilter,
	(void**)&pSampleGrabberFilter);
  
if( hr != S_OK )
	MessageBox( 0, "Could not create Sample Grabber filter", "ok", 0 );

// Query the ISampleGrabber interface of the sample grabber filter
hr = pSampleGrabberFilter->QueryInterface(
		DexterLib::IID_ISampleGrabber, (void**)&pSampleGrabber);
     
if( hr != S_OK )
	MessageBox( 0, "Could not get ISampleGrabber interface to sample grabber filter", "ok", 0 );

// Enable sample buffering in the sample grabber filter
hr = pSampleGrabber->SetBufferSamples(TRUE);
   
if( hr != S_OK )
	MessageBox( 0, "Could not enable sample buffering in the sample grabber", "ok", 0 );

// Set media type in sample grabber filter
AM_MEDIA_TYPE mt;
ZeroMemory(&mt, sizeof(AM_MEDIA_TYPE));
mt.majortype = MEDIATYPE_Video;
mt.subtype = MEDIASUBTYPE_RGB24;
hr = pSampleGrabber->SetMediaType((DexterLib::_AMMediaType *)&mt);
   
if( hr != S_OK )
	MessageBox( 0, "Could not set media type in sample grabber", "ok", 0 );

// Add sample grabber filter to filter graph
hr = pGraph->AddFilter(pSampleGrabberFilter, L"SampleGrab");
   
if( hr != S_OK )
	MessageBox( 0, "Could not add Sample Grabber to filter graph", "ok", 0 );

// Create Null Renderer filter
hr = CoCreateInstance(CLSID_NullRenderer, NULL,
	CLSCTX_INPROC_SERVER, IID_IBaseFilter,
	(void**)&pNullRenderer);

   if( hr != S_OK )
		MessageBox( 0, "Could not create Null Renderer filter", "ok", 0 );

// Add Null Renderer filter to filter graph
hr = pGraph->AddFilter(pNullRenderer, L"NullRender");

   if( hr != S_OK )
		MessageBox( 0, "Could not add Null Renderer to filter graph", "ok", 0 );
      

   // Connect up the filter graph's capture stream
	hr = pBuilder->RenderStream(
		&PIN_CATEGORY_CAPTURE, &MEDIATYPE_Video,
		pCap,  pSampleGrabberFilter, pNullRenderer);
      

if( hr != S_OK )
	MessageBox( 0, "Could not render capture video stream", "ok", 0 );

hr = pBuilder->RenderStream(
			&PIN_CATEGORY_PREVIEW, &MEDIATYPE_Video,
			pCap, NULL, NULL);

   if (hr != S_OK && hr != VFW_S_NOPREVIEWPIN)
			MessageBox( 0, "Could not render preview video stream", "ok", 0 );

// Get media control interfaces to graph builder object
hr = pGraph->QueryInterface(IID_IMediaControl,
				(void**)&pMediaControl);

   if( hr != S_OK ) 
      MessageBox( 0, "Could not get media control interface", "ok", 0 );

// Run graph
while(1)
{
	hr = pMediaControl->Run();
	
	// Hopefully, the return value was S_OK or S_FALSE
	if (hr == S_OK) break; // graph is now running
	if (hr == S_FALSE) continue; // graph still preparing to run
	
	// If the Run function returned something else,
	// there must be a problem
	// fprintf(stderr, "Error: %u\n", hr);
	MessageBox( 0, "Could not run filter graph", "ok", 0 );
}
   
   hb_retnll( ( HB_LONGLONG ) pMediaControl );
}

#pragma ENDDUMP

Code: Select all | Expand

function Main()

   local oWnd, hWnd, oCamera, pMediaControl, oScan

   DEFINE WINDOW oWnd

   oCamera = TControl()

   oCamera:bLClicked = { || TakePhoto( oCamera ) }

   ACTIVATE WINDOW oWnd MAXIMIZED ;
      ON INIT ( pMediaControl := DShowCamera(),;
                SetParent( hWnd := FindWindow( 0, "ActiveMovie Window" ), oWnd:hWnd ),;
                SetWindowLong( hWnd, GWL_STYLE, nOr( WS_CHILD, WS_VISIBLE ) ),;
                SetWindowPos( hWnd, 0, 15, 15, 300, 300 ),;
                oCamera:oWnd := oWnd, oCamera:hWnd := hWnd, oCamera:Link(),;
                oScan := TTimer():New( 500, { || ScanQR( oCamera, oScan ) }, oWnd ),;
                oScan:Activate() ) ;
      VALID ( If( oScan != NIL, oScan:DeActivate(), ), .T. )

return nil

static function ScanQR( oCamera, oScan )

   static lBusy := .F.
   local cTmp := hb_DirTemp() + "qrscan.bmp"
   local hRes

   if lBusy
      return nil
   endif

   lBusy := .T.
   FErase( cTmp )

   if oCamera:SaveToBmp( cTmp )
      hRes := QRReadFile( cTmp )
      if hRes != NIL
         oScan:DeActivate()               // stop at the first QR found
         MsgInfo( hRes[ "text" ], "QR found" )
      endif
   endif

   lBusy := .F.

return nil

Code: Select all | Expand

-gui -mt
-Ic:\fwh64\include
dshow.prg 
QrRead.prg 
-Lc:\fwh64\lib
-lFiveH64
-lFiveHC64
-lgdiplus
-lole32
-lOleDlg
-lversion
-lDrXlsx64
-LC:\BCC7764\lib\psdk -lUxtheme
xhb.hbc
hbct.hbc
hbwin.hbc
hbmzip.hbc
hbziparc.hbc
hbfoxpro.hbc
hbodbc.hbc
-ldflag=/NODEFAULTLIB:msvcrt

Code: Select all | Expand

call "%ProgramFiles%\Microsoft Visual Studio\2022\Community\VC\Auxiliary\Build\vcvarsall.bat" amd64
c:\harbour64\bin\win\msvc64\hbmk2 QrRead.HBP  -comp=msvc64
QrRead.EXE

Code: Select all | Expand

-ldflag=/NODEFAULTLIB:msvcrt

Code: Select all | Expand

cd c:\fwh64\samples
build_new.bat dshow hm64

Code: Select all | Expand

#include "qrread.prg"

Code: Select all | Expand

oScan := TTimer():New( 400, {|| ScanQR( oCam, oScan ) }, oDlg ), ;
                     oScan:Activate()

Code: Select all | Expand

ACTION ( oCam:Save( NIL, ".\dshowphoto.jpg", 90 ), ;
                   oScan := TTimer():New( 400, {|| ScanQR( oCam, oScan ) }, oDlg ), ;
                   oScan:Activate(), ;
                   oSnap:LoadImage( , ".\dshowphoto.jpg" ), oSnap:Refresh() )

Code: Select all | Expand

oScan := TTimer():New( 400, {|| ScanQR( oCam, oScan ) }, oDlg )
// do not call oScan:Activate() here

Code: Select all | Expand

ACTION ( oCam:Save( NIL, ".\dshowphoto.jpg", 90 ), ;
         oSnap:LoadImage( , ".\dshowphoto.jpg" ), oSnap:Refresh(), ;
         oScan:DeActivate(), oScan:Activate() )

Code: Select all | Expand

QRReadFile( cBmp [, @aCorners] )        -> hResult | NIL
QRDecodeGray( aGray, nW, nH [, @aCorners] ) -> hResult | NIL

Code: Select all | Expand

function QRReadFile( cBmp, aCorners )
   local aImg := QRBmpLoad( cBmp )
   aCorners := nil
   if aImg == nil
      return nil
   endif
return QRDecodeGray( aImg[3], aImg[1], aImg[2], @aCorners )

Code: Select all | Expand

aCorners := { HMap( aH, 0, 0 ), HMap( aH, nDim, 0 ), ;
              HMap( aH, nDim, nDim ), HMap( aH, 0, nDim ) }

Code: Select all | Expand

local aCorners := NIL
local hRes := QRReadFile( cTmp, @aCorners )

if hRes != NIL
   // aCorners[1] = top-left, [2] = top-right,
   // [3] = bottom-right, [4] = bottom-left
   // each one is { x, y } in pixels of the saved frame,
   // ready to scale onto your preview control and paint the frame
endif

Code: Select all | Expand

#include "hbclass.ch"

PROCEDURE Main()
   LOCAL oNet, uUnidades, uEsVip, uMayorQue4, uPrecio, uDescuento, uTotal

   // 1. Instanciamos el compilador/red neuronal
   oNet := THandwiredNet():New()

   // 2. Declaramos las variables de entrada (nodos simbólicos)
   uUnidades := oNet:Input( "unidades" )
   uEsVip    := oNet:Input( "es_vip" )

   // 3. Escribimos la lógica de negocio de forma declarativa e intuitiva:
   //    - Condición: ¿unidades > 4? (Compila a ReLU(u - 4) - ReLU(u - 5))
   //    - IIF simbólico: si > 4 vale 10, si no vale 12
   //    - Descuento: si es_vip == 1 vale 5, si no 0
   uMayorQue4 := oNet:GreaterThan( uUnidades, 4 )
   uPrecio    := oNet:Iif( uMayorQue4, 10, 12 )
   uDescuento := oNet:Iif( oNet:Equals( uEsVip, 1 ), 5, 0 )

   // Gracias a la sobrecarga de operadores en THWVar, escribimos la fórmula natural:
   uTotal     := ( uUnidades * uPrecio ) - uDescuento

   // 4. Fijamos la salida y compilamos a matrices puras
   oNet:SetOutput( uTotal )
   oNet:Compile()

   // Mostramos la arquitectura generada automáticamente
   oNet:DumpArchitecture()

   // 5. Ejecutamos la inferencia (100% MatMul + ReLU + ReGLU, cero IFs)
   ? "=== Inferencia en la Red Neuronal Compilada ==="
   ? "3 uds, Normal (Esperado: 36) -> Red:", oNet:Run( { "unidades" => 3, "es_vip" => 0 } )
   ? "5 uds, Normal (Esperado: 50) -> Red:", oNet:Run( { "unidades" => 5, "es_vip" => 0 } )
   ? "6 uds, VIP    (Esperado: 55) -> Red:", oNet:Run( { "unidades" => 6, "es_vip" => 1 } )

RETURN


// ===========================================================================
// CLASE THWVar: Representa un nodo/tensor simbólico en el grafo
// ===========================================================================
// Un THWVar almacena cómo se calcula su valor como combinación lineal de
// neuronas ocultas ReLU y términos bilineales (ReGLU).
// ===========================================================================
CLASS THWVar
   DATA oNet
   DATA aLinear   INIT {}   // Pares: { nHiddenIdx, nWeight } (Idx 0 = Bias constante)
   DATA aBilinear INIT {}   // Tripletas ReGLU: { nHiddenIdxA, nHiddenIdxB, nWeight }

   METHOD New( oNet )
   METHOD AddLinear( nHiddenIdx, nWeight )
   METHOD AddBilinear( nIdxA, nIdxB, nWeight )
   METHOD Clone()

   // Sobrecarga de operadores nativos de Harbour para expresiones naturales
   OPERATOR "+" ARG xOther
   OPERATOR "-" ARG xOther
   OPERATOR "*" ARG xOther
ENDCLASS

METHOD New( oNet ) CLASS THWVar
   ::oNet := oNet
RETURN Self

METHOD AddLinear( nHiddenIdx, nWeight ) CLASS THWVar
   LOCAL aPair
   IF nWeight == 0
      RETURN Self
   ENDIF
   FOR EACH aPair IN ::aLinear
      IF aPair[ 1 ] == nHiddenIdx
         aPair[ 2 ] += nWeight
         RETURN Self
      ENDIF
   NEXT
   AAdd( ::aLinear, { nHiddenIdx, nWeight } )
RETURN Self

METHOD AddBilinear( nIdxA, nIdxB, nWeight ) CLASS THWVar
   IF nWeight != 0
      AAdd( ::aBilinear, { nIdxA, nIdxB, nWeight } )
   ENDIF
RETURN Self

METHOD Clone() CLASS THWVar
   LOCAL oCopy := THWVar():New( ::oNet )
   LOCAL aItem
   FOR EACH aItem IN ::aLinear
      AAdd( oCopy:aLinear, { aItem[ 1 ], aItem[ 2 ] } )
   NEXT
   FOR EACH aItem IN ::aBilinear
      AAdd( oCopy:aBilinear, { aItem[ 1 ], aItem[ 2 ], aItem[ 3 ] } )
   NEXT
RETURN oCopy

// Suma simbólica: Variable + Variable  o  Variable + Constante
METHOD "+"( xOther ) CLASS THWVar
   LOCAL oRes := ::Clone()
   LOCAL aItem
   IF HB_ISNUMERIC( xOther )
      oRes:AddLinear( 0, xOther ) // 0 = Bias constante
   ELSEIF HB_ISOBJECT( xOther )
      FOR EACH aItem IN xOther:aLinear
         oRes:AddLinear( aItem[ 1 ], aItem[ 2 ] )
      NEXT
      FOR EACH aItem IN xOther:aBilinear
         oRes:AddBilinear( aItem[ 1 ], aItem[ 2 ], aItem[ 3 ] )
      NEXT
   ENDIF
RETURN oRes

// Resta simbólica: Variable - Variable  o  Variable - Constante
METHOD "-"( xOther ) CLASS THWVar
   LOCAL oRes := ::Clone()
   LOCAL aItem
   IF HB_ISNUMERIC( xOther )
      oRes:AddLinear( 0, -xOther )
   ELSEIF HB_ISOBJECT( xOther )
      FOR EACH aItem IN xOther:aLinear
         oRes:AddLinear( aItem[ 1 ], -aItem[ 2 ] )
      NEXT
      FOR EACH aItem IN xOther:aBilinear
         oRes:AddBilinear( aItem[ 1 ], aItem[ 2 ], -aItem[ 3 ] )
      NEXT
   ENDIF
RETURN oRes

// Multiplicación simbólica (Genera compuertas ReGLU cuando multiplica 2 variables)
METHOD "*"( xOther ) CLASS THWVar
   LOCAL oRes := THWVar():New( ::oNet )
   LOCAL aItemA, aItemB
   IF HB_ISNUMERIC( xOther )
      FOR EACH aItemA IN ::aLinear
         oRes:AddLinear( aItemA[ 1 ], aItemA[ 2 ] * xOther )
      NEXT
      FOR EACH aItemA IN ::aBilinear
         oRes:AddBilinear( aItemA[ 1 ], aItemA[ 2 ], aItemA[ 3 ] * xOther )
      NEXT
   ELSEIF HB_ISOBJECT( xOther )
      // Producto distributivo entre dos expresiones lineales -> Compuertas ReGLU
      FOR EACH aItemA IN ::aLinear
         FOR EACH aItemB IN xOther:aLinear
            IF aItemA[ 1 ] == 0
               oRes:AddLinear( aItemB[ 1 ], aItemA[ 2 ] * aItemB[ 2 ] )
            ELSEIF aItemB[ 1 ] == 0
               oRes:AddLinear( aItemA[ 1 ], aItemA[ 2 ] * aItemB[ 2 ] )
            ELSE
               // Ambos dependen de neuronas ocultas -> Interacción Bilineal (ReGLU)
               oRes:AddBilinear( aItemA[ 1 ], aItemB[ 1 ], aItemA[ 2 ] * aItemB[ 2 ] )
            ENDIF
         NEXT
      NEXT
   ENDIF
RETURN oRes


// ===========================================================================
// CLASE THandwiredNet: Compilador de Lógica a Matrices + Motor de Inferencia
// ===========================================================================
CLASS THandwiredNet
   DATA hInputs       INIT {=>} // Mapa nombre_entrada -> índice de columna
   DATA aInputNames   INIT {}   // Lista ordenada de entradas
   DATA aHiddenSpecs  INIT {}   // Definición de cada neurona ReLU de Capa 1
   DATA oOutputVar              // THWVar de salida

   // Matrices compiladas listas para inferencia matricial
   DATA aW1           INIT {}   // Matriz Capa 1: [ nHidden ][ nInputs + 1 (Bias) ]
   DATA aW2Linear     INIT {}   // Vector Capa 2 Lineal: [ nHidden + 1 (Bias) ]
   DATA aW2Bilinear   INIT {}   // Matriz Capa 2 ReGLU: tripletas { idxA, idxB, peso }

   METHOD New()
   METHOD Input( cName )
   METHOD AddReLUNeuron( nInputIdx, nWeight, nBias )
   METHOD GreaterThan( oVar, nThreshold )
   METHOD LessThan( oVar, nThreshold )
   METHOD Equals( oVar, nValue )
   METHOD Iif( oCond, xTrue, xFalse )
   METHOD SetOutput( oVar )
   METHOD Compile()
   METHOD Run( hValues )
   METHOD DumpArchitecture()
ENDCLASS

METHOD New() CLASS THandwiredNet
RETURN Self

// Crea una variable de entrada y una neurona ReLU identidad para dejarla pasar
METHOD Input( cName ) CLASS THandwiredNet
   LOCAL nInputIdx, nHiddenIdx, oVar

   AAdd( ::aInputNames, cName )
   nInputIdx := Len( ::aInputNames )
   ::hInputs[ cName ] := nInputIdx

   // Creamos una neurona ReLU(1 * x + 0) que actúa como "cable" de paso (para x >= 0)
   nHiddenIdx := ::AddReLUNeuron( nInputIdx, 1, 0 )

   oVar := THWVar():New( Self )
   oVar:AddLinear( nHiddenIdx, 1 )
RETURN oVar

// Añade una neurona a la Capa 1: ReLU( nWeight * Input[nInputIdx] + nBias )
METHOD AddReLUNeuron( nInputIdx, nWeight, nBias ) CLASS THandwiredNet
   AAdd( ::aHiddenSpecs, { nInputIdx, nWeight, nBias } )
RETURN Len( ::aHiddenSpecs )

// Compila (x > k) para enteros: ReLU(x - k) - ReLU(x - (k + 1))
METHOD GreaterThan( oVar, nThreshold ) CLASS THandwiredNet
   LOCAL nInputIdx := ::aHiddenSpecs[ oVar:aLinear[ 1 ][ 1 ] ][ 1 ]
   LOCAL nH1 := ::AddReLUNeuron( nInputIdx, 1, -nThreshold )
   LOCAL nH2 := ::AddReLUNeuron( nInputIdx, 1, -( nThreshold + 1 ) )
   LOCAL oCond := THWVar():New( Self )

   oCond:AddLinear( nH1,  1 )
   oCond:AddLinear( nH2, -1 )
RETURN oCond

// Compila (x < k) para enteros: 1 - (x > k - 1)
METHOD LessThan( oVar, nThreshold ) CLASS THandwiredNet
   LOCAL oGe := ::GreaterThan( oVar, nThreshold - 1 )
   LOCAL oRes := THWVar():New( Self )
   oRes:AddLinear( 0, 1 )
RETURN oRes - oGe

// Compila igualdad exacta (x == k) usando un pulso triangular de 3 ReLUs:
// ReLU(x - (k-1)) - 2*ReLU(x - k) + ReLU(x - (k+1))
METHOD Equals( oVar, nValue ) CLASS THandwiredNet
   LOCAL nInputIdx := ::aHiddenSpecs[ oVar:aLinear[ 1 ][ 1 ] ][ 1 ]
   LOCAL nH1 := ::AddReLUNeuron( nInputIdx, 1, -( nValue - 1 ) )
   LOCAL nH2 := ::AddReLUNeuron( nInputIdx, 1, -nValue )
   LOCAL nH3 := ::AddReLUNeuron( nInputIdx, 1, -( nValue + 1 ) )
   LOCAL oEq := THWVar():New( Self )

   oEq:AddLinear( nH1,  1 )
   oEq:AddLinear( nH2, -2 )
   oEq:AddLinear( nH3,  1 )
RETURN oEq

// Compila un IIF( oCond, xTrue, xFalse ) como: oCond * xTrue + (1 - oCond) * xFalse
METHOD Iif( oCond, xTrue, xFalse ) CLASS THandwiredNet
   LOCAL oOneMinusCond := THWVar():New( Self )
   LOCAL oBranchTrue, oBranchFalse

   oOneMinusCond:AddLinear( 0, 1 )
   oOneMinusCond := oOneMinusCond - oCond

   oBranchTrue  := iif( HB_ISOBJECT( xTrue ),  xTrue,   oCond * xTrue )
   IF HB_ISOBJECT( xTrue )
      oBranchTrue := oCond * xTrue
   ENDIF

   oBranchFalse := iif( HB_ISOBJECT( xFalse ), oOneMinusCond * xFalse, oOneMinusCond * xFalse )
RETURN oBranchTrue + oBranchFalse

METHOD SetOutput( oVar ) CLASS THandwiredNet
   ::oOutputVar := oVar
RETURN Self

// ---------------------------------------------------------------------------
// COMPILACIÓN: Ensambla las matrices densas aW1, aW2Linear y aW2Bilinear
// ---------------------------------------------------------------------------
METHOD Compile() CLASS THandwiredNet
   LOCAL nInputs := Len( ::aInputNames )
   LOCAL nHidden := Len( ::aHiddenSpecs )
   LOCAL i, aSpec, aRow, aPair

   // 1. Construir Matriz W1 (Capa 1): [ nHidden x (nInputs + 1) ]
   ::aW1 := Array( nHidden )
   FOR i := 1 TO nHidden
      aRow := Array( nInputs + 1 )
      AFill( aRow, 0 )
      aSpec := ::aHiddenSpecs[ i ]
      aRow[ aSpec[ 1 ] ]     := aSpec[ 2 ] // Peso de la entrada
      aRow[ nInputs + 1 ]    := aSpec[ 3 ] // Peso del Bias (última columna)
      ::aW1[ i ] := aRow
   NEXT

   // 2. Construir Vector W2 Lineal: [ nHidden + 1 ] (la última posición es el Bias de salida)
   ::aW2Linear := Array( nHidden + 1 )
   AFill( ::aW2Linear, 0 )
   FOR EACH aPair IN ::oOutputVar:aLinear
      IF aPair[ 1 ] == 0
         ::aW2Linear[ nHidden + 1 ] += aPair[ 2 ]
      ELSE
         ::aW2Linear[ aPair[ 1 ] ]  += aPair[ 2 ]
      ENDIF
   NEXT

   // 3. Copiar compuertas bilineales (ReGLU)
   ::aW2Bilinear := AClone( ::oOutputVar:aBilinear )
RETURN Self

// ---------------------------------------------------------------------------
// MOTOR DE INFERENCIA PURA: Solo multiplicación de matrices + ReLU + ReGLU
// ---------------------------------------------------------------------------
METHOD Run( hValues ) CLASS THandwiredNet
   LOCAL nInputs := Len( ::aInputNames )
   LOCAL nHidden := Len( ::aW1 )
   LOCAL aX      := Array( nInputs + 1 )
   LOCAL aH      := Array( nHidden + 1 )
   LOCAL i, j, nSum, nOut, aGate

   // Preparar vector de entrada X con un 1.0 al final para el Bias
   FOR i := 1 TO nInputs
      aX[ i ] := hValues[ ::aInputNames[ i ] ]
   NEXT
   aX[ nInputs + 1 ] := 1.0

   // CAPA 1: H = ReLU( W1 * X )
   FOR i := 1 TO nHidden
      nSum := 0
      FOR j := 1 TO nInputs + 1
         nSum += ::aW1[ i ][ j ] * aX[ j ]
      NEXT
      aH[ i ] := Max( 0, nSum ) // Función de activación ReLU
   NEXT
   aH[ nHidden + 1 ] := 1.0 // Bias para la Capa 2

   // CAPA 2 (Parte A - Producto escalar lineal): Out = W2_Linear · H
   nOut := 0
   FOR i := 1 TO nHidden + 1
      nOut += ::aW2Linear[ i ] * aH[ i ]
   NEXT

   // CAPA 2 (Parte B - Compuertas ReGLU): Out += Suma( w * H[a] * H[b] )
   FOR EACH aGate IN ::aW2Bilinear
      nOut += aGate[ 3 ] * aH[ aGate[ 1 ] ] * aH[ aGate[ 2 ] ]
   NEXT

RETURN nOut

// Muestra por pantalla las matrices compiladas y el número de pesos
METHOD DumpArchitecture() CLASS THandwiredNet
   LOCAL i, nWeightsW1 := Len( ::aW1 ) * ( Len( ::aInputNames ) + 1 )
   LOCAL nWeightsW2 := Len( ::aW2Linear ) + Len( ::aW2Bilinear )

   ? "=== Arquitectura Compilada Automaticamente ==="
   ? "Entradas :", hb_ValToExp( ::aInputNames )
   ? "Neuronas ReLU Capa 1:", Len( ::aW1 ), "| Pesos totales:", nWeightsW1 + nWeightsW2
   ? "--- Matriz W1 (Cada fila es: [", hb_ValToExp( ::aInputNames ), ", Bias ]) ---"
   FOR i := 1 TO Len( ::aW1 )
      ? "  Neurona h" + hb_ntos( i ) + ": ReLU(", hb_ValToExp( ::aW1[ i ] ), ")"
   NEXT
   ? "--- Vector W2 Lineal (Pesos sobre h1..h" + hb_ntos( Len( ::aW1 ) ) + " + Bias) ---"
   ? " ", hb_ValToExp( ::aW2Linear )
   ? "--- Compuertas ReGLU ( { hA, hB, Peso } ) ---"
   ? " ", hb_ValToExp( ::aW2Bilinear )
   ? ""
RETURN Self

Code: Select all | Expand

#include "hbclass.ch"

// ===========================================================================
// handwired.prg  --  version parcheada
//
// Cambios respecto a la version publicada en el foro (post p286654):
//   1. Input() ya no recorta negativos: cada entrada usa DOS neuronas paso,
//      ReLU(x) y ReLU(-x), y la variable es su diferencia (x = pos - neg).
//   2. El operador "*" rechaza con error claro el producto de expresiones
//      que ya contienen terminos bilineales (no representable en 2 capas),
//      en lugar de descartarlos en silencio.
//   3. GreaterThan()/Equals() validan que reciben una variable de entrada
//      directa (nInputIdx), no una expresion compuesta, y que el umbral es
//      entero; en caso contrario lanzan error descriptivo.
//   4. Run() valida que las entradas que intervienen en comparaciones
//      reciban valores enteros (las comparaciones son exactas para enteros).
//   5. Compile() exige que se haya llamado a SetOutput().
//   6. Limpiados los iif() redundantes del metodo Iif().
// ===========================================================================

PROCEDURE Main()
   LOCAL oNet, uUnidades, uEsVip, uMayorQue4, uPrecio, uDescuento, uTotal
   LOCAL oErr

   // 1. Instanciamos el compilador/red neuronal
   oNet := THandwiredNet():New()

   // 2. Declaramos las variables de entrada (nodos simbólicos)
   uUnidades := oNet:Input( "unidades" )
   uEsVip    := oNet:Input( "es_vip" )

   // 3. Escribimos la lógica de negocio de forma declarativa e intuitiva:
   //    - Condición: ¿unidades > 4? (Compila a ReLU(u - 4) - ReLU(u - 5))
   //    - IIF simbólico: si > 4 vale 10, si no vale 12
   //    - Descuento: si es_vip == 1 vale 5, si no 0
   uMayorQue4 := oNet:GreaterThan( uUnidades, 4 )
   uPrecio    := oNet:Iif( uMayorQue4, 10, 12 )
   uDescuento := oNet:Iif( oNet:Equals( uEsVip, 1 ), 5, 0 )

   // Gracias a la sobrecarga de operadores en THWVar, escribimos la fórmula natural:
   uTotal     := ( uUnidades * uPrecio ) - uDescuento

   // 4. Fijamos la salida y compilamos a matrices puras
   oNet:SetOutput( uTotal )
   oNet:Compile()

   // Mostramos la arquitectura generada automáticamente
   oNet:DumpArchitecture()

   // 5. Ejecutamos la inferencia (100% MatMul + ReLU + ReGLU, cero IFs)
   ? "=== Inferencia en la Red Neuronal Compilada ==="
   ? "3 uds, Normal (Esperado: 36) -> Red:", oNet:Run( { "unidades" => 3, "es_vip" => 0 } )
   ? "5 uds, Normal (Esperado: 50) -> Red:", oNet:Run( { "unidades" => 5, "es_vip" => 0 } )
   ? "6 uds, VIP    (Esperado: 55) -> Red:", oNet:Run( { "unidades" => 6, "es_vip" => 1 } )

   // Caso nuevo: entradas negativas ya no se recortan a cero
   ? "-2 uds, Normal (Esperado: -24) -> Red:", oNet:Run( { "unidades" => -2, "es_vip" => 0 } )

   // 6. Demostraciones de las nuevas validaciones (deben lanzar error claro)
   ? "=== Validaciones ==="

   TRY
      oNet:Run( { "unidades" => 4.5, "es_vip" => 0 } )
      ? "ERROR: no se detecto la entrada no entera"
   CATCH oErr
      ? "OK, entrada no entera rechazada:", oErr:Description
   END

   TRY
      oNet:GreaterThan( uUnidades + 1, 4 )
      ? "ERROR: no se detecto la expresion compuesta"
   CATCH oErr
      ? "OK, expresion compuesta rechazada:", oErr:Description
   END

   TRY
      ( uUnidades * uPrecio ) * uEsVip
      ? "ERROR: no se detecto el producto con terminos bilineales"
   CATCH oErr
      ? "OK, producto no representable rechazado:", oErr:Description
   END

RETURN


// ===========================================================================
// Error descriptivo del compilador/red
// ===========================================================================
STATIC FUNCTION RaiseError( cMsg )
   LOCAL oErr := ErrorNew()
   oErr:SubSystem   := "THWNET"
   oErr:Description := cMsg
   Throw( oErr )
RETURN NIL


// ===========================================================================
// CLASE THWVar: Representa un nodo/tensor simbólico en el grafo
// ===========================================================================
// Un THWVar almacena cómo se calcula su valor como combinación lineal de
// neuronas ocultas ReLU y términos bilineales (ReGLU).
//
// nInputIdx: si la variable es EXACTAMENTE una entrada declarada con Input(),
// guarda su índice de columna; cualquier operación aritmética lo pone a NIL.
// Las comparaciones (GreaterThan/Equals) lo exigen para operar sobre la
// entrada cruda y no sobre una expresión compuesta.
// ===========================================================================
CLASS THWVar
   DATA oNet
   DATA aLinear    INIT {}    // Pares: { nHiddenIdx, nWeight } (Idx 0 = Bias constante)
   DATA aBilinear  INIT {}    // Tripletas ReGLU: { nHiddenIdxA, nHiddenIdxB, nWeight }
   DATA nInputIdx  INIT NIL   // Índice de entrada si es una entrada directa, NIL si es compuesta

   METHOD New( oNet )
   METHOD AddLinear( nHiddenIdx, nWeight )
   METHOD AddBilinear( nIdxA, nIdxB, nWeight )
   METHOD Clone()

   // Sobrecarga de operadores nativos de Harbour para expresiones naturales
   OPERATOR "+" ARG xOther
   OPERATOR "-" ARG xOther
   OPERATOR "*" ARG xOther
ENDCLASS

METHOD New( oNet ) CLASS THWVar
   ::oNet := oNet
RETURN Self

METHOD AddLinear( nHiddenIdx, nWeight ) CLASS THWVar
   LOCAL aPair
   IF nWeight == 0
      RETURN Self
   ENDIF
   FOR EACH aPair IN ::aLinear
      IF aPair[ 1 ] == nHiddenIdx
         aPair[ 2 ] += nWeight
         RETURN Self
      ENDIF
   NEXT
   AAdd( ::aLinear, { nHiddenIdx, nWeight } )
RETURN Self

METHOD AddBilinear( nIdxA, nIdxB, nWeight ) CLASS THWVar
   IF nWeight != 0
      AAdd( ::aBilinear, { nIdxA, nIdxB, nWeight } )
   ENDIF
RETURN Self

METHOD Clone() CLASS THWVar
   LOCAL oCopy := THWVar():New( ::oNet )
   LOCAL aItem
   FOR EACH aItem IN ::aLinear
      AAdd( oCopy:aLinear, { aItem[ 1 ], aItem[ 2 ] } )
   NEXT
   FOR EACH aItem IN ::aBilinear
      AAdd( oCopy:aBilinear, { aItem[ 1 ], aItem[ 2 ], aItem[ 3 ] } )
   NEXT
   oCopy:nInputIdx := ::nInputIdx
RETURN oCopy

// Suma simbólica: Variable + Variable  o  Variable + Constante
METHOD "+"( xOther ) CLASS THWVar
   LOCAL oRes := ::Clone()
   LOCAL aItem
   IF HB_ISNUMERIC( xOther )
      oRes:AddLinear( 0, xOther ) // 0 = Bias constante
   ELSEIF HB_ISOBJECT( xOther )
      FOR EACH aItem IN xOther:aLinear
         oRes:AddLinear( aItem[ 1 ], aItem[ 2 ] )
      NEXT
      FOR EACH aItem IN xOther:aBilinear
         oRes:AddBilinear( aItem[ 1 ], aItem[ 2 ], aItem[ 3 ] )
      NEXT
   ENDIF
   oRes:nInputIdx := NIL // el resultado ya es una expresión compuesta
RETURN oRes

// Resta simbólica: Variable - Variable  o  Variable - Constante
METHOD "-"( xOther ) CLASS THWVar
   LOCAL oRes := ::Clone()
   LOCAL aItem
   IF HB_ISNUMERIC( xOther )
      oRes:AddLinear( 0, -xOther )
   ELSEIF HB_ISOBJECT( xOther )
      FOR EACH aItem IN xOther:aLinear
         oRes:AddLinear( aItem[ 1 ], -aItem[ 2 ] )
      NEXT
      FOR EACH aItem IN xOther:aBilinear
         oRes:AddBilinear( aItem[ 1 ], aItem[ 2 ], -aItem[ 3 ] )
      NEXT
   ENDIF
   oRes:nInputIdx := NIL // el resultado ya es una expresión compuesta
RETURN oRes

// Multiplicación simbólica (Genera compuertas ReGLU cuando multiplica 2 variables)
METHOD "*"( xOther ) CLASS THWVar
   LOCAL oRes := THWVar():New( ::oNet )
   LOCAL aItemA, aItemB
   IF HB_ISNUMERIC( xOther )
      FOR EACH aItemA IN ::aLinear
         oRes:AddLinear( aItemA[ 1 ], aItemA[ 2 ] * xOther )
      NEXT
      FOR EACH aItemA IN ::aBilinear
         oRes:AddBilinear( aItemA[ 1 ], aItemA[ 2 ], aItemA[ 3 ] * xOther )
      NEXT
      oRes:nInputIdx := NIL
   ELSEIF HB_ISOBJECT( xOther )
      // El producto de términos bilineales daría grado 3 o superior, que una
      // red de 2 capas (ReLU + ReGLU) no puede representar: error claro,
      // no descarte silencioso.
      IF ! Empty( ::aBilinear ) .OR. ! Empty( xOther:aBilinear )
         RaiseError( "THWVar * : el producto de expresiones con términos bilineales " + ;
                     "no es representable en una red de 2 capas (ReLU + ReGLU)" )
      ENDIF
      // Producto distributivo entre dos expresiones lineales -> Compuertas ReGLU
      FOR EACH aItemA IN ::aLinear
         FOR EACH aItemB IN xOther:aLinear
            IF aItemA[ 1 ] == 0
               oRes:AddLinear( aItemB[ 1 ], aItemA[ 2 ] * aItemB[ 2 ] )
            ELSEIF aItemB[ 1 ] == 0
               oRes:AddLinear( aItemA[ 1 ], aItemA[ 2 ] * aItemB[ 2 ] )
            ELSE
               // Ambos dependen de neuronas ocultas -> Interacción Bilineal (ReGLU)
               oRes:AddBilinear( aItemA[ 1 ], aItemB[ 1 ], aItemA[ 2 ] * aItemB[ 2 ] )
            ENDIF
         NEXT
      NEXT
      oRes:nInputIdx := NIL
   ENDIF
RETURN oRes


// ===========================================================================
// CLASE THandwiredNet: Compilador de Lógica a Matrices + Motor de Inferencia
// ===========================================================================
CLASS THandwiredNet
   DATA hInputs       INIT {=>} // Mapa nombre_entrada -> índice de columna
   DATA aInputNames   INIT {}   // Lista ordenada de entradas
   DATA aHiddenSpecs  INIT {}   // Definición de cada neurona ReLU de Capa 1
   DATA oOutputVar              // THWVar de salida
   DATA hCmpInputs    INIT {=>} // Índices de entrada usados en comparaciones (exigen enteros en Run)

   // Matrices compiladas listas para inferencia matricial
   DATA aW1           INIT {}   // Matriz Capa 1: [ nHidden ][ nInputs + 1 (Bias) ]
   DATA aW2Linear     INIT {}   // Vector Capa 2 Lineal: [ nHidden + 1 (Bias) ]
   DATA aW2Bilinear   INIT {}   // Matriz Capa 2 ReGLU: tripletas { idxA, idxB, peso }

   METHOD New()
   METHOD Input( cName )
   METHOD AddReLUNeuron( nInputIdx, nWeight, nBias )
   METHOD GreaterThan( oVar, nThreshold )
   METHOD LessThan( oVar, nThreshold )
   METHOD Equals( oVar, nValue )
   METHOD Iif( oCond, xTrue, xFalse )
   METHOD SetOutput( oVar )
   METHOD Compile()
   METHOD Run( hValues )
   METHOD DumpArchitecture()
ENDCLASS

METHOD New() CLASS THandwiredNet
RETURN Self

// Crea una variable de entrada.
// La entrada atraviesa DOS neuronas paso, ReLU(x) y ReLU(-x), y la variable
// es su diferencia: x = ReLU(x) - ReLU(-x). Así los valores negativos no se
// recortan a cero (con una sola neurona ReLU(x) se perdían en silencio).
METHOD Input( cName ) CLASS THandwiredNet
   LOCAL nInputIdx, nHPos, nHNeg, oVar

   AAdd( ::aInputNames, cName )
   nInputIdx := Len( ::aInputNames )
   ::hInputs[ cName ] := nInputIdx

   nHPos := ::AddReLUNeuron( nInputIdx,  1, 0 ) // parte positiva: ReLU(x)
   nHNeg := ::AddReLUNeuron( nInputIdx, -1, 0 ) // parte negativa: ReLU(-x)

   oVar := THWVar():New( Self )
   oVar:AddLinear( nHPos,  1 )
   oVar:AddLinear( nHNeg, -1 )
   oVar:nInputIdx := nInputIdx // marca: esta variable ES la entrada cruda
RETURN oVar

// Añade una neurona a la Capa 1: ReLU( nWeight * Input[nInputIdx] + nBias )
METHOD AddReLUNeuron( nInputIdx, nWeight, nBias ) CLASS THandwiredNet
   AAdd( ::aHiddenSpecs, { nInputIdx, nWeight, nBias } )
RETURN Len( ::aHiddenSpecs )

// Valida que oVar es una entrada directa (no una expresión compuesta) y la
// registra para que Run() exija valores enteros sobre ella.
METHOD CheckComparableInput( oVar, cMetodo ) CLASS THandwiredNet
   IF ! HB_ISOBJECT( oVar ) .OR. oVar:nInputIdx == NIL
      RaiseError( cMetodo + "(): requiere una variable de entrada directa, " + ;
                  "no una expresión compuesta" )
   ENDIF
   ::hCmpInputs[ oVar:nInputIdx ] := .T.
RETURN oVar:nInputIdx

// Compila (x > k) para enteros: ReLU(x - k) - ReLU(x - (k + 1))
METHOD GreaterThan( oVar, nThreshold ) CLASS THandwiredNet
   LOCAL nInputIdx := ::CheckComparableInput( oVar, "GreaterThan" )
   LOCAL nH1, nH2, oCond

   IF nThreshold != Int( nThreshold )
      RaiseError( "GreaterThan(): el umbral debe ser entero (recibido: " + ;
                  hb_ValToExp( nThreshold ) + ")" )
   ENDIF

   nH1 := ::AddReLUNeuron( nInputIdx, 1, -nThreshold )
   nH2 := ::AddReLUNeuron( nInputIdx, 1, -( nThreshold + 1 ) )
   oCond := THWVar():New( Self )

   oCond:AddLinear( nH1,  1 )
   oCond:AddLinear( nH2, -1 )
RETURN oCond

// Compila (x < k) para enteros: 1 - (x > k - 1)
METHOD LessThan( oVar, nThreshold ) CLASS THandwiredNet
   LOCAL oGe := ::GreaterThan( oVar, nThreshold - 1 )
   LOCAL oRes := THWVar():New( Self )
   oRes:AddLinear( 0, 1 )
RETURN oRes - oGe

// Compila igualdad exacta (x == k) usando un pulso triangular de 3 ReLUs:
// ReLU(x - (k-1)) - 2*ReLU(x - k) + ReLU(x - (k+1))
METHOD Equals( oVar, nValue ) CLASS THandwiredNet
   LOCAL nInputIdx := ::CheckComparableInput( oVar, "Equals" )
   LOCAL nH1, nH2, nH3, oEq

   IF nValue != Int( nValue )
      RaiseError( "Equals(): el valor debe ser entero (recibido: " + ;
                  hb_ValToExp( nValue ) + ")" )
   ENDIF

   nH1 := ::AddReLUNeuron( nInputIdx, 1, -( nValue - 1 ) )
   nH2 := ::AddReLUNeuron( nInputIdx, 1, -nValue )
   nH3 := ::AddReLUNeuron( nInputIdx, 1, -( nValue + 1 ) )
   oEq := THWVar():New( Self )

   oEq:AddLinear( nH1,  1 )
   oEq:AddLinear( nH2, -2 )
   oEq:AddLinear( nH3,  1 )
RETURN oEq

// Compila un IIF( oCond, xTrue, xFalse ) como: oCond * xTrue + (1 - oCond) * xFalse
METHOD Iif( oCond, xTrue, xFalse ) CLASS THandwiredNet
   LOCAL oOneMinusCond := THWVar():New( Self )

   oOneMinusCond:AddLinear( 0, 1 )
   oOneMinusCond := oOneMinusCond - oCond

RETURN oCond * xTrue + oOneMinusCond * xFalse

METHOD SetOutput( oVar ) CLASS THandwiredNet
   ::oOutputVar := oVar
RETURN Self

// ---------------------------------------------------------------------------
// COMPILACIÓN: Ensambla las matrices densas aW1, aW2Linear y aW2Bilinear
// ---------------------------------------------------------------------------
METHOD Compile() CLASS THandwiredNet
   LOCAL nInputs := Len( ::aInputNames )
   LOCAL nHidden := Len( ::aHiddenSpecs )
   LOCAL i, aSpec, aRow, aPair

   IF ::oOutputVar == NIL
      RaiseError( "Compile(): falta fijar la salida con SetOutput()" )
   ENDIF

   // 1. Construir Matriz W1 (Capa 1): [ nHidden x (nInputs + 1) ]
   ::aW1 := Array( nHidden )
   FOR i := 1 TO nHidden
      aRow := Array( nInputs + 1 )
      AFill( aRow, 0 )
      aSpec := ::aHiddenSpecs[ i ]
      aRow[ aSpec[ 1 ] ]     := aSpec[ 2 ] // Peso de la entrada
      aRow[ nInputs + 1 ]    := aSpec[ 3 ] // Peso del Bias (última columna)
      ::aW1[ i ] := aRow
   NEXT

   // 2. Construir Vector W2 Lineal: [ nHidden + 1 ] (la última posición es el Bias de salida)
   ::aW2Linear := Array( nHidden + 1 )
   AFill( ::aW2Linear, 0 )
   FOR EACH aPair IN ::oOutputVar:aLinear
      IF aPair[ 1 ] == 0
         ::aW2Linear[ nHidden + 1 ] += aPair[ 2 ]
      ELSE
         ::aW2Linear[ aPair[ 1 ] ]  += aPair[ 2 ]
      ENDIF
   NEXT

   // 3. Copiar compuertas bilineales (ReGLU)
   ::aW2Bilinear := AClone( ::oOutputVar:aBilinear )
RETURN Self

// ---------------------------------------------------------------------------
// MOTOR DE INFERENCIA PURA: Solo multiplicación de matrices + ReLU + ReGLU
// ---------------------------------------------------------------------------
METHOD Run( hValues ) CLASS THandwiredNet
   LOCAL nInputs := Len( ::aInputNames )
   LOCAL nHidden := Len( ::aW1 )
   LOCAL aX      := Array( nInputs + 1 )
   LOCAL aH      := Array( nHidden + 1 )
   LOCAL i, j, nSum, nOut, aGate, cName

   // Las comparaciones GreaterThan/LessThan/Equals son exactas solo para
   // enteros: rechazar valores no enteros en las entradas que las usan,
   // en lugar de interpolar en silencio.
   FOR EACH cName IN ::aInputNames
      IF hb_HHasKey( ::hCmpInputs, ::hInputs[ cName ] ) .AND. ;
         hValues[ cName ] != Int( hValues[ cName ] )
         RaiseError( "Run(): la entrada '" + cName + "' interviene en comparaciones " + ;
                     "y debe ser entera (recibido: " + hb_ValToExp( hValues[ cName ] ) + ")" )
      ENDIF
   NEXT

   // Preparar vector de entrada X con un 1.0 al final para el Bias
   FOR i := 1 TO nInputs
      aX[ i ] := hValues[ ::aInputNames[ i ] ]
   NEXT
   aX[ nInputs + 1 ] := 1.0

   // CAPA 1: H = ReLU( W1 * X )
   FOR i := 1 TO nHidden
      nSum := 0
      FOR j := 1 TO nInputs + 1
         nSum += ::aW1[ i ][ j ] * aX[ j ]
      NEXT
      aH[ i ] := Max( 0, nSum ) // Función de activación ReLU
   NEXT
   aH[ nHidden + 1 ] := 1.0 // Bias para la Capa 2

   // CAPA 2 (Parte A - Producto escalar lineal): Out = W2_Linear · H
   nOut := 0
   FOR i := 1 TO nHidden + 1
      nOut += ::aW2Linear[ i ] * aH[ i ]
   NEXT

   // CAPA 2 (Parte B - Compuertas ReGLU): Out += Suma( w * H[a] * H[b] )
   FOR EACH aGate IN ::aW2Bilinear
      nOut += aGate[ 3 ] * aH[ aGate[ 1 ] ] * aH[ aGate[ 2 ] ]
   NEXT

RETURN nOut

// Muestra por pantalla las matrices compiladas y el número de pesos
METHOD DumpArchitecture() CLASS THandwiredNet
   LOCAL i, nWeightsW1 := Len( ::aW1 ) * ( Len( ::aInputNames ) + 1 )
   LOCAL nWeightsW2 := Len( ::aW2Linear ) + Len( ::aW2Bilinear )

   ? "=== Arquitectura Compilada Automaticamente ==="
   ? "Entradas :", hb_ValToExp( ::aInputNames )
   ? "Neuronas ReLU Capa 1:", Len( ::aW1 ), "| Pesos totales:", nWeightsW1 + nWeightsW2
   ? "--- Matriz W1 (Cada fila es: [", hb_ValToExp( ::aInputNames ), ", Bias ]) ---"
   FOR i := 1 TO Len( ::aW1 )
      ? "  Neurona h" + hb_ntos( i ) + ": ReLU(", hb_ValToExp( ::aW1[ i ] ), ")"
   NEXT
   ? "--- Vector W2 Lineal (Pesos sobre h1..h" + hb_ntos( Len( ::aW1 ) ) + " + Bias) ---"
   ? " ", hb_ValToExp( ::aW2Linear )
   ? "--- Compuertas ReGLU ( { hA, hB, Peso } ) ---"
   ? " ", hb_ValToExp( ::aW2Bilinear )
   ? ""
RETURN Self

Code: Select all | Expand

// 1. Compile ONCE
oNet := THandwiredNet():New()
uUds := oNet:Input( "unidades" )
uVip := oNet:Input( "es_vip" )
oNet:SetOutput( ( uUds * oNet:Iif( oNet:GreaterThan( uUds, 4 ), 10, 12 ) ) - ;
                oNet:Iif( oNet:Equals( uVip, 1 ), 5, 0 ) )
oNet:Compile()

// 2. Evaluate MANY records with the same matrices
aOut := Array( Len( aRows ) )
for i := 1 to Len( aRows )
   aOut[ i ] := oNet:Run( aRows[ i ] )   // { "unidades" => n, "es_vip" => n }
next

Code: Select all | Expand

account.exe  : $(PRG:.PRG=.OBJ) account.res
   echo off
   echo $(BCDIR)\lib\c0w32.obj + > b32.bc
   echo obj\ejemcont.obj obj\contabil.obj obj\mntotel.obj, + >> b32.bc
   ...
   $(BCDIR)\bin\ilink32 -Gn -aa -Tpe -s @b32.bc
   del b32.bc

Code: Select all | Expand

C:\Borland\BCC55\Bin\bcc32 -c -tWM -oobj\test.obj test.c
echo %ERRORLEVEL%

Code: Select all | Expand

Application
===========
   Path and name: D:\SiaWin50\SiaWin50.Exe (32 bits)
   Size: 6,582,784 bytes
   Compiler version: Harbour 3.2.0dev (r2503251254)
   FiveWin  version: FWH 25.09
   C compiler version: Borland/Embarcadero C++ 7.7 (32-bit)
   Windows 11 64 Bits, version: 6.2, Build 9200 

   Time from start: 8 sec
   Error occurred at: 19/09/2026, 11:19:51
   Error description: Error BASE/1004  Message not found: TWINDOW:DEFCONTROL
   Args:
     [   1] = O   TWINDOW

Stack Calls
===========
   Called from:  => __ERRRT_SBASE( 0 )
   Called from: ../../../tobject.prg => TWINDOW:ERROR( 0 )
   Called from: ../../../tobject.prg => (b)HBOBJECT( 0 )
   Called from: ../../../tobject.prg => TWINDOW:MSGNOTFOUND( 0 )
   Called from: ../../../tobject.prg => TWINDOW:DEFCONTROL( 0 )
   Called from: .\source\classes\tmetafil.prg => TMETAFILE:NEW( 123 )
   Called from: Source\rpreview.prg => TPREVIEW:BUILDWINDOW( 520 )
   Called from: Source\rpreview.prg => TPREVIEW:NEW( 140 )
   Called from: Source\rpreview.prg => RPREVIEW( 2115 )
   Called from: .\source\classes\report.prg => (b)TREPORT_NEW( 188 )
   Called from: .\source\classes\report.prg => TREPORT:ACTIVATE( 917 )
   Called from: Source\SiaWin7e.prg => IMPRIMIR( 512 )
   Called from: Source\SiaWin7e.prg => (b)SIAWIN7E( 123 )
   Called from: .\source\classes\btnbmp.prg => TBTNBMP:CLICK( 816 )

Code: Select all | Expand

SiaWin7e.prg => IMPRIMIR( 512 ) - si posible, COMPLETO.

Code: Select all | Expand

STATIC FUNCTION Imprimir()
	LOCAL oReporte
	LOCAL oFont1,oFont2,oFont3
	LOCAL oPen1,oPen2
	LOCAL cTitulo	:= "Catálogo de marcas"

LOCAL nLinea		:= 1
LOCAL nHasta		:= oRsMar:RecordCount()
LOCAL nBookMark	:= oRsMar:BookMark

DEFINE FONT oFont1 NAME "ARIAL" SIZE 0,-10
DEFINE FONT oFont2 NAME "ARIAL" SIZE 0,-10 BOLD
DEFINE FONT oFont3 NAME "ARIAL" SIZE 0,-14 BOLD

DEFINE PEN oPen1 WIDTH 3 COLOR CLR_HBLUE
DEFINE PEN oPen2 WIDTH 1 COLOR CLR_HMAGENTA

oRsMar:MoveFirst()

REPORT oReporte CAPTION cTitulo PREVIEW ;
	HEADER ALLTRIM(oApp:cRazonSocial),;
	"",;
	cTitulo CENTER;
	TITLE "Fecha: "+Date2Txt(DATE()),;
	"Hoja No:"+STR(oReporte:nPage,3);
	FONT oFont1,oFont2,oFont3;
	PEN open1,oPen2

	COLUMN TITLE "Número"		DATA oRsMar:Fields("MAR_NUM"):Value						SIZE  6 RIGHT PICTURE "@Z 99"
	COLUMN TITLE "Descripción"	DATA oRsMar:Fields("MAR_NOM"):Value						SIZE 35 LEFT
END REPORT

IF oReporte:lCreated
	oReporte:SetTxtColor(CLR_BLACK,1)	// Color del texto de la hoja default NEGRO
	oReporte:SetTxtColor(CLR_HRED,2)		// Color de encabezado y totales del grupo
	oReporte:SetTxtColor(CLR_HRED,3)		// Color para el primer titulo del encabezado
	oReporte:SetPenColor(CLR_HBLUE)		// Color para las líneas
	oReporte:SetShdColor(CLR_YELLOW)		// Color para el sombreado
	oReporte:oHeader:aFont[1] := {||3}

	oReporte:oTitle:aPad[1] := RPT_LEFT
	oReporte:oTitle:aPad[2] := RPT_RIGHT

   oReporte:bSkip := { || (nLinea++, oRsMar:MoveNext())}

ENDIF

   ACTIVATE REPORT oReporte ;
		ON STARTPAGE Alinea(oReporte,1,2);
		ON END oRsMar:BookMark := nBookMark;
      WHILE nLinea <= nHasta				[b]<=============  esta es la línea 512[/b]

oFont1:Release()
oFont2:Release()
oFont3:Release()
oPen1:Release()
oPen2:Release()
RETURN(Nil)

Code: Select all | Expand

//-> C:\FWH2603\SAMPLES\ARMANDO2.PRG

#include "FiveWin.ch"
#include "Report.ch"

FUNCTION Imprimir_Armando()

   LOCAL oPen1, oPen2
   LOCAL oFont1, oFont2, oFont3
   LOCAL Report
   LOCAL nBookMark := oRsMar:BookMark
   LOCAL nLinea := 1
   LOCAL nHasta := 50 // limite de lineas.

   DEFINE PEN oPen1 WIDTH 2
   DEFINE PEN oPen2 WIDTH 1     

   DEFINE FONT oFont1 NAME "Arial"       SIZE 0, -10
   DEFINE FONT oFont2 NAME "Arial"       SIZE 0, -10
   DEFINE FONT oFont3 NAME "Courier New" SIZE 0,  10

// SELECT( BAIRROS )
// DbGoTop()

   REPORT oReport TITLE "Listagem de BAIRROS" ;
      CAPTION "Catálogo: BAIRROS"             ;
      HEADER "BAIRROS",                       ;
      "Fecha:  " + DTOC( DATE() ),            ;
      "Página: " + STR( oReport:nPage, 3 )    ;
      FOOTER "- BAIRROS -" CENTER             ;
      FONT oFont1, oFont2, oFont3             ;
      PEN oPen1, oPen2 ;
      PREVIEW

  oReport:oDevice:lPrvModal := .T. 
  oReport:oDevice:SetPage(9) //-> Formato A4

  // Otras columnas aqui...

   ENDREPORT

   ACTIVATE REPORT Report                 ;
      ON STARTPAGE Aline(Report, 1, 2)    ;
      ON END oRsMar:BookMark := nBookMark ;
      WHILE nLinea <= nHasta ;
      ON CHANGE ( nLinea++ ) // Incrementa Linea

   oPen1:End()
   oPen2:End()  

   oFont1:End() 
   oFont2:End() 
   oFont3:End()

RETURN NIL

Code: Select all | Expand

//-> C:\FWH2603\SAMPLES\ARMANDO3.PRG

#include "FiveWin.ch"
#include "Report.ch"

STATIC FUNCTION Imprimir()

   LOCAL oReporte
   LOCAL oFont1, oFont2, oFont3
   LOCAL oPen1, oPen2
   LOCAL cTitulo := "Catálogo de marcas"
   LOCAL nBookMark := oRsMar:BookMark

   DEFINE FONT oFont1 NAME "ARIAL" SIZE 0, - 10
   DEFINE FONT oFont2 NAME "ARIAL" SIZE 0, - 10 BOLD
   DEFINE FONT oFont3 NAME "ARIAL" SIZE 0, - 14 BOLD

   DEFINE PEN oPen1 WIDTH 3 COLOR CLR_HBLUE
   DEFINE PEN oPen2 WIDTH 1 COLOR CLR_HMAGENTA

   oRsMar:MoveFirst()

   REPORT oReporte CAPTION cTitulo PREVIEW  ;
      HEADER ALLTRIM( oApp:cRazonSocial ),  ;
      "",                                   ;
      cTitulo CENTER                        ;
      TITLE "Fecha: " + Date2Txt( DATE() ), ;
      "Hoja No:" + STR( oReporte:nPage, 3 ) ;
      FONT oFont1, oFont2, oFont3           ;
      PEN open1, oPen2

  COLUMN TITLE "Número"  DATA oRsMar:Fields( "MAR_NUM" ):Value      SIZE 6 RIGHT PICTURE "@Z 99"
  COLUMN TITLE "Descripción" DATA oRsMar:Fields( "MAR_NOM" ):Value  SIZE 35 LEFT

   ENDREPORT

   IF oReporte:lCreated

  oReporte:SetTxtColor( CLR_BLACK, 1 ) 
  oReporte:SetTxtColor( CLR_HRED, 2 )  
  oReporte:SetTxtColor( CLR_HRED, 3 )  
  oReporte:SetPenColor( CLR_HBLUE )  
  oReporte:SetShdColor( CLR_YELLOW )  
  oReporte:oHeader:aFont[1] := {||3 }

  oReporte:oTitle:aPad[1] := RPT_LEFT
  oReporte:oTitle:aPad[2] := RPT_RIGHT

  // Simplificado: Solo avanzamos el RecordSet en cada línea
  oReporte:bSkip := { || oRsMar:MoveNext() }

   ENDIF

   ACTIVATE REPORT oReporte                 ;
      ON STARTPAGE Alinea( oReporte, 1, 2 ) ;
      ON END oRsMar:BookMark := nBookMark   ;
      WHILE !oRsMar:EOF // <============= Solución aquí ?

   oFont1:Release()
   oFont2:Release()
   oFont3:Release()
   oPen1:Release()
   oPen2:Release()

RETURN NIL

// FIN / END

Code: Select all | Expand

rem MinGW GCC
set PATH=C:\mingw64\bin;%PATH%
win-make

Code: Select all | Expand

win-make clean

Code: Select all | Expand

win-make clean install

Code: Select all | Expand

Aplicación
==========
   Ruta y nombre: C:\cmplar_64\hymlyma.exe (64 bits)
   Tamaño: ********* bytes
   Versión del compilador: xHarbour 1.3.2 Intl. (SimpLex) (Build 20251210)
   Versión de FiveWin: FWH 26.03
   Versión del compilador C: LLVM/Clang C 5.0.2 (64-bit)
   Windows 8 64 Bits, version: 6.2, Build 9200 

   Tiempo desde inicio: 36 sec
   Error ocurrido en: 25/09/2026, 13:03:56
   Descripción del error: Error BASE/1081  Error de argumento: +
   Argumentos:
     [   1] = B   {|| ... }
     [   2] = N   391

Pila de llamadas
================
   Llamado desde: C:\fwteam\source/classes/control.prg => (b)TCONTROL:TCONTROL( 211 )
   Llamado desde:  => TDOCKPNEL:_NHEIGHT( 0 )
   Llamado desde: C:\fwteam\source/internal/tdockpnel.prg => TDOCKPNEL:SETCOORS( 303 )
   Llamado desde: .\PRG\R32_arti.prg => PINFOARTICULO( 138 )
   Llamado desde: .\PRG\R32_arti.prg => R32_ARTI( 86 )
   Llamado desde: .\PRG\Alyma.prg => (b)TLYMA:AUTORIZA( 1746 )
   Llamado desde: .\PRG\Alyma.prg => TLYMA:AUTORIZA( 1746 )
   Llamado desde: .\PRG\R32_menu.prg => (b)VTNAPRINCIPAL( 771 )
   Llamado desde: C:\fwteam\source/classes/trbtn.prg => TRBTN:CLICK( 720 )
   Llamado desde: C:\fwteam\source/classes/trbtn.prg => TRBTN:LBUTTONUP( 876 )
   Llamado desde: C:\fwteam\source/classes/control.prg => TCONTROL:HANDLEEVENT( 1896 )
   Llamado desde: C:\fwteam\source/classes/trbtn.prg => TRBTN:HANDLEEVENT( 1575 )
   Llamado desde: C:\fwteam\source/classes/window.prg => _FWH( 1076 )
   Llamado desde:  => WINRUN( 0 )
   Llamado desde: C:\fwteam\source/classes/window.prg => TMDIFRAME:ACTIVATE( 1205 )
   Llamado desde: .\PRG\R32_menu.prg => VTNAPRINCIPAL( 1136 )
   Llamado desde: .\PRG\R32_menu.prg => MAIN( 127 )

Code: Select all | Expand

*********************************
*CATALOGO CON SALDOS DE ARTICULOS
*********************************
Function pInfoarticulo()
Local cFont         := "Liberation Mono"  

Local cFecIni := space(0)
Local cQry:=	"SELECT o_fechas FROM "+oLamcla:tMovi+" WHERE o_contro='II' AND YEAR(o_fechas)="+oLamcla:vGano+" LIMIT 0,1"
Local oConsCA := AdoExecute( oCnArt, { |oCn| FW_OPENRECORDSET(oCn,cQry,adLockOptimistic,adOpenKeyset) } )
Local nRegistros := oConsCA:RecordCount()
If nRegistros#0
	cFecIni := dtoc(oConsCA:Fields( "o_fechas" ):Value)
Else
	cFecIni := "01/01/"+alltrim(oLamcla:vGano)
Endif

DEFINE FONT oFont  NAME cFont SIZE 0,-11
DEFINE FONT oFontB NAME cFont SIZE 0,-14 BOLD     //ARIAL NARROW
DEFINE FONT oFont1 NAME cFont SIZE 0,-11 BOLD
DEFINE FONT oFontE NAME cFont SIZE 0,-14
DEFINE FONT oFont2 NAME cFont SIZE 0,-16
DEFINE FONT oFont3 NAME cFont SIZE 0,-20 //BOLD
DEFINE FONT oFont4 NAME "CALIBRI" SIZE 0,-16
DEFINE FONT oFontCtrl NAME cFont SIZE 0, -9 BOLD
DEFINE FONT oFontS NAME "FIXEDSYS" SIZE 0,-12

DEFINE WINDOW oWChArti MDICHILD TITLE "Catálogo Artículos" ICON "#8001" OF oWnd

   oDock1  := TDockPnel():New( oWChArti )
   WITH OBJECT oDock1
      :SetHeightCaption( 50 )
      :SetCoors( { | o | 10 }, ;
				 { | o | 10 }, ;
                 { | o | Int( o:oWnd:nHeight  ) - 50 }, ;
                 { | o | Int( o:oWnd:nWidth / 2 ) - XEVal( o:nLeft, o ) } )
      :SetCaption( { | o | "Saldos Acumulados Por Artículo" } )
      :SetColors( CLR_WHITE, Rgb( 0,120,215 ) , Rgb( 88, 88, 88 ), CLR_HGRAY )
      :SetFont( oFont4 )
      :lLeftImgs   := .F.
      :SetBorderSize( 4 )
      :SetCtrlsPnel( { | o, nT, nL, nH, nW, oB | oB := fSaldoArti( o, nT, nL, nH, nW ),;
						fCuentaPaginas(cGbsCta) } )
      :SetImgsFiles( { 	{ oLamcla:cIcoBcIm, { | o | ImprimirEtiquetas() }, "Imprimir etiquetas" } ,;
						{ oLamcla:cIcoCrB1, { | o | crearBloque() }, "Crear artículos en bloque tallas / colores" } ,;
						{ oLamcla:cIcoBcOr, { | o | crucecatalogoinventarios() }, "Cruce catálogo con movimiento año "+alltrim(oLamcla:vGano) } ,;
						{ oLamcla:cIcoBcIp, { | o | pImpArticu() }, "Importar Artículos" },;
						{ oLamcla:cIcoBcBr, { | o | eval(cbBorr) }, "Borrar Artículo" },;
						{ oLamcla:cIcoBcEd, { | o | eval(cbModi) }, "Modificar Artículo" },;
						{ oLamcla:cIcoBcAg, { | o | (manteArticu(0,oCnArt,oBrwAr,aArti),actArticuloArray()) }, "Agregar Artículo" } ;
					 } )	
      :bRClicked   := { || MsgInfo( oDock1:oWnd:aControls[ 1 ]:ClassName() ) }
      :Activate()
   END
 
   oDock2  := TDockPnel():New( oWChArti )
   WITH OBJECT oDock2
      :SetHeightCaption( 50 )
      :SetCoors( { | o | XEval( o:oWnd:aControls[ 1 ]:nTop, o ) }, ;
                 { | o | XEval( o:oWnd:aControls[ 1 ]:nRight, o ) + 10 }, ;
                 { | o | XEval( o:oWnd:aControls[ 1 ]:nBottom, o ) - 1 }, ;
                 { | o | Int( o:oWnd:nWidth / 2 ) + XEval( o:nLeft, o ) - 25 } )
	  :SetCaption( { | o | "Saldo Discriminado Mes"+CRLF+"Desde: 01/01/"+oLamcla:vGano+" - Hasta: 31/12/"+oLamcla:vGano } )
      :SetColors( CLR_WHITE, Rgb( 0,120,215 ) , Rgb( 88, 88, 88 ), CLR_HGRAY )
      :SetBorderSize( 4 )
      :SetFont( oFont4 )
      :lLeftImgs   := .F.
      :SetImgsFiles( { { oLamcla:cIcoBcCr, { | o | oWChArti:end() }, "Cerrar Ventana" } } )
      :SetCtrlsPnel( { | o, nT, nL, nH, nW, oB | oB := fDiscriArtiMes( o, nT, nL, nH, nW ) } )
      :Activate()
   END

   oBtArt:disable()

ACTIVATE WINDOW oWChArti MAXIMIZED ON INIT ( if(len(aArti)!=0,actualizamesarti(aArti[oBrwAr:nArrayAt]),),;
				navegapaginas(0),lCondicion:=.T. ) VALID(oBtArt:enable(),.t. ) 
Return nil

Code: Select all | Expand

oDock1:SetCoors( 10, 10, 390, 390 )
oDock2:SetCoors( 10, 400, 390, 780 )

Code: Select all | Expand

arbour
//********************************
// CATALOGO CON SALDOS DE ARTICULOS
//********************************

FUNCTION pInfoarticulo()

   LOCAL cFont      := "Liberation Mono"

   // --- Declarações LOCAL devem vir TODAS aqui (antes de código executável) ---
   LOCAL cFecIni    := ""
   LOCAL cQry       := ""
   LOCAL oConsCA    := NIL
   LOCAL nRegistros := 0
   LOCAL oDock1     := NIL
   LOCAL oDock2     := NIL

   LOCAL oFont, oFontB, oFont1, oFontE, oFont2, oFont3, oFont4, oFontCtrl, oFontS
   LOCAL oWChArti   := NIL

   // 1) Monta a query
   cQry := "SELECT o_fechas FROM " + oLamcla:tMovi + ;
           " WHERE o_contro='II' AND YEAR(o_fechas)=" + oLamcla:vGano + " LIMIT 0,1"

   // 2) Abre o recordset (forma tradicional do FW)
   oConsCA := FW_OpenRecordSet( oCnArt, cQry, adLockOptimistic, adOpenKeyset )

   IF oConsCA != NIL
      nRegistros := oConsCA:RecordCount()
      IF nRegistros != 0
         cFecIni := DToC( oConsCA:Fields( "o_fechas" ):Value )
      ELSE
         cFecIni := "01/01/" + AllTrim( oLamcla:vGano )
      ENDIF
      oConsCA:Close()
   ELSE
      cFecIni := "01/01/" + AllTrim( oLamcla:vGano )
   ENDIF

   // 3) Fontes
   DEFINE FONT oFont     NAME cFont      SIZE 0, -11
   DEFINE FONT oFontB    NAME cFont      SIZE 0, -14 BOLD
   DEFINE FONT oFont1    NAME cFont      SIZE 0, -11 BOLD
   DEFINE FONT oFontE    NAME cFont      SIZE 0, -14
   DEFINE FONT oFont2    NAME cFont      SIZE 0, -16
   DEFINE FONT oFont3    NAME cFont      SIZE 0, -20
   DEFINE FONT oFont4    NAME "CALIBRI"  SIZE 0, -16
   DEFINE FONT oFontCtrl NAME cFont      SIZE 0,  -9 BOLD
   DEFINE FONT oFontS    NAME "FIXEDSYS" SIZE 0, -12

   // 4) Janela MDI
   DEFINE WINDOW oWChArti MDICHILD TITLE "Catálogo Artículos" ICON "#8001" OF oWnd

   // ---------------- DOCK 1 ----------------
   oDock1 := TDockPnel():New( oWChArti )

   WITH OBJECT oDock1
      :SetHeightCaption( 50 )

  :SetCoors( { |o| 10 }, ;
             { |o| 10 }, ;
             { |o| Int( o:oWnd:nHeight ) - 50 }, ;
             { |o| Int( o:oWnd:nWidth / 2 ) - XEval( o:nLeft, o ) } )

  :SetCaption( { |o| "Saldos Acumulados Por Artículo" } )
  :SetColors( CLR_WHITE, RGB( 0,120,215 ), RGB( 88,88,88 ), CLR_HGRAY )
  :SetFont( oFont4 )
  :lLeftImgs := .F.
  :SetBorderSize( 4 )

  :SetCtrlsPnel( { |o, nT, nL, nH, nW, oB| ;
                     oB := fSaldoArti( o, nT, nL, nH, nW ), ;
                     fCuentaPaginas( cGbsCta ) } )

  :SetImgsFiles( { ;
     { oLamcla:cIcoBcIm, { || ImprimirEtiquetas() },                       "Imprimir etiquetas" }, ;
     { oLamcla:cIcoCrB1, { || crearBloque() },                             "Crear artículos en bloque tallas / colores" }, ;
     { oLamcla:cIcoBcOr, { || crucecatalogoinventarios() },                "Cruce catálogo con movimiento año " + AllTrim( oLamcla:vGano ) }, ;
     { oLamcla:cIcoBcIp, { || pImpArticu() },                              "Importar Artículos" }, ;
     { oLamcla:cIcoBcBr, { || Eval( cbBorr ) },                            "Borrar Artículo" }, ;
     { oLamcla:cIcoBcEd, { || Eval( cbModi ) },                            "Modificar Artículo" }, ;
     { oLamcla:cIcoBcAg, { || manteArticu( 0, oCnArt, oBrwAr, aArti ), ;
                              actArticuloArray() },                        "Agregar Artículo" } ;
  } )

  :bRClicked := { || MsgInfo( oDock1:oWnd:aControls[ 1 ]:ClassName() ) }

  :Activate()
   END

   // ---------------- DOCK 2 ----------------
   oDock2 := TDockPnel():New( oWChArti )

   WITH OBJECT oDock2
      :SetHeightCaption( 50 )

  :SetCoors( { |o| XEval( o:oWnd:aControls[ 1 ]:nTop,    o ) }, ;
             { |o| XEval( o:oWnd:aControls[ 1 ]:nRight,  o ) + 10 }, ;
             { |o| XEval( o:oWnd:aControls[ 1 ]:nBottom, o ) - 1 }, ;
             { |o| Int( o:oWnd:nWidth / 2 ) + XEval( o:nLeft, o ) - 25 } )

  :SetCaption( { |o| "Saldo Discriminado Mes" + CRLF + ;
                     "Desde: 01/01/" + oLamcla:vGano + ;
                     " - Hasta: 31/12/" + oLamcla:vGano } )
  :SetColors( CLR_WHITE, RGB( 0,120,215 ), RGB( 88,88,88 ), CLR_HGRAY )
  :SetBorderSize( 4 )
  :SetFont( oFont4 )
  :lLeftImgs := .F.

  :SetImgsFiles( { { oLamcla:cIcoBcCr, { || oWChArti:End() }, "Cerrar Ventana" } } )

  :SetCtrlsPnel( { |o, nT, nL, nH, nW, oB| ;
                     oB := fDiscriArtiMes( o, nT, nL, nH, nW ) } )

  :Activate()
   END

   oBtArt:Disable()

   // --------------- ATIVAÇÃO ---------------
   //  - ON INIT recebe UM ÚNICO bloco/expressão
   //  - VALID recebe UM ÚNICO bloco
   ACTIVATE WINDOW oWChArti MAXIMIZED ;
      ON INIT  ( If( Len( aArti ) != 0, ;
                     actualizamesarti( aArti[ oBrwAr:nArrayAt ] ), ;
                     Nil ), ;
                 navegapaginas( 0 ), ;
                 lCondicion := .T. ) ;
      VALID    ( oBtArt:Enable(), .T. )

RETURN nil

Code: Select all | Expand

//CATALOGO CON SALDOS DE ARTICULOS
//********************************

FUNCTION pInfoarticulo()

   // Declaración de variables locales del sistema e interfaz
   LOCAL cFont         := "Liberation Mono"
   LOCAL cFecIni       := space( 0 )
   LOCAL cQry, oConsCA, nRegistros
   

   // Declaración de Fuentes (Evita errores de compilación y limpia memoria)
   LOCAL oFont, oFontB, oFont1, oFontE, oFont2, oFont3, oFont4, oFontCtrl, oFontS
   

   // Declaración de Objetos de Ventana y Contenedores
   LOCAL oWChArti, oDock1, oDock2

   cQry       := "SELECT o_fechas FROM " + oLamcla:tMovi + " WHERE o_contro='II' AND YEAR(o_fechas)=" + oLamcla:vGano + " LIMIT 0,1"
   oConsCA    := AdoExecute( oCnArt, { |oCn| FW_OPENRECORDSET( oCn,cQry,adLockOptimistic,adOpenKeyset ) } )
   nRegistros := oConsCA:RecordCount()

   IF nRegistros # 0
      cFecIni := dtoc( oConsCA:Fields( "o_fechas" ):Value )
   ELSE
      cFecIni := "01/01/" + alltrim( oLamcla:vGano )
   ENDIF

   // Creación de Fuentes
   DEFINE FONT oFont  NAME cFont SIZE 0, - 11
   DEFINE FONT oFontB NAME cFont SIZE 0, - 14 BOLD     //ARIAL NARROW
   DEFINE FONT oFont1 NAME cFont SIZE 0, - 11 BOLD
   DEFINE FONT oFontE NAME cFont SIZE 0, - 14
   DEFINE FONT oFont2 NAME cFont SIZE 0, - 16
   DEFINE FONT oFont3 NAME cFont SIZE 0, - 20 //BOLD
   DEFINE FONT oFont4 NAME "CALIBRI" SIZE 0, - 16
   DEFINE FONT oFontCtrl NAME cFont SIZE 0, - 9 BOLD
   DEFINE FONT oFontS NAME "FIXEDSYS" SIZE 0, - 12

   DEFINE WINDOW oWChArti MDICHILD TITLE "Catálogo Artículos" ICON "#8001" OF oWnd

   oDock1  := TDockPnel():New( oWChArti )

   WITH OBJECT oDock1

  :SetHeightCaption( 50 )

  // CORREGIDO: Se cambió XEVal por XEval
  :SetCoors( { | o | 10 }, ;
     { | o | 10 }, ;
     { | o | Int( o:oWnd:nHeight  ) - 50 }, ;
     { | o | Int( o:oWnd:nWidth / 2 ) - XEval( o:nLeft, o ) } )

  :SetCaption( { | o | "Saldos Acumulados Por Artículo" } )

  :SetColors( CLR_WHITE, Rgb( 0,120,215 ) , Rgb( 88, 88, 88 ), CLR_HGRAY )
  :SetFont( oFont4 )
  :lLeftImgs   := .F.
  :SetBorderSize( 4 )
  :SetCtrlsPnel( { | o, nT, nL, nH, nW, oB | oB := fSaldoArti( o, nT, nL, nH, nW ), ;
     fCuentaPaginas( cGbsCta ) } )

  :SetImgsFiles( {  { oLamcla:cIcoBcIm, { | o | ImprimirEtiquetas() }, "Imprimir etiquetas" } , ;
     { oLamcla:cIcoCrB1, { | o | crearBloque() }, "Crear artículos en bloque tallas / colores" } , ;
     { oLamcla:cIcoBcOr, { | o | crucecatalogoinventarios() }, "Cruce catálogo con movimiento año " + alltrim( oLamcla:vGano ) } , ;
     { oLamcla:cIcoBcIp, { | o | pImpArticu() }, "Importar Artículos" }, ;
     { oLamcla:cIcoBcBr, { | o | eval( cbBorr ) }, "Borrar Artículo" }, ;
     { oLamcla:cIcoBcEd, { | o | eval( cbModi ) }, "Modificar Artículo" }, ;
     { oLamcla:cIcoBcAg, { | o | ( manteArticu( 0,oCnArt,oBrwAr,aArti ),actArticuloArray() ) }, "Agregar Artículo" } ;
     } )

  :bRClicked   := { || MsgInfo( oDock1:oWnd:aControls[ 1 ]:ClassName() ) }

  :Activate()

   END
 
   oDock2  := TDockPnel():New( oWChArti )

   WITH OBJECT oDock2

  :SetHeightCaption( 50 )

  :SetCoors( { | o | XEval( o:oWnd:aControls[ 1 ]:nTop, o ) }, ;
     { | o | XEval( o:oWnd:aControls[ 1 ]:nRight, o ) + 10 }, ;
     { | o | XEval( o:oWnd:aControls[ 1 ]:nBottom, o ) - 1 }, ;
     { | o | Int( o:oWnd:nWidth / 2 ) + XEval( o:nLeft, o ) - 25 } )

  :SetCaption( { | o | "Saldo Discriminado Mes" + CRLF + "Desde: 01/01/" + oLamcla:vGano + " - Hasta: 31/12/" + oLamcla:vGano } )
  :SetColors( CLR_WHITE, Rgb( 0,120,215 ) , Rgb( 88, 88, 88 ), CLR_HGRAY )
  :SetBorderSize( 4 )
  :SetFont( oFont4 )
  :lLeftImgs   := .F.
  :SetImgsFiles( { { oLamcla:cIcoBcCr, { | o | oWChArti:end() }, "Cerrar Ventana" } } )
  :SetCtrlsPnel( { | o, nT, nL, nH, nW, oB | oB := fDiscriArtiMes( o, nT, nL, nH, nW ) } )

  :Activate()

   END

   oBtArt:disable()

   // CORREGIDO: Se agregaron los :End() de las fuentes en el VALID para liberar recursos GDI
   ACTIVATE WINDOW oWChArti MAXIMIZED ;
      ON INIT ( if( len(aArti ) != 0,actualizamesarti(aArti[oBrwAr:nArrayAt] ), ), ;
         navegapaginas( 0 ), lCondicion := .T. ) ;
      VALID ( oBtArt:enable(), ;
              oFont:End(), oFontB:End(), oFont1:End(), oFontE:End(), ;
              oFont2:End(), oFont3:End(), oFont4:End(), oFontCtrl:End(), oFontS:End(), ;
              .T. )

RETURN nil

Code: Select all | Expand

#include "FiveWin.ch"
#include "ado.ch"

// Declaração de variáveis visíveis externamente (evita avisos Ambiguous Reference)
MEMVAR oLamcla, oCnArt, oWnd, cGbsCta, cbBorr, cbModi, oBrwAr, aArti, oBtArt, lCondicion

//----------------------------------------------------------------------------//
// CATALOGO CON SALDOS DE ARTICULOS
//----------------------------------------------------------------------------//

FUNCTION pInfoarticulo()

   // Declaración de variables locales del sistema e interfaz
   LOCAL cFont         := "Liberation Mono"
   LOCAL cYear         := ""
   LOCAL cFecIni       := ""
   LOCAL cQry          := ""
   LOCAL oConsCA       := NIL
   LOCAL uVal          := NIL
   

   // Declaración de Fuentes (Limpieza de memoria y recursos GDI)
   // NOTA: Si fSaldoArti o fDiscriArtiMes usan estas fuentes, deben declararse
   // como STATIC al inicio del archivo .prg.
   LOCAL oFont, oFontB, oFont1, oFontE, oFont2, oFont3, oFont4, oFontCtrl, oFontS
   

   // Declaración de Objetos de Ventana y Contenedores
   LOCAL oWChArti, oDock1, oDock2

   // Asegurar que el año sea tipo caracter seguro para SQL y concatenación
   IF oLamcla != NIL .AND. !Empty( oLamcla:vGano )
      cYear := AllTrim( cValToChar( oLamcla:vGano ) )
   ELSE
      cYear := AllTrim( Str( Year( Date() ) ) )
   ENDIF

   // Valor por defecto de fecha inicial
   cFecIni := "01/01/" + cYear

   // Consulta SQL protegida contra fallos de conexión o valores NULL
   IF oCnArt != NIL .AND. oLamcla != NIL
      cQry := "SELECT o_fechas FROM " + oLamcla:tMovi + ;
              " WHERE o_contro='II' AND YEAR(o_fechas)=" + cYear + " LIMIT 0,1"

  TRY
     oConsCA := AdoExecute( oCnArt, { |oCn| FW_OPENRECORDSET( oCn, cQry, adLockOptimistic, adOpenKeyset ) } )
  CATCH
     oConsCA := NIL
  END

  IF oConsCA != NIL
     IF !oConsCA:Eof() .AND. oConsCA:RecordCount() != 0
        uVal := oConsCA:Fields( "o_fechas" ):Value
        DO CASE
        CASE ValType( uVal ) == "D"
           cFecIni := DToC( uVal )
        #ifdef __HARBOUR__
        CASE ValType( uVal ) == "T"
           cFecIni := DToC( hb_TToD( uVal ) )
        #endif
        CASE ValType( uVal ) == "C" .AND. !Empty( uVal )
           cFecIni := uVal
        ENDCASE
     ENDIF
     TRY
        oConsCA:Close()
     CATCH
     END
  ENDIF
   ENDIF

   // Creación de Fuentes
   DEFINE FONT oFont     NAME cFont      SIZE 0, - 11
   DEFINE FONT oFontB    NAME cFont      SIZE 0, - 14 BOLD     // ARIAL NARROW
   DEFINE FONT oFont1    NAME cFont      SIZE 0, - 11 BOLD
   DEFINE FONT oFontE    NAME cFont      SIZE 0, - 14
   DEFINE FONT oFont2    NAME cFont      SIZE 0, - 16
   DEFINE FONT oFont3    NAME cFont      SIZE 0, - 20
   DEFINE FONT oFont4    NAME "CALIBRI"  SIZE 0, - 16
   DEFINE FONT oFontCtrl NAME cFont      SIZE 0, - 9  BOLD
   DEFINE FONT oFontS    NAME "FIXEDSYS" SIZE 0, - 12

   DEFINE WINDOW oWChArti MDICHILD TITLE "Catálogo Artículos" ICON "#8001" OF oWnd

   oDock1 := TDockPnel():New( oWChArti )

   WITH OBJECT oDock1

  :SetHeightCaption( 50 )

  :SetCoors( { || 10 }, ;
             { || 10 }, ;
             { | o | Int( o:oWnd:nHeight ) - 50 }, ;
             { | o | Int( o:oWnd:nWidth / 2 ) - XEval( o:nLeft, o ) } )

  :SetCaption( { || "Saldos Acumulados Por Artículo" } )

  :SetColors( CLR_WHITE, Rgb( 0, 120, 215 ), Rgb( 88, 88, 88 ), CLR_HGRAY )
  :SetFont( oFont4 )
  :lLeftImgs   := .F.
  :SetBorderSize( 4 )

  :SetCtrlsPnel( { | o, nT, nL, nH, nW, oB | ;
     oB := fSaldoArti( o, nT, nL, nH, nW ), ;
     fCuentaPaginas( cGbsCta ) } )

  :SetImgsFiles( { ;
     { oLamcla:cIcoBcIm, { || ImprimirEtiquetas() }, "Imprimir etiquetas" }, ;
     { oLamcla:cIcoCrB1, { || crearBloque() }, "Crear artículos en bloque tallas / colores" }, ;
     { oLamcla:cIcoBcOr, { || crucecatalogoinventarios() }, "Cruce catálogo con movimiento año " + cYear }, ;
     { oLamcla:cIcoBcIp, { || pImpArticu() }, "Importar Artículos" }, ;
     { oLamcla:cIcoBcBr, { || If( cbBorr != NIL, Eval( cbBorr ), NIL ) }, "Borrar Artículo" }, ;
     { oLamcla:cIcoBcEd, { || If( cbModi != NIL, Eval( cbModi ), NIL ) }, "Modificar Artículo" }, ;
     { oLamcla:cIcoBcAg, { || ( manteArticu( 0, oCnArt, oBrwAr, aArti ), actArticuloArray() ) }, "Agregar Artículo" } ;
  } )

  :Activate()

   END
 
   oDock2 := TDockPnel():New( oWChArti )

   WITH OBJECT oDock2

  :SetHeightCaption( 50 )

  // Coordenadas calculadas respecto a oDock1 de forma segura
  :SetCoors( { | o | XEval( oDock1:nTop, o ) }, ;
             { | o | XEval( oDock1:nRight, o ) + 10 }, ;
             { | o | XEval( oDock1:nBottom, o ) - 1 }, ;
             { | o | Int( o:oWnd:nWidth ) - 25 } )

  // Ahora utiliza la fecha real cFecIni obtenida de la base de datos
  :SetCaption( { || "Saldo Discriminado Mes" + CRLF + ;
                    "Desde: " + cFecIni + " - Hasta: 31/12/" + cYear } )
  :SetColors( CLR_WHITE, Rgb( 0, 120, 215 ), Rgb( 88, 88, 88 ), CLR_HGRAY )
  :SetBorderSize( 4 )
  :SetFont( oFont4 )
  :lLeftImgs   := .F.
  :SetImgsFiles( { { oLamcla:cIcoBcCr, { || oWChArti:End() }, "Cerrar Ventana" } } )
  :SetCtrlsPnel( { | o, nT, nL, nH, nW, oB | oB := fDiscriArtiMes( o, nT, nL, nH, nW ) } )

  :Activate()

   END

   // Desactivar el botón llamador si está definido
   IF oBtArt != NIL
      oBtArt:Disable()
   ENDIF

   // Activación de la ventana MDI Child
   ACTIVATE WINDOW oWChArti MAXIMIZED ;
      ON INIT ( If( !Empty( aArti ) .AND. oBrwAr != NIL .AND. oBrwAr:nArrayAt > 0 .AND. oBrwAr:nArrayAt <= Len( aArti ), ;
                    actualizamesarti( aArti[ oBrwAr:nArrayAt ] ), NIL ), ;
                navegapaginas( 0 ), lCondicion := .T. ) ;
      VALID ( If( oBtArt != NIL, oBtArt:Enable(), NIL ), ;
              AEval( { oFont, oFontB, oFont1, oFontE, oFont2, oFont3, oFont4, oFontCtrl, oFontS }, ;
                     { | oF | If( oF != NIL, oF:End(), NIL ) } ), ;
              .T. )

RETURN nil

Code: Select all | Expand

set FWPRNLOG=1
miapp.exe