ICIM functions to replace PageScript

[Badara Thiam]

Hello every Body who practice solidarity,

Here is a set of functions i began to create in 2005, to replace integraly the same functions
of Pagescript than i used when i worked for mister DOS. These functions work very nice,
but if you have any suggest to me, don't private you !

The "out on .pdf" is not implemented today, but you can already use this in waiting.

Code: Select all  Expand view

***********************************************************************************
****** ICImprim.PRG ***************************************************************
***********************************************************************************
****** Creation le 04/01/2005
****** Derniere modification le 12/10/2013 à 21:30:08
****** Auteur : Badara THIAM
****** Description : fonctions remplaçant la plupart des fonctions équivalentes de PageScript
****** Aujourd'hui ces fonctions ne gèrent pas l'impression directe dans un fichier .pdf mais Badara THIAM
****** souhaite inclure le code nécessaire à chaque fonction dans un proche avenir, si les fonctions
****** disponibles sous (x)Harbour le permettent
***********************************************************************************

#include  "fivewin.ch"

#IFNDEF __XPP__

    #define  HKEY_CLASSES_ROOT       2147483648        // 0x80000000
    #define  HKEY_CURRENT_USER       2147483649        // 0x80000001
    #define  HKEY_LOCAL_MACHINE      2147483650        // 0x80000002
    #define  HKEY_USERS              2147483651        // 0x80000003
    #define  HKEY_PERFORMANCE_DATA   2147483652        // 0x80000004
    #define  HKEY_CURRENT_CONFIG     2147483653        // 0x80000005
    #define  HKEY_DYN_DATA           2147483654        // 0x80000006

#ELSE

   #define  HKEY_CLASSES_ROOT       1
   #define  HKEY_CURRENT_USER       2
   #define  HKEY_LOCAL_MACHINE      3
   #define  HKEY_USERS              4
   #define  HKEY_PERFORMANCE_DATA   5
   #define  HKEY_CURRENT_CONFIG     6
   #define  HKEY_DYN_DATA           7

#ENDIF

// Registry Specific Access Rights.

#define KEY_QUERY_VALUE         1    // 0x0001
#define KEY_SET_VALUE           2    // 0x0002
#define KEY_CREATE_SUB_KEY      4    // 0x0004
#define KEY_ENUMERATE_SUB_KEYS  8    // 0x0008
#define KEY_NOTIFY              16   // 0x0010
#define KEY_CREATE_LINK         32   // 0x0020


/* device capabilities indices */
#define DC_FIELDS           1
#define DC_PAPERS           2
#define DC_PAPERSIZE        3
#define DC_MINEXTENT        4
#define DC_MAXEXTENT        5
#define DC_BINS             6
#define DC_DUPLEX           7
#define DC_SIZE             8
#define DC_EXTRA            9
#define DC_VERSION          10
#define DC_DRIVER           11
#define DC_BINNAMES         12
#define DC_ENUMRESOLUTIONS  13
#define DC_FILEDEPENDENCIES 14
#define DC_TRUETYPE         15
#define DC_PAPERNAMES       16
#define DC_ORIENTATION      17
#define DC_COPIES           18


#define SRCCOPY        13369376    // 0x00CC0020L
#define SRCPAINT    15597702    // 0x00EE0086L

STATIC oPrn
STATIC oFont
STATIC nPage
STATIC nCOPIE
STATIC lASSEMBLER
STATIC lINVERSER
STATIC HDCFW

*******************
FUNCTION PSREFRESHP()
*******************
* OK
RETURN NIL

***************
FUNCTION PSINIT()
***************
RETURN 0

***********************
FUNCTION PSSETTIMESLICE()
***********************
* OK
RETURN NIL

*******************
FUNCTION PSSETDECIM()
*******************
* OK
RETURN NIL

*******************
FUNCTION PSGETFONTS(NIMP)
*******************
* Liste des fontes disponibles pour l'imprimante Nø NIMP
RETURN {}

*******************
FUNCTION PSGETPRINTERS()
*******************
* retourne la liste des imprimantes disponibles sous windows depuis le poste de travail courant
* Recherche dans le fichier WIN.INI si rien dans le registre de Windows
LOCAL TIMP := {}
LOCAL REPWIN := GETREPWIN()
LOCAL NOTES
LOCAL NOTLIG
IF !EMPTY(REPWIN)

  TIMP := WinGetPrn()

  IF LEN(TIMP) = 0 .AND. ( " " + cWinVersion() + " " $ " 95 98 " )

    NOTES := FileToMemo(REPWIN + "\WIN.INI")
    IF !EMPTY(NOTES)
      NOTES := ANSIASCI(NOTES)
      IF "[DEVICES]" $ MAJ(NOTES)
        NOTES := SUBSTR(NOTES, AT("[DEVICES]", MAJ(NOTES)) )
        IF CRLF $ NOTES
          NOTES := SUBSTR(NOTES, AT(CRLF, NOTES) + LEN(CRLF))
          DO WHILE !EMPTY(NOTES)
            IF CRLF $ NOTES
              NOTLIG := LEFT(NOTES, AT(CRLF, NOTES)-1)
              NOTES := SUBSTR(NOTES, AT(CRLF, NOTES) + LEN(CRLF))
            ELSE
              NOTLIG := NOTES
              NOTES := ""
            ENDIF
            IF LEFT(LTRIM(NOTLIG), 1)  == "["
              EXIT
            ELSEIF !EMPTY(NOTLIG)
              AADD(TIMP, LEFT(NOTLIG, AT("=",NOTLIG) - 1) )
            ENDIF
          ENDDO
        ENDIF
      ENDIF
    ENDIF
  ENDIF
ENDIF
RETURN ACLONE( TIMP )

******************
FUNCTION WinGetPrn( lOrigine )
******************
* Recherche les imprimantes installées sous windows dans le registre de Windows
* Auteur Badara Thiam

LOCAL lSetExact := SET( _SET_EXACT, .T. )
LOCAL TIMP := {}
LOCAL cValue
LOCAL n1
LOCAL n2
LOCAL nok
LOCAL nLen
LOCAL cSubkeys
LOCAL nHKey := HKEY_LOCAL_MACHINE
LOCAL TSERVEURS := {}
LOCAL X
LOCAL oReg
LOCAL oRegSubK

* Recherche des imprimantes disponibles depuis le poste courant
cSubKeys := "System\CurrentControlSet\Control\Print\Printers"

oReg := TReg32():New( nHKey, cSubKeys, , KEY_ENUMERATE_SUB_KEYS )
IF oReg:nError = 0
    n1 := 0
    DO WHILE .T.
      cValue := ""
      n2 := RegEnumKey( oReg:nHandle, n1,  @cvalue  )
      SysRefresh()
      IF n2 = 0
        IF ASCAN(TIMP, STRTRAN(cValue, "," , "\")) = 0
          SysRefresh()
          AADD(TIMP, STRTRAN(cValue, "," , "\"))
        ENDIF
      ELSE
        EXIT
      ENDIF
      n1 ++
    ENDDO
    SysRefresh()
    oReg:Close()
ENDIF


* Recherche des imprimantes réseau non répertoriées dans la clé précédente (ci-dessus)
* Ajouté le 20/10/2006
TSERVEURS := WinGetSP()

* Recherche des imprimantes non répertoriées dans les clés prédédentes (cas avec Windows 7 et peut-être suivants)
* Ajouté le 14/04/2013
cSubKeys := "Printers\Connections"
nHKey := HKEY_CURRENT_USER

oReg := TReg32():New( nHKey, cSubKeys, , KEY_ENUMERATE_SUB_KEYS )
IF oReg:nError = 0
    n1 := 0
    DO WHILE .T.
      cValue := ""
      n2 := RegEnumKey( oReg:nHandle, n1,  @cvalue  )
      SysRefresh()
      IF n2 = 0
        IF ASCAN(TIMP, STRTRAN(cValue, "," , "\")) = 0
          SysRefresh()
          AADD(TIMP, STRTRAN(cValue, "," , "\"))
        ENDIF
      ELSE
        EXIT
      ENDIF
      n1 ++
    ENDDO
    SysRefresh()
    oReg:Close()
ENDIF


nHKey := HKEY_LOCAL_MACHINE

IF !EMPTY(TSERVEURS)
  FOR X := 1 TO LEN(TSERVEURS)
    cSubKeys := TSERVEURS[X][2] + "\" + TSERVEURS[X][1] + "\Printers"

    oRegSubK := TReg32():New( TSERVEURS[X][3], cSubKeys, , KEY_ENUMERATE_SUB_KEYS )
    IF oRegSubK:nError = 0
      n1 := 0
      DO WHILE .T.
        cValue := ""
        n2 := RegEnumKey( oRegSubK:nHandle, n1,  @cvalue  )
        SysRefresh()
        IF n2 = 0

          * Pour vista : le nom d'imprimante (sous précédents os) est le port, codé avec "{" et "}"
          IF EMPTY( lOrigine ) .AND. ( "{" $ cValue )
            oReg := TReg32():New( TSERVEURS[X][3], TSERVEURS[X][2] + "\" + TSERVEURS[X][1] + "\Printers" ;
            + "\" + cValue + "\PrinterDriverData", , KEY_QUERY_VALUE )
            IF oReg:nError = 0
              cValue := oReg:Get("Model", "")
            ENDIF
            oReg:Close()
          ENDIF
          IF ASCAN(TIMP, STRTRAN(cValue, "," , "\")) = 0
            IF "," $ cValue
              AADD(TIMP, STRTRAN(cValue, "," , "\"))
            ELSE
              AADD(TIMP, "\\" + TSERVEURS[X][1] + "\" + cValue)
            ENDIF
          ENDIF
          SysRefresh()
        ELSE
          EXIT
        ENDIF
        n1 ++
      ENDDO
      oRegSubK:Close()

    ENDIF
    SysRefresh()
  NEXT X

ENDIF

SET( _SET_EXACT, lSetExact )
RETURN ACLONE(TIMP)

*****************
FUNCTION WinGetSP()
*****************
* Renvoie un tableau dont chaque élément est un tableau contenant
* 1 : les noms des serveurs d'impression disponibles pour le poste courant
* 2 : la sous-clé dans le registre Windows où est localisée l'information concernant le serveur
* 3 : clé dans le registre Windows où est localisée l'information concernant le serveur
* Auteur Badara Thiam

LOCAL lSetExact := SET( _SET_EXACT, .T. )
LOCAL cValue
LOCAL n1
LOCAL n2
LOCAL cSubkeys
LOCAL nHKey
LOCAL TSERVEURS := {}
LOCAL nSubK := 0
LOCAL oReg

DO WHILE .T.
  nSubK ++
  IF nSubK = 1
    nHKey := HKEY_LOCAL_MACHINE
    cSubKeys := "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Print\Providers\LanMan Print Services\Servers"
  ELSEIF nSubK = 2
    * Sous Vista version premium familiale et Windows 7
    nHKey := HKEY_LOCAL_MACHINE
    cSubKeys := "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Print\Providers\Client Side Rendering Print Provider\Servers"
  ELSE
    EXIT
  ENDIF

  oReg := TReg32():New( nHKey, cSubKeys, , KEY_ENUMERATE_SUB_KEYS )
  IF oReg:nError = 0

    * Recherche des serveurs accessibles
    n1 := 0
    DO WHILE .T.
      cValue := ""
      n2 := RegEnumKey( oReg:nHandle, n1,  @cvalue  )
      SysRefresh()
      IF n2 = 0
        IF ASCAN(TSERVEURS, { ¦qelem¦ qelem[1] = cValue } ) = 0
          AADD(TSERVEURS, ACLONE( { cValue, cSubKeys, nHKey } ) )
        ENDIF
      ELSE
        EXIT
      ENDIF
      SysRefresh()
      n1 ++
    ENDDO
    oReg:Close()
  ENDIF
ENDDO
SET( _SET_EXACT, lSetExact )
RETURN ACLONE(TSERVEURS)

*******************
FUNCTION WinGetSerP()
*******************
* Renvoie dans un tableau les noms des serveurs d'impression disponibles pour le poste courant
* Auteur Badara Thiam
LOCAL N
LOCAL TSERVEURS := WinGetSP()
LOCAL aServeurs := {}
FOR N := 1 TO LEN(TSERVEURS)
  AADD( aServeurs, TSERVEURS[N][1] )
NEXT N
RETURN ACLONE(aServeurs)


*******************
FUNCTION WinGetPrnD(cNomDriver)
*******************
* Recherche le driver d'une imprimante installée sous windows
* dans le registre de Windows (remplace le WIN.INI qui est obsolète sous Windows 2000 et suivants)
* Auteur Badara THIAM

LOCAL lSetExact := SET( _SET_EXACT, .T. )
LOCAL cValue
LOCAL n1
LOCAL n2
LOCAL nok
LOCAL nLen
LOCAL cSubkeys
LOCAL cSubkeys2
LOCAL cSubkeys3
LOCAL X, X2
LOCAL XENV
LOCAL TENV := {}
LOCAL TVERDRIVER := {}
LOCAL oReg
LOCAL nHKey
LOCAL cDriver := ""

X := 0
DO WHILE EMPTY(cDriver)

  X ++
  TENV := {}
  TVERDRIVER := {}
  cDriver := ""

  IF X = 1
    cSubKeys := "System\CurrentControlSet\Control\Print\Environments"
    nHKey := HKEY_LOCAL_MACHINE
  ELSEIF X = 2
    cSubKeys := "System\ControlSet001\Control\Print\Environments"
    nHKey := HKEY_LOCAL_MACHINE
  ELSEIF X = 3
    cSubKeys := "System\ControlSet002\Control\Print\Environments"
    nHKey := HKEY_LOCAL_MACHINE
  ELSE
    EXIT
  ENDIF

  oReg := TReg32():New(nHKey, cSubKeys, , KEY_ENUMERATE_SUB_KEYS )
  IF oReg:nError = 0
      * Stocke tous les sous chemins de ..\Environments
      * dans le tableau TENV, pour analyse le contenu de chaque "environment"
      SysRefresh()
      n1 := 0
      DO WHILE .T.
        cValue := ""
        n2 := RegEnumKey( oReg:nHandle, n1,  @cvalue  )
        IF n2 = 0
          IF ASCAN(TENV, STRTRAN(cValue, "," , "\")) = 0
            AADD(TENV, STRTRAN(cValue, "," , "\"))
          ENDIF
        ELSE
          EXIT
        ENDIF
        n1 ++
        SysRefresh()
      ENDDO
      oReg:Close()
      SysRefresh()
  ENDIF

  FOR XENV := 1 TO LEN(TENV)
    cSubKeys2 := cSubKeys + "\" + TENV[XENV] + "\Drivers"
    cSubKeys3 := cSubKeys2 + "\" + cNomDriver

    oReg := TReg32():New(nHKey, cSubKeys3, , KEY_QUERY_VALUE)

    IF oReg:nError = 0
    * Si le nom de l'imprimante est présent dans le chemin ..\Drivers
      cDriver := oReg:Get("Driver", "")
      oReg:Close()
      oReg := NIL

      IF !EMPTY(cDriver)
        cDriver := IIF("." $ cDriver, LEFT(cDriver, AT(".", cDriver) - 1), cDriver)
        EXIT
      ENDIF
    ELSE

      oReg:Close()
      oReg := NIL

      oReg := TReg32():New(nHKey, cSubKeys2, , KEY_ENUMERATE_SUB_KEYS )
      IF oReg:nError = 0

        n1 := 0
        TVERDRIVER := {}
        DO WHILE .T.
          cValue := ""
          n2 := RegEnumKey( oReg:nHandle, n1,  @cvalue  )
          IF n2 = 0
            IF ASCAN(TVERDRIVER, STRTRAN(cValue, "," , "\")) = 0
              AADD(TVERDRIVER, STRTRAN(cValue, "," , "\"))
            ENDIF
          ELSE
            EXIT
          ENDIF
          SysRefresh()
          n1 ++
        ENDDO
        oReg:Close()
        SysRefresh()

        FOR X2 := 1 TO LEN(TVERDRIVER)

          cSubKeys3 := cSubKeys2 + "\" + TVERDRIVER[X2] + "\" + cNomDriver

          oReg := TReg32():New(nHKey, cSubKeys3, , KEY_QUERY_VALUE)

          IF oReg:nError = 0

            cDriver := oReg:Get("Driver", "")
            SysRefresh()
            oReg:Close()
            oReg := NIL
            IF !EMPTY(cDriver)
              cDriver := IIF("." $ cDriver, LEFT(cDriver, AT(".", cDriver) - 1), cDriver)
              EXIT
            ENDIF
          ELSE
            oReg:Close()
            oReg := NIL
          ENDIF
          SysRefresh()

        NEXT X2
        IF !EMPTY(cDriver)
          EXIT
        ENDIF
      ENDIF
    ENDIF
    SysRefresh()
  NEXT XENV

ENDDO

SysRefresh()
SET( _SET_EXACT, lSetExact )
RETURN cDriver

*******************
FUNCTION WinGetPrnP(cNomImpr)
*******************
* Renvoie le (nom du fichier) Driver et le Port de l'imprimante dont le nom est le contenu de cNomImpr.
* Le Driver et le Port sont renvoyés dans une chaine, séparés par une virgule.
* Auteur Badara THIAM

LOCAL lSetExact := SET( _SET_EXACT, .T. )
LOCAL cDriver := ""
LOCAL cNomDriver := ""
LOCAL cPort := ""
LOCAL oReg
LOCAL X
LOCAL Y
LOCAL TIMP := WinGetPrn()
LOCAL TImpOrig := WinGetPrn(.T.)
LOCAL TSERVEURS := {}

* Recherche l'imprimante Windows ayant le même nom,
* en convertissant en minuscule et en supprimant les espaces
FOR X := 1 TO LEN(TIMP)
  IF MEMEIMPRIM(@cNomImpr, TIMP[X])
  * Si c'est la même imprimante
    EXIT
  ENDIF
NEXT X

IF X <= LEN(TIMP)

  IF "\" $ TIMP[X] .AND. TIMP[X] != TImpOrig[X]
  * Si imprimante réseau

    TSERVEURS := WinGetSP()

    FOR Y := 1 TO LEN(TSERVEURS)
        oReg := TReg32():New( TSERVEURS[Y][3], TSERVEURS[Y][2] ;
        + "\" + TSERVEURS[Y][1] + "\Printers\" + SUBSTR(TImpOrig[X], RAT("\",TImpOrig[X]) + 1) ;
        + "\DsSpooler", , KEY_QUERY_VALUE )
        IF oReg:nError = 0
          EXIT
        ENDIF
        oReg:Close()
        oReg := NIL
    NEXT Y

    IF oReg != NIL
      IF oReg:nError = 0
        cPort := oReg:Get("portName", "")
        cNomDriver := oReg:Get("driverName", "")
      ENDIF
      oReg:Close()
      oReg := NIL
    ENDIF

  ELSE
    oReg := TReg32():New(HKEY_LOCAL_MACHINE,;
   "System\CurrentControlSet\Control\Print\Printers\" + STRTRAN(TIMP[X],"\",","), , KEY_QUERY_VALUE)

    IF oReg:nError <> 0

      * Cherche si cette imprimante non répertoriée est en réseau (10/2006)
      oReg:Close()
      oReg := NIL
      TSERVEURS := WinGetSP()

      FOR Y := 1 TO LEN(TSERVEURS)

        oReg := TReg32():New( TSERVEURS[Y][3], TSERVEURS[Y][2] ;
        + "\" + TSERVEURS[Y][1] + "\Printers\" + STRTRAN(TIMP[X],"\",","), , KEY_QUERY_VALUE)

        IF oReg:nError = 0
          EXIT
        ELSEIF "\" $ TIMP[X]
          * Si "\" est présent dans le nom d'imprimante, c'est "peut-être" la fonction WinGetPrn()
          * qui a inséré le nom de serveur dans le nom d'imprimante. Pour le vérifier,
          * recherche également le nom de l'imprimante sans le nom de serveur
          oReg:Close()
          oReg := NIL
          oReg := TReg32():New( TSERVEURS[Y][3], TSERVEURS[Y][2] ;
          + "\" + TSERVEURS[Y][1] + "\Printers\" + SUBSTR(TIMP[X], RAT("\",TIMP[X]) + 1 ), , KEY_QUERY_VALUE )
          IF oReg:nError = 0
            EXIT
          ENDIF
        ENDIF
        oReg:Close()
        oReg := NIL
      NEXT Y

    ENDIF

    IF oReg != NIL
      IF oReg:nError = 0
        cPort := oReg:Get("Port", "")
        cNomDriver := oReg:Get("Printer Driver", "")
      ENDIF
      oReg:Close()
      oReg := NIL
    ENDIF

  ENDIF

  IF cNomDriver != ""
    cDriver := WinGetPrnD( STRTRAN(cNomDriver, CHR(0), "") )
  ENDIF

ENDIF
SET( _SET_EXACT, lSetExact )
RETURN cDriver + "," + cPort

******************
FUNCTION WinDefPrn()
******************
* Dernière modification le 17/11/2006
* Retourne le nom de l'imprimante par défaut en allant le chercher dans le registre Windows
* (regedit.exe)
LOCAL cDefPrn := ""
* Adresse dans le registre pour Windows 2000 et suivants
LOCAL oReg := TReg32():New(HKEY_CURRENT_USER, "Software\Microsoft\Windows NT\CurrentVersion\Windows", , KEY_QUERY_VALUE)
IF oReg:nError = 0
  cDefPrn := oReg:Get("Device", "")
  IF "," $ cDefPrn
    * Suppression du Pilote et du Port, non requis ici
    cDefPrn := LEFT(cDefPrn, AT(",",cDefPrn) -1)
  ENDIF
ELSE
  * Alternative pour Windows 9x et Millennium
  oReg:Close()
  oReg := NIL
  oReg := TReg32():New(HKEY_CURRENT_CONFIG, "System\CurrentControlSet\Control\Print\Printers", , KEY_QUERY_VALUE)
  IF oReg:nError = 0
    cDefPrn := oReg:Get("Default", "")
  ENDIF
ENDIF
oReg:Close()
oReg := NIL
RETURN cDefPrn

*******************
FUNCTION PSGETDEFPR()
*******************
* Imprimante par défaut
* Retourne le numéro d'élément, dans le tableau des imprimantes retourné par PSGETPRINTERS()
LOCAL REPWIN := GETREPWIN()
LOCAL NOTES := ""
LOCAL nRet := 0
IF !EMPTY(REPWIN)
  * Cherche d'abord dans le registre Windows
  NOTES := WINDEFPRN()
  IF EMPTY(NOTES) .AND. ( " " + cWinVersion() + " " $ " 95 98 " )
  * Si introuvable dans le registre windows et version de windows compatible avec WIN.INI
    NOTES := FileToMemo(REPWIN + "\WIN.INI")
    IF !EMPTY(NOTES)
      NOTES := ANSIASCI(NOTES)
      IF "DEVICE=" $ MAJ(NOTES)
        NOTES := SUBSTR(NOTES, AT("DEVICE=", MAJ(NOTES)) + 7 )
        IF CRLF $ NOTES
          NOTES := LEFT(NOTES, AT(CRLF, NOTES) - 1)
        ENDIF
        IF "," $ NOTES
          NOTES := TRIM(LEFT(NOTES, AT(",",NOTES) - 1))
        ENDIF
      ELSE
        NOTES := ""
      ENDIF
    ENDIF
  ENDIF
  IF !EMPTY(NOTES)
    nRet := ASCAN(PSGETPRINTERS(), NOTES )
  ENDIF
ENDIF
RETURN nRet

******************
FUNCTION WinDevMode(cNomImpr)
******************
* Retourne le contenu DevMode en allant le chercher dans le registre Windows
* (regedit.exe)

* Inutilisée pour le moment (conversion en données compréhensibles à faire
* pour le contenu récupéré )

LOCAL cDevMode := ""
LOCAL oReg := TReg32():New(HKEY_LOCAL_MACHINE,;
"System\CurrentControlSet\Control\Print\Printers\" + STRTRAN(cNomImpr, "\", ","), , KEY_QUERY_VALUE)
IF oReg:nError = 0
  cDevMode := oReg:Get("Default DevMode", "")
ENDIF
oReg:Close()
oReg := NIL
RETURN cDevMode

******************
FUNCTION PSTEXTOUT(nRow, nCol, cText, cPicture, nAligne, cFont, nStyle, nPoint, ;
nFColor, nBColor, nAngle )
******************
STATIC ancnPoint
STATIC ancnOrient
STATIC cTexteAff
STATIC nRetour

LOCAL lFonteSupp := .F.
LOCAL oFonte
LOCAL nDixiemeAngle := IIF(nAngle = NIL, 0, nAngle * 10)

* Si cFont = NIL, la dernière fonte activée avant l'appel de cette fonction
* est utilisée par défaut
IF !EMPTY(cFont)
    oFonte := TFont():New( cFont, , nPoint, ,, nDixiemeAngle, nDixiemeAngle,,,,,,,,, oPrn, )
    lFonteSupp := .T.
ELSEIF (nPoint != NIL .OR. !EMPTY(nDixiemeAngle)) .AND. oFont != NIL
    ancnOrient := oFont:nOrientation
    ancnPoint := oFont:nHeight
    PSSetFont2( @nDixiemeAngle, @nPoint)
ENDIF

IF oFonte = NIL
    oFonte := oFont
ENDIF

IF cPicture = NIL
    cTexteAff := ASCIANSI(cText)
ELSE
    cTexteAff := ASCIANSI(TRANSFORM(cText, cPicture))
ENDIF

IF nRow = NIL
    nRetour := GetTextWidth( oPrn:hDC, cTexteAff, oFonte:hFont )
ELSE

    oprn:Say( nRow, nCol, cTexteAff, oFonte, , nFColor, 1, nAligne )

    nRetour := NIL

ENDIF

IF oFonte != NIL .AND. lFonteSupp
  oFonte:End()
  oFonte := NIL
ELSEIF (nPoint != NIL .OR. !EMPTY(nDixiemeAngle)) .AND. oFont != NIL
  PSSetFont2( @ancnOrient, @ancnPoint)
ENDIF
RETURN nRetour

******************
FUNCTION PSSetFont(cFont, nStyle, nPoint, nFColor, nBColor)
******************
* Fonction retournant un tableau contenant les valeurs précédentes :
* { <cOldFont>, <nOldStyle>, <nOldPoint>, <nOldFColor>, <nOldBColor> }

LOCAL ANCIENNEF[5]
* Styles :
*APS_PLAIN      0 Plain
*APS_BOLD       1 Bold
*APS_ITALIC     2 Italic
*APS_BOLDITALIC 3 Bold + Italic
*APS_UNDERLINE  4 UnderLine
*APS_STRIKEOUT  8 StrikeOut


* Tableau de description des fontes avec Fivewin, pour CreateFont()
* LF_HEIGHT    1
* LF_WIDTH    2
* LF_ESCAPEMENT    3
* LF_ORIENTATION    4
* LF_WEIGHT    5
* LF_ITALIC    6
* LF_UNDERLINE    7
* LF_STRIKEOUT    8
* LF_CHARSET    9
* LF_OUTPRECISION    10
* LF_CLIPPRECISION    11
* LF_QUALITY    12
* LF_PITCHANDFAMILY    13
* LF_FACENAME    14

ANCIENNEF := ANCFONTE(0)
IF oFont != NIL
  * Récupère le nom et la hauteur de la dernière fonte réellement activée
  ANCIENNEF[1] := oFont:cFaceName
  ANCIENNEF[3] := oFont:nHeight
ENDIF

IF cFont != NIL
  ANCFONTE(1, cFont)
ENDIF
IF nStyle != NIL
  ANCFONTE(2, nStyle)
ENDIF
IF nPoint != NIL
  ANCFONTE(3, nPoint)
ENDIF
IF nFColor != NIL
  ANCFONTE(4, nFColor)
ENDIF
IF nBColor != NIL
  ANCFONTE(5, nBColor)
ENDIF

PSSetFont2()
RETURN ACLONE(ANCIENNEF)

*******************
FUNCTION PSSetFont2(nOriente, nPointHaut)
*******************
STATIC ANCPOINTH

*oFont := TFont():New( cFaceName, nWidth, nHeight, lFromUser, lBold,;
*            nEscapement, nOrientation, nWeight, lItalic, lUnderline,;
*            lStrikeOut, nCharSet, nOutPrecision, nClipPrecision,;
*            nQuality, oDevice, nPitchFamily ) CLASS TFont

IF oFont != NIL
  oFont:End()
  oFont := NIL
ENDIF

IF nPointHaut != NIL
  ANCPOINTH := ANCFONTE(3)
  ANCFONTE(3, nPointHaut)
ENDIF

IF EMPTY(ANCFONTE(2))
* Normal
  oFont := TFont():New( ANCFONTE(1), , ANCFONTE(3), ,  , nOriente, nOriente, , , ,,,,,, @oPrn, )

ELSE

  oFont := TFont():New( ANCFONTE(1), , ANCFONTE(3), ,;
  ANCFONTE(2) % 2 = 1, nOriente, nOriente, , ANCFONTE(2) % 4 >= 2,;
  ANCFONTE(2) % 8 >= 4, ANCFONTE(2) >= 8,,,,, @oPrn, )

ENDIF

IF oFont != NIL .AND. oPrn != NIL
  oPrn:SetFont( oFont )
ENDIF
IF ANCPOINTH != NIL
  ANCFONTE(3, ANCPOINTH)
  ANCPOINTH := NIL
ENDIF
RETURN NIL

***********************
FUNCTION IMPFonteHauteur()
***********************
* Retourne la hauteur d'une fonte en pixels, ou zéro si aucune fonte en cours pour impression
IF !EMPTY(oFont)
  RETURN oFont:nHeight
ENDIF
RETURN 0

*****************
FUNCTION ANCFONTE(nCas, nVal)
*****************
STATIC ANCFONTE := {"",,,,}
IF nVal != NIL
  ANCFONTE[nCas] := nVal
  RETURN NIL
ELSEIF nCas = NIL
  ANCFONTE := ARRAY(LEN(ANCFONTE))
  RETURN NIL
ELSEIF nCas = 0
  RETURN ACLONE(ANCFONTE)
ENDIF
RETURN ANCFONTE[nCas]

****************
FUNCTION PSFRAME(nR1, nC1, nR2, nC2, EPAISSEUR, nBColor, nFColor, nPattern)
****************
STATIC oBrush
STATIC oPen
LOCAL nEpaisseur := IIF(EPAISSEUR = NIL, PSSETBORDER()[1], EPAISSEUR)
IF nFColor != NIL .AND. nEpaisseur > 0
    oPen := TPen():New(PS_SOLID, PointToPix(MAX( oPrn:nLogPixelX(), oPrn:nLogPixelY()) , nEpaisseur ), ;
    IIF(nFColor = NIL, PSSETBORDER()[2], nFColor) )
    oPrn:Box( nR1, nC1, nR2, nC2, oPen )
    oPen:End()
ENDIF
IF nBColor != NIL
    oBrush := TBrush():New( , nBColor, , )
    IF nFColor != NIL .AND. nEpaisseur > 0
        oPrn:FillRect( { nR1 + nEpaisseur, nC1 + nEpaisseur, nR2 - nEpaisseur, nC2 - nEpaisseur }, oBrush )
    ELSE
        oPrn:FillRect( { nR1, nC1, nR2, nC2 }, oBrush )
    ENDIF
    oBrush:End()
ENDIF
RETURN NIL

*****************
FUNCTION PSBITMAP(nR1, nC1, nR2, nC2, cBitmapFile, nTransColor, lDeleteFile, lKeepRatio)
*****************
* Imprime un fichier .BMP
oPrn:SayBitmap( nR1, nC1, cBitmapFile, nC2 - nC1 + 1, nR2 - nR1 + 1, , nTranscolor )
RETURN NIL

**********************
FUNCTION PSSETPAGESIZE(nPageType)
**********************
STATIC nPageT
IF nPageType != NIL
    nPageT := nPageType
    RETURN NIL
ENDIF
RETURN nPageT

******************
FUNCTION PSGETCAPS(NPRINTER, nOriente)
******************
* Les "#define" ci-dessous sont dans WINDOWS.CH
#define HORZSIZE      4
#define VERTSIZE      6
#define HORZRES       8
#define VERTRES       10
#define BITSPIXEL     12
#define LOGPIXELSX    88
#define LOGPIXELSY    90


*APC_PAPERWIDTH 1 Paper width
*APC_PAPERHEIGHT 2 Paper height
*APC_AREAWIDTH 3 Printable area width
*APC_AREAHEIGHT 4 Printable area height
*APC_TOPMARGIN 5 Top margin
*APC_LEFTMARGIN 6 Left margin
*APC_HPIXELS 7 Number of horizontal pixels per inch
*APC_VPIXELS 8 Number of vertical pixels per inch
*APC_BITSPIXEL 9 Number of bits per pixels. 1 bit = B & W and bits > 1 = color.

STATIC TCAPS[9]
LOCAL oPrint
LOCAL aPixCoord

IF !EMPTY(NPRINTER)
  SysRefresh()
  IF oPrn = NIL
      TCAPS := ARRAY(LEN(TCAPS))
      oPrint := TPrinter():New( "", .F., .F., PSGETPRINTERS()[NPRINTER], .T., .F. )

      InitPrnDim(@oPrint, @nOriente)

      TCAPS[3] := GetDeviceCaps( oPrint:hDC, HORZRES )
      TCAPS[4] := GetDeviceCaps( oPrint:hDC, VERTRES )

      IF nOriente = 0
        TCAPS[5] := oPrint:nYOffset
        TCAPS[6] := oPrint:nXOffset
        TCAPS[7] := GetDeviceCaps( oPrint:hDC, LOGPIXELSY )
        TCAPS[8] := GetDeviceCaps( oPrint:hDC, LOGPIXELSX )
      ELSE
        TCAPS[5] := oPrint:nXOffset
        TCAPS[6] := oPrint:nYOffset
        TCAPS[7] := GetDeviceCaps( oPrint:hDC, LOGPIXELSX )
        TCAPS[8] := GetDeviceCaps( oPrint:hDC, LOGPIXELSY )
      ENDIF
      IF TCAPS[5] = NIL
        TCAPS[5] := 0
      ENDIF
      IF TCAPS[6] = NIL
        TCAPS[6] := 0
      ENDIF
      SysRefresh()
      aPixCoord := oPrint:GetPhySize()
      SysRefresh()
      TCAPS[1] := INT(( aPixCoord[1] / 25.4 ) * TCAPS[7])
      TCAPS[2] := INT(( aPixCoord[2] / 25.4 ) * TCAPS[8])
      TCAPS[9] := GetDeviceCaps( oPrint:hDC, BITSPIXEL )

      PrintEnd( @OPrint, .T. )
  ENDIF

ELSEIF oPrn = NIL
  RETURN ARRAY(LEN(TCAPS))
ENDIF
RETURN ACLONE( TCAPS )

*******************
FUNCTION InitPrnDim( oPrint, nOriente )
*******************
* Format du papier
PSSETPAGESIZE( PSFORMPAPI("D") )
PrnSetPage( PSSETPAGESIZE() )

IF nOriente = 0
    oPrint:SetPortrait()
ELSE
    oPrint:SetLandscape()
ENDIF
RETURN NIL

*******************
FUNCTION PSBEGINDOC(NIMP, QTITRE, nOriente, nCopies, lASSEMB, lINVERS)
*******************
ANCFONTE()

* Avec ou Sans Prévisualisation selon la valeur logique contenue dans PSSetDevice()
oPrn := TPrinter():New( ASCIANSI( PROPRE(QTITRE) ), .F., .T., PSGETPRINTERS()[NIMP], .T., , PSSetDevice() = 2 )

InitPrnDim( @oPrn, @nOriente )

* Nombre d'exemplaires
nCOPIE := nCopies

* permet d'Assembler chaque exemplaire si multi-copie
lASSEMBLER := lASSEMB

* pour inverser l'impression, de la dernière à la première page
lINVERSER := lINVERS

oPrn:SetCopies( nCopies )

PageBegin( @oPrn )
nPage := 1

RETURN NIL

*****************
FUNCTION PSENDDOC(aCourriel, nCourriel, STOP)
*****************

SysRefresh()
IF oPrn != NIL

  RETOURNEDC(,.T.)

  PageEnd( @oPrn )

  SysRefresh()
  PrintEnd( @oPrn, @STOP, @aCourriel, @nCourriel)
  SysRefresh()

  RETOURNEDC(,.T.)

  SysRefresh()

ENDIF

ANCFONTE()
IF oFont != NIL
  oFont:End()
  oFont := NIL
ENDIF
SysRefresh()
nPage := 0

RETURN NIL

******************
FUNCTION PSSETUNIT( nNouvUnit )
******************
* Map modes pour SetMapMode()
#define MM_TEXT        1
#define MM_LOMETRIC    2
#define MM_HIMETRIC    3
#define MM_LOENGLISH    4
*#define MM_HIENGLISH    5
*#define MM_TWIPS    6
*#define MM_ISOTROPIC    7
*#define MM_ANISOTROPIC    8

#define APS_TEXT            0     // Unit is text coordinates (Row, Col)
#define APS_MILL            1     // Unit is millimeter
#define APS_CENT            2     // Unit is centimeter
#define APS_INCH            3     // Unit is inch
#define APS_PIXEL           4     // Unit is pixels

STATIC nUnit := 4

IF nNouvUnit != NIL
  *oImprimeur(@oPrn)
  IF nNouvUnit = 4 .OR. nNouvUnit = 0
    * unité de mesure = Pixel
    SetMapMode( oPrn:hDC, MM_TEXT )
  ELSEIF nNouvUnit = 1
    * unité de mesure = Millimètre
    SetMapMode( oPrn:hDC, MM_HIMETRIC )
  ELSEIF nNouvUnit = 2
    * unité de mesure = Centimètre
    SetMapMode( oPrn:hDC, MM_LOMETRIC )
  ELSEIF nNouvUnit = 3
    * unité de mesure = Pouce
    SetMapMode( oPrn:hDC, MM_LOENGLISH )
  ENDIF
  nUnit := nNouvUnit
ENDIF
RETURN nUnit

********************
FUNCTION PSSETBORDER( EPAISSEUR, NRGBCOUL )
********************
STATIC TT := { 1, 0 }
LOCAL ANCTT := ACLONE(TT)
IF EPAISSEUR != NIL
  TT[1] := EPAISSEUR
ENDIF
IF NRGBCOUL != NIL
  TT[2] := NRGBCOUL
ENDIF
RETURN ACLONE(ANCTT)

***************
FUNCTION PSLINE(LIGD, COLD, LIGF, COLF, EPAISSEUR, nRGBCOUL)
***************
STATIC oPen
*oImprimeur(@oPrn)
oPen := TPen():New( PS_SOLID, PointToPix( MAX( oPrn:nLogPixelX(), oPrn:nLogPixelY()), ;
IIF(EPAISSEUR = NIL, PSSETBORDER()[1], EPAISSEUR) ), ;
IIF(nRGBCOUL = NIL, PSSETBORDER()[2], nRGBCOUL) )
oPrn:Line( LIGD, COLD, LIGF, COLF, oPen )
oPen:End()
RETURN NIL

******************
FUNCTION PSNEWPAGE()
******************
PageEnd( @oPrn )
SysRefresh()
nPage ++
PageBegin( @oPrn )
RETURN NIL

****************
FUNCTION PSABORT()
****************
* Stoppe le travail d'impression en cours (Annulation)
IF oPrn != NIL
    PSENDDOC(,,.T.)
ENDIF
ANCFONTE()
IF oFont != NIL
    oFont:End()
    oFont := NIL
ENDIF
SysRefresh()
nPage := 0
RETURN NIL

*******************
FUNCTION PSSHUTDOWN()
*******************
* OK
RETURN NIL

*******************
FUNCTION RETOURNEDC(DOFFICE, INITIALISE)
*******************
IF INITIALISE != NIL
    IF HDCFW != NIL
        ReleaseDC( oWnd:hWnd )
        HDCFW := NIL
    ENDIF
ELSE
    IF HDCFW = NIL
        HDCFW := GETDC( oWnd:hWnd )
    ELSEIF !EMPTY(DOFFICE)
        IF !EMPTY(HDCFW)
            ReleaseDC( oWnd:hWnd )
        ENDIF
        HDCFW := GETDC( oWnd:hWnd )
    ENDIF
ENDIF
RETURN HDCFW

*******************
FUNCTION PSFORMPAPI(FORMATPAP, LARGPAGE, LONGPAGE)
*******************
* Fonction renvoyant le numéro de format de papier pour PageScript,
* correspondant au format choisi par l'utilisateur
* FORMATPAP est la lettre d'identification du format dans les logiciels ICIM développés par Badara THIAM
#INCLUDE "PSCRIPT.CH"
IF FORMATPAP = "A"
    * A : Exécutive (7.25 x 10.5 pouces)
    LARGPAGE := 184
    LONGPAGE := 267
    RETURN DMPAPER_EXECUTIVE

ELSEIF FORMATPAP = "B"
    * B : Letter (8.5 x 11 pouces)
    LARGPAGE := 216
    LONGPAGE := 279
    RETURN DMPAPER_LETTER

ELSEIF FORMATPAP = "C"
    * C : Légal (8.5 x 14 pouces)
    LARGPAGE := 216
    LONGPAGE := 356
    RETURN DMPAPER_LEGAL

ELSEIF FORMATPAP = "D"
    * D : A4 (210 x 297 mm)
    LARGPAGE := 210
    LONGPAGE := 297
    RETURN DMPAPER_A4

ELSEIF FORMATPAP = "E"
    * E : A3 (297 x 420 mm)
    LARGPAGE := 297
    LONGPAGE := 420
    RETURN DMPAPER_A3

ELSEIF FORMATPAP = "F"
    * F : Enveloppe Monarch (3 7/8 x 7 1/2 pouces)
    LARGPAGE := 190
    LONGPAGE := 98
    RETURN DMPAPER_ENV_MONARCH

ELSEIF FORMATPAP = "G"
    * G : Enveloppe COM-10 (4 1/8 x 9 1/2 pouces)
    LARGPAGE := 241
    LONGPAGE := 105
    RETURN DMPAPER_ENV_10

ELSEIF FORMATPAP = "H"
    * H : Enveloppe DL (110 x 220 mm)
    LARGPAGE := 220
    LONGPAGE := 110
    RETURN DMPAPER_ENV_DL

ELSEIF FORMATPAP = "I"
    * I : Enveloppe C5 (162 x 229 mm)
    LARGPAGE := 229
    LONGPAGE := 162
    RETURN DMPAPER_ENV_C5

ELSEIF FORMATPAP = "J"
    * J : Enveloppe C4 (229 x 324 mm)
    LARGPAGE := 229
    LONGPAGE := 324
    RETURN DMPAPER_ENV_C4

ELSEIF FORMATPAP = "K"
    * K : Enveloppe C3 (324 x 458 mm)
    LARGPAGE := 324
    LONGPAGE := 458
    RETURN DMPAPER_ENV_C3

ELSEIF FORMATPAP = "L"
    * L : Enveloppe C6 (114 x 162 mm)
    LARGPAGE := 162
    LONGPAGE := 114
    RETURN DMPAPER_ENV_C6

ELSEIF FORMATPAP = "M"
    * M : Etiquette 1 (49 x 99 mm)
    LARGPAGE := 99
    LONGPAGE := 49
    RETURN DMPAPER_USER

ENDIF
RETURN DMPAPER_A4

*******************
FUNCTION PSSetDevice( nDevice )
*******************
* Mémorise le type de sortie : Directe, vue avant impression, .pdf
* Si nDevice = 1 : la sortie est envoyée vers l'imprimante (direct printing)
* Si nDevice = 2 : la sortie est envoyée vers la vue avant impression (Preview)
* Si nDevice = 3 : la sortie est enregistrée dans un fichier .pdf. Le fichier doit être défini
*                          avec PSSetFileName() avant de démarer le travail d'impression

* Retourne : NIL si nDevice n'est pas NIL, ou la valeur actuelle si nDevice est NIL

STATIC nDev := 1
IF nDevice = NIL
    RETURN nDev
ENDIF
nDev := nDevice
RETURN NIL

...and with ICIM, enjoy Printing !!!

[Badara Thiam]

Hello,

Sorry, i forgot to tell that :

- i use a FWH 8.6 Printer.prg changed by me, see below.
- The functions ASCIANSI() and ANSIASCI() can be changed by OemToAnsi() and AnsiToOem()
if these functions work correctly with your language, that is not my case (french).
- oWnd: can be changed to WndMain():

Code: Select all  Expand view

#include "FiveWin.ch"
#include "set.ch"
#include "struct.ch"

#define TA_LEFT               0
#define TA_RIGHT              2
#define TA_CENTER             6

#define ETO_OPAQUE            2
#define ETO_CLIPPED           4

#define HORZSIZE            4
#define VERTSIZE            6
#define HORZRES             8
#define VERTRES            10
#define LOGPIXELSX         88
#define LOGPIXELSY         90

#define MM_TEXT             1
#define MM_LOMETRIC         2
#define MM_HIMETRIC         3
#define MM_LOENGLISH        4
#define MM_HIENGLISH        5
#define MM_TWIPS            6
#define MM_ISOTROPIC        7
#define MM_ANISOTROPIC      8

#define PAD_LEFT            0
#define PAD_RIGHT           1
#define PAD_CENTER          2

// Defines for the oPrn:SetPage(nPage) method (The printer MUST support it)

#define DMPAPER_LETTER      1           // Letter 8 1/2 x 11 in
#define DMPAPER_LETTERSMALL 2           // Letter Small 8 1/2 x 11 in
#define DMPAPER_TABLOID     3           // Tabloid 11 x 17 in
#define DMPAPER_LEDGER      4           // Ledger 17 x 11 in
#define DMPAPER_LEGAL       5           // Legal 8 1/2 x 14 in
#define DMPAPER_STATEMENT   6           // Statement 5 1/2 x 8 1/2 in
#define DMPAPER_EXECUTIVE   7           // Executive 7 1/4 x 10 1/2 in
#define DMPAPER_A3          8           // A3 297 x 420 mm
#define DMPAPER_A4          9           // A4 210 x 297 mm
#define DMPAPER_A4SMALL     10          // A4 Small 210 x 297 mm
#define DMPAPER_A5          11          // A5 148 x 210 mm
#define DMPAPER_B4          12          // B4 250 x 354
#define DMPAPER_B5          13          // B5 182 x 257 mm
#define DMPAPER_FOLIO       14          // Folio 8 1/2 x 13 in
#define DMPAPER_QUARTO      15          // Quarto 215 x 275 mm
#define DMPAPER_10X14       16          // 10x14 in
#define DMPAPER_11X17       17          // 11x17 in
#define DMPAPER_NOTE        18          // Note 8 1/2 x 11 in
#define DMPAPER_ENV_9       19          // Envelope #9 3 7/8 x 8 7/8
#define DMPAPER_ENV_10      20          // Envelope #10 4 1/8 x 9 1/2
#define DMPAPER_ENV_11      21          // Envelope #11 4 1/2 x 10 3/8
#define DMPAPER_ENV_12      22          // Envelope #12 4 \276 x 11
#define DMPAPER_ENV_14      23          // Envelope #14 5 x 11 1/2
#define DMPAPER_CSHEET      24          // C size sheet
#define DMPAPER_DSHEET      25          // D size sheet
#define DMPAPER_ESHEET      26          // E size sheet
#define DMPAPER_ENV_DL      27          // Envelope DL 110 x 220mm
#define DMPAPER_ENV_C5      28          // Envelope C5 162 x 229 mm
#define DMPAPER_ENV_C3      29          // Envelope C3  324 x 458 mm
#define DMPAPER_ENV_C4      30          // Envelope C4  229 x 324 mm
#define DMPAPER_ENV_C6      31          // Envelope C6  114 x 162 mm
#define DMPAPER_ENV_C65     32          // Envelope C65 114 x 229 mm
#define DMPAPER_ENV_B4      33          // Envelope B4  250 x 353 mm
#define DMPAPER_ENV_B5      34          // Envelope B5  176 x 250 mm
#define DMPAPER_ENV_B6      35          // Envelope B6  176 x 125 mm
#define DMPAPER_ENV_ITALY   36          // Envelope 110 x 230 mm
#define DMPAPER_ENV_MONARCH 37          // Envelope Monarch 3.875 x 7.5 in
#define DMPAPER_ENV_PERSONAL 38         // 6 3/4 Envelope 3 5/8 x 6 1/2 in
#define DMPAPER_FANFOLD_US  39          // US Std Fanfold 14 7/8 x 11 in
#define DMPAPER_FANFOLD_STD_GERMAN  40  // German Std Fanfold 8 1/2 x 12 in
#define DMPAPER_FANFOLD_LGL_GERMAN  41  // German Legal Fanfold 8 1/2 x 13 in

// Defines for the oPrn:SetBin(nBin) method (The printer MUST support it)

#define DMBIN_FIRST         DMBIN_UPPER
#define DMBIN_UPPER         1
#define DMBIN_ONLYONE       1
#define DMBIN_LOWER         2
#define DMBIN_MIDDLE        3
#define DMBIN_MANUAL        4
#define DMBIN_ENVELOPE      5
#define DMBIN_ENVMANUAL     6
#define DMBIN_AUTO          7
#define DMBIN_TRACTOR       8
#define DMBIN_SMALLFMT      9
#define DMBIN_LARGEFMT      10
#define DMBIN_LARGECAPACITY 11
#define DMBIN_CASSETTE      14
#define DMBIN_LAST          DMBIN_CASSETTE

#define DMORIENT_PORTRAIT   1
#define DMORIENT_LANDSCAPE  2

*static oPrinter

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

CLASS TPrinter

   DATA   oFont
   DATA   hDC, hDCOut
   DATA   aMeta
   DATA   cDir, cDocument, cModel
   DATA   nPage, nXOffset, nYOffset, nPad, nOrient
   DATA   lMeta, lStarted, lModified, lPrvModal
   DATA   lVue
   DATA   TransColor

   METHOD New( cDocument, lUser, lMeta, cModel, lModal, lSelection, lVue ) CONSTRUCTOR

   MESSAGE StartPage() METHOD _StartPage()
   MESSAGE EndPage() METHOD _EndPage()

   METHOD End()

   METHOD Say( nRow, nCol, cText, oFont, nWidth, nClrText, nBkMode, nPad )

   METHOD CmSay( nRow, nCol, cText, oFont, nWidth, nClrText, nBkMode, nPad );
           INLINE ;
           (::Cmtr2Pix(@nRow, @nCol),;
            ::Say( nRow, nCol, cText, oFont, nWidth, nClrText, nBkMode, nPad ))

   METHOD InchSay( nRow, nCol, cText, oFont, nWidth, nClrText, nBkMode, nPad );
           INLINE ;
           (::Inch2Pix(@nRow, @nCol),;
            ::Say( nRow, nCol, cText, oFont, nWidth, nClrText, nBkMode, nPad ))

   METHOD SayBitmap( nRow, nCol, cBitmap, nWidth, nHeight, nRaster, Transcolor )

   METHOD SayImage( nRow, nCol, oImage, nWidth, nHeight, nRaster )

   METHOD SetPos( nRow, nCol )  INLINE MoveTo( ::hDCOut, nCol, nRow )

   METHOD Line( nTop, nLeft, nBottom, nRight, oPen ) INLINE ;
                      MoveTo( ::hDCOut, nLeft, nTop ),;
                      LineTo( ::hDCOut, nRight, nBottom,;
                              If( oPen != nil, oPen:hPen, 0 ) )

   METHOD Box( nRow, nCol, nBottom, nRight, oPen ) INLINE ;
                      Rectangle( ::hDCOut, nRow, nCol, nBottom, nRight,;
                                 If( oPen != nil, oPen:hPen, 0 ) )

   METHOD RoundBox( nRow, nCol, nBottom, nRight, nWidth, nHeight, oPen, nBGColor )

   METHOD Arc( nTop, nLeft, nBottom, nRight, nXB, nYB, nXE, nYE, oPen ) INLINE ;
            Arc( ::hDCOut, nLeft, nTop, nRight, nBottom, nXB, nYB, nXE, nYE, ;
                 If( oPen != nil, oPen:hPen, 0 ) )

   METHOD Chord( nTop, nLeft, nBottom, nRight, nXB, nYB, nXE, nYE, oPen ) INLINE ;
            Chord( ::hDCOut, nLeft, nTop, nRight, nBottom, nXB, nYB, nXE, nYE, ;
                   If( oPen != nil, oPen:hPen, 0 ) )

   METHOD Ellipse( nRow, nCol, nBottom, nRight, oPen ) INLINE ;
            Ellipse( ::hDCOut, nCol, nRow, nRight, nBottom, ;
                     If( oPen != nil, oPen:hPen, 0 ) )

   METHOD Pie( nTop, nLeft, nBottom, nRight, nxStartArc, nyStartArc, nxEndArc, nyEndArc, oPen ) INLINE ;
            Pie( ::hDCOut, nTop, nLeft, nBottom, nRight, nxStartArc, nyStartArc, nxEndArc, nyEndArc, ;
                 If( oPen != nil, oPen:hPen, 0 ) )

   METHOD GetPixel( nRow, nCol, nRGBColor ) INLINE ;
            SetPixel( ::hDCOut, nCol, nRow, nRGBColor )

   METHOD SetPixel( nRow, nCol ) INLINE ;
            SetPixel( ::hDCOut, nCol, nRow )

   METHOD Cmtr2Pix( nRow, nCol )

   METHOD DraftMode( lOnOff ) INLINE (DraftMode( lOnOff ),;
                                      ::Rebuild()         )

   METHOD Inch2Pix( nRow, nCol )

   METHOD Pix2Mmtr(nRow, nCol) INLINE ;
                               ( nRow := nRow * 25.4 / ::nLogPixelX() ,;
                                 nCol := nCol * 25.4 / ::nLogPixelY() ,;
                                 {nRow, nCol}                          )

   METHOD Pix2Inch(nRow, nCol) INLINE ;
                               ( nRow := nRow / ::nLogPixelX() ,;
                                 nCol := nCol / ::nLogPixelY() ,;
                                 {nRow, nCol}                   )

   METHOD CmRect2Pix(aRect)

   METHOD nVertRes()  INLINE  GetDeviceCaps( ::hDC, VERTRES  )
   METHOD nHorzRes()  INLINE  GetDeviceCaps( ::hDC, HORZRES  )

   METHOD nVertSize() INLINE  GetDeviceCaps( ::hDC, VERTSIZE )
   METHOD nHorzSize() INLINE  GetDeviceCaps( ::hDC, HORZSIZE )

   METHOD nLogPixelX() INLINE GetDeviceCaps( ::hDC, LOGPIXELSX )
   METHOD nLogPixelY() INLINE GetDeviceCaps( ::hDC, LOGPIXELSY )

   METHOD SetPixelMode()  INLINE SetMapMode( ::hDC, MM_TEXT )
   METHOD SetTwipsMode()  INLINE SetMapMode( ::hDC, MM_TWIPS )

   METHOD SetLoInchMode() INLINE SetMapMode( ::hDC, MM_LOENGLISH )
   METHOD SetHiInchMode() INLINE SetMapMode( ::hDC, MM_HIENGLISH )

   METHOD SetLoMetricMode() INLINE SetMapMode( ::hDC, MM_LOMETRIC )
   METHOD SetHiMetricMode() INLINE SetMapMode( ::hDC, MM_HIMETRIC )

   METHOD SetIsotropicMode()   INLINE SetMapMode( ::hDC, MM_ISOTROPIC )
   METHOD SetAnisotropicMode() INLINE SetMapMode( ::hDC, MM_ANISOTROPIC )

   METHOD SetWindowExt( nUnitsWidth, nUnitsHeight ) INLINE ;
                        SetWindowExt( ::hDC, nUnitsWidth, nUnitsHeight )

   METHOD SetViewPortExt( nWidth, nHeight ) INLINE ;
                          SetViewPortExt( ::hDC, nWidth, nHeight )

   METHOD GetTextWidth( cText, oFont ) INLINE ;
                        GetTextWidth( ::hDC, cText, ::SetFont(oFont):hFont)

   METHOD GetTextHeight( cText, oFont ) INLINE Abs( ::SetFont(oFont):nHeight )

   METHOD Preview() INLINE If( ::lMeta .and. Len( ::aMeta ) > 0 .and. ::hDC != 0,;
                               RPreview( Self ), ::End() )

   MESSAGE FillRect( aRect, oBrush )  METHOD _FillRect( aRect, oBrush )

   METHOD ResetDC() INLINE ResetDC( ::hDC )

   METHOD GetOrientation() INLINE  PrnGetOrientation()

   METHOD SetLandscape() INLINE ( PrnLandscape( ::hDC ),;
                                  ::Rebuild() )

   METHOD SetPortrait()  INLINE ( PrnPortrait( ::hDC ),;
                                  ::Rebuild() )

   METHOD SetCopies( nCopies ) INLINE ;
                               ( PrnSetCopies( nCopies ),;
                                 ::Rebuild()                    )

   METHOD SetSize( nWidth, nHeight ) INLINE ;
                               ( PrnSetSize( nWidth, nHeight ),;
                                 ::Rebuild()                   )

   METHOD SetPage( nPage ) INLINE ;
                           ( PrnSetPage( nPage ),;
                             ::Rebuild()         )

   METHOD SetBin( nBin ) INLINE ;
                           ( PrnBinSource( nBin ),;
                             ::Rebuild()          )

   METHOD GetModel()  INLINE PrnGetName()
   METHOD GetDriver() INLINE PrnGetDrive()
   METHOD GetPort()   INLINE PrnGetPort()

   METHOD GetPhySize()

   METHOD Setup() INLINE ( PrinterSetup(),;
                           ::Rebuild()    )

   METHOD Rebuild()

   METHOD SetFont( oFont )
   METHOD CharSay( nRow, nCol, cText )
   METHOD CharWidth()
   METHOD CharHeight()

   METHOD ImportWMF( cFile )
   METHOD ImportRAW( cFile )

ENDCLASS

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

METHOD New( cDocument, lUser, lMeta, cModel, lModal, lSelection, lVue ) CLASS TPrinter

   local aOffset
   local cPrinter
   LOCAL cPortDrv

   DEFAULT cDocument := ASCIANSI( "Impression ICIM" ), ;
           lUser := .f. , ;
           lMeta := .f. , ;
           lModal := .f., ;
           lvue := .F., ;
           lSelection := .f.

   cPortDrv := WINGETPRNP(cModel)
   cModel := cModel + "," + cPortDrv
   SysRefresh()

* Remplacé le 16/09/2008 pour concordance avec FWH86 (et test de fonctionnement de l'impression en Paysage)
*
*
*   ::hDC := CreateDC( TOKEN(cModel,",",2), ;
*   TOKEN(cModel,",",1), TOKEN(cModel,",",3))
*   SysRefresh()

   if lUser
      ::hDC := GetPrintDC( GetActiveWindow(), lSelection, PrnGetPagNums() )
      if ::hDC != 0
         cModel = ::GetModel() + "," + ::GetDriver() + "," + ::GetPort()
      endif
   elseif cModel == nil
      ::hDC  := GetPrintDefault( GetActiveWindow() )
      if ::hDC != 0
         cModel = ::GetModel() + "," + ::GetDriver() + "," + ::GetPort()
      endif
   else
      cPrinter := GetProfString( "windows", "device" , "" )
      WriteProfString( "windows", "device", cModel )
      SysRefresh()
      PrinterInit()
      ::hDC := GetPrintDefault( GetActiveWindow() )
      SysRefresh()
      WriteProfString( "windows", "device", cPrinter  )
   endif

**

   if ::hDC != 0
      aOffset    := PrnOffset( ::hDC )
      ::nXOffset := aOffset[1]
      ::nYOffset := aOffset[2]
      ::nOrient  := ::GetOrientation()
   elseif ComDlgXErr() != 0
      MsgStop( ASCIANSI("Aucune imprimante n'est installée ou accessible actuellement...") )
      ::nXOffset := 0
      ::nYOffset := 0
   else                
      ::nXOffset = 0    
      ::nYOffset = 0    
      ::nOrient  = DMORIENT_PORTRAIT  
   endif

   ::cDocument  := cDocument
   ::cModel     := cModel
   ::nPage      := 0
   ::nPad       := 0
   ::lMeta      := lMeta
   ::lStarted   := .F.
   ::lModified  := .F.
   ::lPrvModal  := lModal

   * Ajouté par Badara THIAM le 23/03/2006
   ::lVue := lVue

   if !lMeta
      ::hDcOut := ::hDC
   else
      ::aMeta  := {}

      ::cDir := WinTempDir()

   endif

return Self

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

METHOD End() CLASS TPrinter

   If ::hDC != 0
      if !::lMeta
         if ::lStarted
            EndDoc(::hDC)
         endif
      else
         Aeval(::aMeta,{¦val¦ ferase(val) })
         ::aMeta  := {}
         ::hDCOut := 0
      endif
      if ::nOrient != NIL
         if ::nOrient == DMORIENT_PORTRAIT
            ::SetPortrait()
         else
            ::SetLandscape()
         endif
      endif
      DeleteDC( ::hDC )
      ::hDC := 0
   endif

   if ::oFont != NIL
     ::oFont:End()
   endif

Return NIL

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

METHOD Rebuild() CLASS TPrinter

   LOCAL cPrinter
   LOCAL cModelImp := ::cModel

   if ::lStarted
      if !::lMeta
         EndDoc(::hDC)
      else
         ::hDCOut := 0
      endif
   endif

   if ::hDC != 0
     DeleteDC(::hDC)
     ::hDC := GetPrintDefault( GetActiveWindow() )

*   ::hDC := CreateDC( TOKEN(cModelImp,",",2), ;
*   TOKEN(cModelImp,",",1), TOKEN(cModelImp,",",3))
*   SysRefresh()

     ::lStarted   := .F.
     ::lModified  := .T.

   endif

   if ::hDC != 0
      if !::lMeta
         ::hDcOut = ::hDC
      endif
   endif

return nil

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

METHOD _StartPage() CLASS TPrinter

   local lSetFixed

   if ::hDC == 0
      return nil
   endif

   lSetFixed := Set( _SET_FIXED, .F. )

   if !::lMeta .and. ! ::lStarted
      ::lStarted := .T.
      StartDoc( ::hDC, ::cDocument )
   endif

   ::nPage++

   if ::lMeta
      * fichiers .WMF remplacés en fichiers .EMF par Badara THIAM
      AAdd( ::aMeta, ::cDir + "\ICIM" + PUBVAR(15) + "\" + PadL( ::nPage, 8, "0" ) + ".EMF" )

*      #ifndef __CLIPPER__
*         ::hDCOut := CreateEnhMetaFile( ::hDC, ATail( ::aMeta ), ::cDocument )  //jlcr
*      #else
       ::hDCOut := CreateMetaFile( ATail( ::aMeta ) )
*      # endif


   else
      StartPage( ::hDC )
   endif

   Set( _SET_FIXED, lSetFixed )

return nil

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

METHOD _EndPage() CLASS TPrinter

   If ::hDC = 0
      Return NIL
   endif

   if ::lMeta
      if len(::aMeta) == 0
         MsgAlert(ASCIANSI("Le méta-fichier temporaire n'a pas pu être créé"),;
                  ASCIANSI("Erreur système d'impression"))
      else
*         #ifndef __CLIPPER__
*            DeleteEnhMetaFile( CloseEnhMetaFile( ::hDCOut ) )
*         #else
             DeleteMetaFile( CloseMetaFile( ::hDCOut ) )
*         #endif

         if ! FileExist( Atail( ::aMeta ) )
            MsgAlert(ASCIANSI( "Ce fichier temporaire n'a pas pu être créé : "+Atail(::aMeta)+CRLF+CRLF ;
                     + "S'il vous plait, vérifiez l'espace libre sur votre disque dur.") ;
                    , "Erreur vue avant impression" )
         endif
      endif
   else
      EndPage( ::hDC )
   endif

Return NIL

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

METHOD RoundBox( nRow, nCol, nBottom, nRight, nWidth, nHeight, oPen, nBGColor ) ;
   CLASS TPrinter

   local hBrush, hOldBrush
   local hPen, hOldPen

   hPen = If( oPen == Nil, CreatePen( PS_SOLID, 1, CLR_BLACK ), oPen:hPen )
   hOldPen = SelectObject( ::hDCOut, hPen )

   if nBGColor != nil
      hBrush    := CreateSolidBrush( nBGColor )
      hOldBrush := SelectObject( ::hDCOut, hBrush )
   endif

   RoundRect( ::hDCOut, nRow, nCol, nBottom, nRight, nWidth, nHeight )

   if nBGColor # Nil
      SelectObject( ::hDCOut, hOldBrush )
      DeleteObject( hBrush )
   endif

   SelectObject( ::hDCOut, hOldPen )

   If( oPen == Nil, DeleteObject( hPen ), Nil )

return nil

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

METHOD Say( nRow, nCol, cText, oFont,;
            nWidth, nClrText, nBkMode, nPad ) CLASS TPrinter

   LOCAL nTemp

   If ::hDC = 0
      Return NIL
   endif

   DEFAULT oFont   := ::oFont ,;
           nBkMode := 1       ,;
           nPad    := ::nPad

   if oFont != nil
      oFont:Activate( ::hDCOut )
   endif

   SetbkMode( ::hDCOut, nBkMode )               // 1,2 transparent or Opaque

   if nClrText != NIL
     SetTextColor( ::hDCOut, nClrText )
   endif

   if Empty(nWidth)
      Do Case
      Case nPad == PAD_RIGHT
         nCol := Max(0, nCol - ::GetTextWidth( cText, oFont ))
      Case nPad == PAD_CENTER
         nCol := Max(0, nCol - (::GetTextWidth( cText, oFont )/2))
      Endcase
      SetTextAlign( ::hDCOut, TA_LEFT )
      TextOut( ::hDCOut, nRow, nCol, cText )
   else
      Do Case
      Case nPad == PAD_RIGHT
         nTemp := nCol + nWidth
         SetTextAlign( ::hDCOut, TA_RIGHT )
      Case nPad == PAD_CENTER
         nTemp := nCol + (nWidth/2)
         SetTextAlign( ::hDCOut, TA_CENTER )
      otherwise
         nTemp := nCol
         SetTextAlign( ::hDCOut, TA_LEFT )
      Endcase
      ExtTextOut( ::hDCOut, nRow, nTemp,;
                  {nRow, nCol, nRow+oFont:nHeight, nCol+nWidth},;
                  cText, ETO_CLIPPED )
   endif

   if oFont != nil
      oFont:DeActivate( ::hDCOut )
   endif

return nil

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

METHOD SayBitmap( nRow, nCol, xBitmap, nWidth, nHeight, nRaster, TransColor ) CLASS TPrinter

local hDib, aBmpPal, hBitmap, hPalette
LOCAL nZeroZeroClr, hBmpOld, nOldClr

if ::hDC = 0
   return nil
endif

if ( ValType( xBitmap ) == "N" ) .or. ! File( xBitmap )
      aBmpPal  := PalBmpLoad( xBitmap )
      hBitmap  := aBmpPal[ 1 ]
      hPalette := aBmpPal[ 2 ]
      hDib     := DibFromBitmap( hBitmap, hPalette )
      PalBmpFree( hBitmap, hPalette )
      if hDib == 0
         return nil
      endif

      if ! ::lMeta
        hPalette := DibPalette( hDib )
      endif

      DibDraw( ::hDCOut, hDib, hPalette, nRow, nCol,;
               nWidth, nHeight, nRaster )

      GlobalFree( hDib )

      if ! ::lMeta
         DeleteObject( hPalette )
      endif

else

  IF LOWER(RIGHT(TRIM( xBitmap ),4)) == ".bmp"
    hBitmap := { ReadBitmap( 0, xBitmap ), xBitmap }
  ELSE
  * Sinon si FREEIMAGE.DLL est la librarie graphique liée à l'executable
    hBitmap := { FILoadImg( xBitmap ), xBitmap }
  ENDIF

   hDib := DibFromBitmap( hBitmap[1] )

   if ! ::lMeta
      hPalette := DibPalette( hDib )
   endif

   DibDraw( ::hDCOut, hDib, hPalette, nRow, nCol,;
            nWidth, nHeight, nRaster )

   GlobalFree( hDib )

   * Ajouté le 23/08/2013 pour voir si réduit la mémoire occupée après impression manuel de référence, mais pas de changement
   DeleteObject( hBitmap[1] )

   if ! ::lMeta
      DeleteObject( hPalette )
   endif

endif


return nil



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

METHOD SayImage( nRow, nCol, oImage, nWidth, nHeight, nRaster ) CLASS TPrinter

   local hDib, hPalBmp, hPal

   If ::hDC = 0
      Return NIL
   endif

   do case
      case ValType( oImage ) == "O"
           hDib := DibFromBitmap( oImage:hBitmap, oImage:hPalette )
   endcase

   if hDib <= 0
     return nil
   endif

   if ! ::lMeta
     hPal := DibPalette( hDib )
   endif

   DibDraw( ::hDCOut, hDib, hPal, nRow, nCol,;
            nWidth, nHeight, nRaster )

   GlobalFree( hDib )

   if ! ::lMeta
     DeleteObject( hPal )
   endif

return nil

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

METHOD _FillRect (aCols, oBrush) CLASS TPrinter

   If ::hDC = 0
      Return NIL
   endif

   FillRect(::hDCOut ,aCols, oBrush:hBrush)

return NIL

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

METHOD Cmtr2Pix( nRow, nCol ) CLASS TPrinter

   nRow := Max( 0, ( nRow * 10 * ::nVertRes() / ::nVertSize() ) - ::nYoffset )
   nCol := Max( 0, ( nCol * 10 * ::nHorzRes() / ::nHorzSize() ) - ::nXoffset )

return { nRow, nCol }

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

METHOD CmRect2Pix(aRect)  CLASS TPrinter

   LOCAL aTmp[4]

   aTmp[1] := Max( 0, ( aRect[1] * 10 * ::nVertRes() / ::nVertSize() ) - ::nYoffset )
   aTmp[2] := Max( 0, ( aRect[2] * 10 * ::nHorzRes() / ::nHorzSize() ) - ::nXoffset )
   aTmp[3] := Max( 0, ( aRect[3] * 10 * ::nVertRes() / ::nVertSize() ) - ::nYoffset )
   aTmp[4] := Max( 0, ( aRect[4] * 10 * ::nHorzRes() / ::nHorzSize() ) - ::nXoffset )

RETURN aTmp

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

METHOD Inch2Pix( nRow, nCol ) CLASS TPrinter

   nRow := Max( 0, ( nRow * ::nVertRes() / (::nVertSize() / 25.4 ))-::nYoffset )
   nCol := Max( 0, ( nCol * ::nHorzRes() / (::nHorzSize() / 25.4 ))-::nXoffset )

return { nRow, nCol }

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

METHOD GetPhySize() CLASS TPrinter

   local aData := PrnGetSize( ::hDC )
   local nWidth, nHeight

   nWidth  := aData[ 1 ] / ::nLogPixelX() * 25.4
   nHeight := aData[ 2 ] / ::nLogPixelY() * 25.4

return { nWidth, nHeight }

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

METHOD SetFont( oFont ) CLASS TPrinter

   IF oFont != NIL
      ::oFont := oFont
   ELSEIF ::oFont == NIL
      DEFINE FONT ::oFont NAME "COURIER" SIZE 0,-12 OF Self
   ENDIF

RETURN ::oFont

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

METHOD CharSay( nRow, nCol, cText ) CLASS TPrinter

   LOCAL nPxRow, nPxCol

   ::SetFont()

   nRow   := Max(--nRow, 0)
   nCol   := Max(--nCol, 0)
   nPxRow := nRow * ::GetTextHeight( "", ::oFont )
   nPxCol := nCol * ::GetTextWidth( "B", ::oFont )

   ::Say( nPxRow, nPxCol, cText, ::oFont )

RETURN NIL

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

METHOD CharWidth() CLASS TPrinter

   ::SetFont()

RETURN Int( ::nHorzRes() / ::GetTextWidth( "B", ::oFont ))

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

METHOD CharHeight() CLASS TPrinter

   ::SetFont()

RETURN Int( ::nVertRes() / ::GetTextHeight( "",::oFont ))

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

METHOD ImportWMF( cFile, lPlaceable ) CLASS TPrinter

     LOCAL hMeta
     LOCAL aData := PrnGetSize( ::hDC )
     LOCAL aInfo := Array(5)
*     LOCAL hOld, hWMF

     DEFAULT lPlaceable := .T.

     IF !file(cFile)
          RETURN NIL
     ENDIF

     SaveDC( ::hDCOut )

*     #ifdef __CLIPPER__
        if lPlaceable
            hMeta := GetPMetaFile( cFile, aInfo )
        else
           hMeta := GetMetaFile( cFile )
        endif
*     #else  
*        if cFileExt( cFile ) == "EMF"
*           hMeta := GetEnhMetaFile( cFile )
*        else
*           hOld := GetPMetaFile( cFile, aInfo )
*           hMeta := WMF2EMF( hOld, ::hDCOut )  
*        endif  
*     #endif  


     ::SetIsoTropicMode()
     ::SetWindowExt( aData[1], aData[2] )
     ::SetViewPortExt( aData[1], aData[2] )

     IF !::lMeta
          SetViewOrg( ::hDCOut, -::nXoffset, -::nYoffset )
     ENDIF

     SetBkMode(::hDCOut, 1)

*       #ifdef __CLIPPER__
          PlayMetaFile( ::hDCOut, hMeta )
          DeleteMetafile( hMeta )
*       #else
*          if cFileExt( cFile ) == "EMF"
*             PlayEnhMetafile( ::hDCOut, hMeta,, .t. )
*             DeleteEnhMetafile( hMeta )
*          else  
*             PlayMetaFile( ::hDCOut, hWMF := EMF2WMF( hMeta, ::hDCOut ) )
*             DeleteMetafile( hWMF )
*          endif  
*       #endif

*     if ! Empty( hOld )
*        DeleteMetafile( hOld )
*     endif

     RestoreDC( ::hDCOut )

RETURN NIL

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

METHOD ImportRAW(cFile) CLASS TPrinter

     IF !file(cFile)
          RETURN NIL
     ENDIF

     ImportRawFile(::HDCOut, cFile)

RETURN NIL

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

FUNCTION PrintBegin( cDoc, lUser, lPreview, xModel, lModal, lSelection )

   local aPrn
   local cText, cDevice
   local nScan

   if xModel == NIL
      return TPrinter():New( cDoc, lUser, lPreview,, lModal, lSelection )
   endif

   cText := StrTran(GetProfString("Devices"),Chr(0), chr(13)+chr(10))
   aPrn  := Array(Mlcount(cText, 250))

   Aeval(aPrn, {¦v,e¦ aPrn[e] := Trim(Memoline(cText, 250, e)) } )

   if Valtype(xModel) == "N"
      if xModel < 0 .or. xModel > len(aPrn)
         nScan := 0
      else
         nScan := xModel
      endif
   else
      if ( nScan := Ascan( aPrn, {¦v¦ MAJ( xModel ) == MAJ( v ) } ) ) == 0
         nScan := Ascan(aPrn, {¦v¦ MAJ(xModel) $ MAJ(v) })
      endif
   endif

   if nScan == 0
      MsgBeep()
      return TPrinter():New( cDoc, .T., lPreview,, lModal, lSelection )
   endif

   cText   := GetProfString("Devices", aPrn[nScan])
   cDevice := aPrn[ nScan ] + "," + cText

return TPrinter():New( cDoc, .f., lPreview, cDevice, lModal, lSelection )


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

FUNCTION PageBegin( oPrn )
oPrn:StartPage()
RETURN NIL

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

FUNCTION PageEnd( oPrn )
oPrn:EndPage()
RETURN NIL

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

*****************
FUNCTION PrintEnd( oPrn, STOP, aCourriel, nCourriel )
*****************

IF aCourriel != NIL .AND. !EMPTY(aCourriel[1])
    * Changement du nom du document lors de la fin de page
    * ou de la fin du document ( FINPRN() ou STOPPRN() )
    oPrn:cDocument := aCourriel[1]
ENDIF

IF EMPTY(STOP)
    PUBVAR(159, nCourriel)
    PUBVAR(160, aCourriel)
    IF oPrn:lVue
        IF oPrn:lMeta .AND. LEN( oPrn:aMeta ) > 0 .AND. oPrn:hDC != 0
            RPreview(@oPrn)
        ELSE
            oPrn:End()
        ENDIF
    ELSE
        IF oPrn:lMeta
            ImprimMeta( @oPrn )
        ENDIF
        oPrn:End()
    ENDIF
    nCourriel := PUBVAR(159)
    PUBVAR(159, NIL)
    PUBVAR(160, NIL)
ELSE
    oPrn:End()
ENDIF
oPrn := NIL
RETURN NIL

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

function AGetPrinters() // returns an array with all the available printers

   local aPrinters, cText, cToken := Chr( 15 )

   cText = StrTran( StrTran( StrTran( ;
         GetProfString( "Devices", 0 ), Chr( 0 ), cToken ), Chr( 13 ) ), Chr( 10 ) )
   aPrinters = Array( Len( cText ) - Len( StrTran( cText, cToken ) ) )
   AEval( aPrinters, { ¦cPrn, nEle ¦ ;
       aPrinters[ nEle ] := StrToken( cText, nEle, cToken ) } )

return aPrinters

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

function SetPrintDefault( cModel )

   local cDriver := StrToken( GetProfString( "Devices", cModel, "" ), 1, "," )
   local cPort   := StrToken( GetProfString( "Devices", cModel, "" ), 2, "," )

   WriteProfString( "Windows", "Device", cModel + ",", cDriver + "," + cPort )

return nil

*******************
FUNCTION PrnGetName()
*******************
* Renvoie l'imprimante par défaut en allant le chercher dans le registre Windows
RETURN WINDEFPRN()


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

/* DLL32 FUNCTION CREATEENHMETAFILE( hDCRef AS LONG,;
                                  cFilename AS LPSTR,;
                                  cRect AS LPSTR,;
                                  cDescription AS LPSTR ) AS LONG;
               PASCAL FROM "CreateEnhMetaFileA" LIB "gdi32.dll"

DLL32 FUNCTION CLOSEENHMETAFILE( hDC AS LONG ) AS LONG;
      PASCAL FROM "CloseEnhMetaFile" LIB "gdi32.dll"

DLL32 FUNCTION DELETEENHMETAFILE( hEMF AS LONG ) AS BOOL;
      PASCAL FROM "DeleteEnhMetaFile" LIB "gdi32.dll"
*/

[Badara Thiam]

Hello,

For intensive printing, i have put this code, increasing default value,
who was necessary for do not have problem in memory (and after so stranges effects...).

Code: Select all  Expand view

*******************
FUNCTION MEMCOMPACT()
*******************
SysRefresh()
* Changé le 21/08/2013
*RETURN GlobalCompact(8192)
* Changé le 24/08/2013
RETURN GlobalCompact(16384)

 

[Badara Thiam]

Hello,

There is a great problem to convert RGB colors with HaruPDF.
We have only 216 colors.

« The reason that 216 colors were used out of the possible palette of 256 colors is that this allowed an even sampling of color throughout the color space that can be realised on most displays by dividing it up into areas which represent one-sixth of the possible values of all color components of red, green and blue - hence we get a cube which has 6 possible areas of red, 6 of green and 6 of blue which together make up 6x6x6 = 216 combinations.

Today most screens are viewed in True color which uses 24-bits and uses the full range of 256 possible values for each red, green and blue color component which give 256x256x256 = 16777216 colors.

However, this can be quite daunting for non-artists to work with and the web safe palette is a useful starting point when considering color schemes. »

source : https://github.com/libharu/libharu/wiki ... e_Operator

[Badara Thiam]

Hello,

Yesterday i let down my try with HaruPDF, because to have a palette of 216 colours is not acceptable for me.
With PDF1 this not seems to be a problem, but the fonts conversion is not easy. Try...

Here there is the function IWinFontes(), created to turn off the problem i haved with PSGETFONTS() of PageScript.

Code: Select all  Expand view

*******************
FUNCTION IWinFontes( SEULFIXE )
*******************
* Retourne un tableau dont chaque élément contient le nom d'une fonte disponible et utilisable sous Windows
* Auteur Badara THIAM

STATIC TFONT := {}
STATIC ANCSEULFIXE := .F.
LOCAL REPFONT := GETREPWIN()
LOCAL TNOMS := {}
LOCAL X
LOCAL aFont := {}

IF !EMPTY(TFONT) .AND. SEULFIXE = ANCSEULFIXE
  RETURN ACLONE(TFONT)

ELSEIF !EMPTY(REPFONT) .AND. EXISTEREP(REPFONT + "\FONTS")
  TFONT := {}
  ANCSEULFIXE := SEULFIXE
  REPFONT += "\FONTS"

  ***** Fontes sous windows 98 *****
  IF EMPTY(SEULFIXE)
    AADD( TNOMS, { "Abadi MT Condensed léger", "ABALC.TTF" } )

    AADD( TNOMS, { "Arial", "ARIAL.TTF" } )
    AADD( TNOMS, { "Arial Black", "ARIBLK.TTF" } )
    AADD( TNOMS, { "Arial Gras", "ARIALBD.TTF" } )
    AADD( TNOMS, { "Arial Gras Italique", "ARIALBI.TTF" } )
    AADD( TNOMS, { "Arial Italique", "ARIALI.TTF" } )
    AADD( TNOMS, { "Arial Narrow", "ARIALN.TTF" } )
    AADD( TNOMS, { "Arial Narrow Special G1", "MSGEONR1.TTF" } )
    AADD( TNOMS, { "Arial Narrow Special G1 Bold", "MSGEONB1.TTF" } )
    AADD( TNOMS, { "Arial Narrow Special G1 Italic", "MSGEONI1.TTF" } )
    AADD( TNOMS, { "Arial Special G1", "MSGEOAR1.TTF" } )
    AADD( TNOMS, { "Arial Special G1 Bold", "MSGEOAB1.TTF" } )
    AADD( TNOMS, { "Arial Special G1 Bold Italic", "MSGEOAX1.TTF" } )
    AADD( TNOMS, { "Arial Special G1 Italic", "MSGEOAI1.TTF" } )

    AADD( TNOMS, { "Book Antiqua", "BKANT.TTF" } )

    AADD( TNOMS, { "Calisto MT", "CALIST.TTF" } )

    AADD( TNOMS, { "Century Gothic", "GOTHIC.TTF" } )
    AADD( TNOMS, { "Century Gothic Gras", "GOTHICB.TTF" } )
    AADD( TNOMS, { "Century Gothic Gras Italique", "GOTHICBI.TTF" } )
    AADD( TNOMS, { "Century Gothic Italique", "GOTHICI.TTF" } )

    AADD( TNOMS, { "Comic sans MS", "COMIC.TTF" } )
    AADD( TNOMS, { "Comic sans MS Gras", "COMICBD.TTF" } )

    AADD( TNOMS, { "Copperlate Gothic Gras", "COPRGTB.TTF" } )
    AADD( TNOMS, { "Copperlate Gothic Léger", "COPRGTL.TTF" } )

  ENDIF

  AADD( TNOMS, { "Courier New", "COUR.TTF" } )
  AADD( TNOMS, { "Courier New Gras", "COURBD.TTF" } )
  AADD( TNOMS, { "Courier New Gras Italique", "COURBI.TTF" } )
  AADD( TNOMS, { "Courier New Italique", "COURI.TTF" } )

  AADD( TNOMS, { "Lucida Console", "LUCON.TTF" } )
  AADD( TNOMS, { "OCR A Extended", "OCRAEXT.TTF" } )

  IF EMPTY(SEULFIXE)
    AADD( TNOMS, { "Impact", "IMPACT.TTF" } )

    AADD( TNOMS, { "Lucida Handwriting Italique", "LHANDW.TTF" } )
    AADD( TNOMS, { "Lucida Sans Italique", "LSANSI.TTF" } )
    AADD( TNOMS, { "Lucida Sans Unicode", "LSANSUNI.TTF" } )

    AADD( TNOMS, { "Matisse ITC", "MATISSE_.TTF" } )
    AADD( TNOMS, { "MS LineDraw Normal", "LINEDRAW.TTF" } )
*    AADD( TNOMS, { "MS-DOS CP 850", "APP850.FON" } )
*    AADD( TNOMS, { "Petites polices", "SMALLE.FON" } )

    AADD( TNOMS, { "New Gothic MT", "NWGTHC.TTF" } )
    AADD( TNOMS, { "New Gothic MT Gras", "NWGTHCB.TTF" } )
    AADD( TNOMS, { "New Gothic MT Italique", "NWGTHCI.TTF" } )

    AADD( TNOMS, { "Tahoma", "TAHOMA.TTF" } )
    AADD( TNOMS, { "Tahoma Gras", "TAHOMABD.TTF" } )

    AADD( TNOMS, { "Tempus Sans ITC", "TEMPSITC.TTF" } )

    AADD( TNOMS, { "Terminal", "VGA850.FON" } )

    AADD( TNOMS, { "Times New Roman", "TIMES.TTF" } )
    AADD( TNOMS, { "Times New Roman Gras", "TIMESBD.TTF" } )
    AADD( TNOMS, { "Times New Roman Gras Italique", "TIMESBI.TTF" } )
    AADD( TNOMS, { "Times New Roman Italique", "TIMESI.TTF" } )
    AADD( TNOMS, { "Times New Roman Special G1", "MSGEOTR1.TTF" } )
    AADD( TNOMS, { "Times New Roman Special G1 Bold", "MSGEOTB1.TTF" } )
    AADD( TNOMS, { "Times New Roman Special G1 Bold Italic", "MSGEOTX1.TTF" } )
    AADD( TNOMS, { "Times New Roman Special G1 Italic", "MSGEOTI1.TTF" } )

    AADD( TNOMS, { "Verdana", "VERDANA.TTF" } )
    AADD( TNOMS, { "Verdana Gras", "VERDANAB.TTF" } )
    AADD( TNOMS, { "Verdana Gras Italique", "VERDANAZ.TTF" } )
    AADD( TNOMS, { "Verdana Italique", "VERDANAI.TTF" } )

    AADD( TNOMS, { "Westminster", "WESTM.TTF" } )
    AADD( TNOMS, { "WingDings", "WINGDING.TTF" } )

  ENDIF
  *****

  ***** Autres fontes sous windows XP *****
  IF EMPTY(SEULFIXE)
    AADD( TNOMS, {"Franklin Gothic Medium", "FRAMD.TTF" } )
    AADD( TNOMS, {"Franklin Gothic Médium Italic", "FRAMDIT.TTF" } )

    AADD( TNOMS, {"Georgia", "GEORGIA.TTF" } )
    AADD( TNOMS, {"Georgia Bold", "GEORGIAB.TTF" } )
    AADD( TNOMS, {"Georgia Bold Italic", "GEORGIAZ.TTF" } )
    AADD( TNOMS, {"Georgia Italic", "GEORGIAI.TTF" } )

    AADD( TNOMS, { "Lucida Sans Unicode", "L_10646.TTF" } )
    AADD( TNOMS, {"Microsoft Sans Serif Regular", "MICROSS.TTF" } )

    AADD( TNOMS, {"Palatino Linotype", "PALA.TTF" } )
    AADD( TNOMS, {"Palatino Linotype Bold", "PALAB.TTF" } )
    AADD( TNOMS, {"Palatino Linotype Bold Italic", "PALABI.TTF" } )
    AADD( TNOMS, {"Palatino Linotype Italic", "PALAI.TTF" } )

    AADD( TNOMS, {"Sylfaen", "SYLFAEN.TTF" } )

* A utiliser avec précaution, ne peut jamais servir à afficher du texte
*    AADD( TNOMS, {"Symbol", "SYMBOL.TTF" } )

    AADD( TNOMS, {"Trebuchet MS", "TREBUC.TTF" } )
    AADD( TNOMS, {"Trebuchet MS Bold", "TREBUCBD.TTF" } )
    AADD( TNOMS, {"Trebuchet MS Bold Italic", "TREBUCBI.TTF" } )
    AADD( TNOMS, {"Trebuchet MS Italic", "TREBUCI.TTF" } )

    AADD( TNOMS, {"Webdings", "WEBDINGS.TTF" } )
  ENDIF
  *****

  ***** Autres fontes gratuites (téléchargées sur internet)
  * éventuellement fournies (gratuitement bien entendu)
  IF EMPTY(SEULFIXE)
    AADD( TNOMS, { "Doctor Azul", "DOCTORAZ.TTF" } )
    AADD( TNOMS, { "Dot2Dot", "DOT2DOT.TTF" } )
    AADD( TNOMS, { "Droid regular", "DROID.TTF" } )
    AADD( TNOMS, { "Dweebo Gothic", "DWEEG___.TTF" } )
    AADD( TNOMS, { "FakeReceipt", "FAKERECE.TTF" } )
*    AADD( TNOMS, { "Girls are Weird", "GIRLSARE.TTF" } ) && Bloque le programme
    AADD( TNOMS, { "Innie Outtie", "INNIO___.TTF" } )
    AADD( TNOMS, {"InvisibleKiller", "INVISIBL.TTF" } )
    AADD( TNOMS, { "LuggerBug", "LUGGERBU.TTF" } )
    AADD( TNOMS, {"proletarian", "PROLE.TTF" } )
    AADD( TNOMS, { "RoboKoz", "ROBOKOZ.TTF" } )
    AADD( TNOMS, {"Ruffian bold", "RUFF.TTF" } )
    AADD( TNOMS, {"Ruffian Outline", "RUFFOUT.TTF" } )
    AADD( TNOMS, {"Stone", "STONE.TTF" } )
    AADD( TNOMS, {"Ventilate", "VENTILAT.TTF" } )
    AADD( TNOMS, {"Vibrocentric", "VIBROCEN.TTF" } )
    AADD( TNOMS, {"Wet Pet", "WETPET.TTF" } )
    AADD( TNOMS, {"WhallyWhilly", "WHALW___.TTF" } )
    AADD( TNOMS, {"Wedgie Regular", "WEDGIE__.TTF" } )


    * Vera à espacement proportionnel
    AADD( TNOMS, {"Bitstream Vera Sans", "VERA.TTF" } )
    AADD( TNOMS, {"Bitstream Vera Sans Bold", "VERABD.TTF" } )
    AADD( TNOMS, {"Bitstream Vera Sans Bold Oblique", "VERABI.TTF" } )
    AADD( TNOMS, {"Bitstream Vera Sans Oblique", "VERAIT.TTF" } )
    AADD( TNOMS, {"Bitstream Vera Serif", "VERASE.TTF" } )
    AADD( TNOMS, {"Bitstream Vera Serif Bold", "VERASEBD.TTF" } )


  ENDIF

  *** Espacement fixe ***
  AADD( TNOMS, {"ProFontWindows", "PROFON~1.TTF" } )

  * Vera
  AADD( TNOMS, {"Bitstream Vera Sans Mono", "VERAMONO.TTF" } )
  AADD( TNOMS, {"Bitstream Vera Sans Mono Bold", "VERAMOBD.TTF" } )
  AADD( TNOMS, {"Bitstream Vera Sans Mono Bold Oblique", "VERAMOBI.TTF" } )
  AADD( TNOMS, {"Bitstream Vera Sans Mono Oblique", "VERAMOIT.TTF" } )

  *****

  * enregistre dans le tableau TFONT, créé par la fonction IWinFontes(),
  * toutes les fontes dont le fichier existe dans le répertoire ..\WINDOWS\FONTS
  * Fait pour palier au problème de détection des fontes TrueType
  * lorsque l'imprimante n'a pas de police internes
  * La fonction PSGetFonts() est la cause du problème (la fonction de PageScript)
  FOR X := 1 TO LEN(TNOMS)
      IF FileExist(REPFONT + "\" + TNOMS[X][2])
          AADD(TFONT, TNOMS[X][1])
      ENDIF
  NEXT X

ENDIF

IF LIBWIN()
* Si version pour Windows de l'application
    * Ajout des fontes Windows non répertoriées en utilisant GetFontNames() une fonction de Fivewin
    aFont := DO0("GetFontNames", RETOURNEDC() )
    FOR X := 1 TO LEN(aFont)
        IF ASCAN(TNOMS, { ¦qElem¦ LOWER(qElem[1]) == LOWER(aFont[X])  } ) = 0
            AADD(TFONT, aFont[X])
        ENDIF
    NEXT X
ENDIF

IF LEN(TFONT) > 0
    ASORT(TFONT,,, { ¦A,B¦ MAJ(A) < MAJ(B) } )
ENDIF
RETURN ACLONE(TFONT)