ATOUTFOX
COMMUNAUTÉ FRANCOPHONE DES PROFESSIONNELS FOXPRO
Visual FoxPro : le développement durable

ECRIRE DANS TOUTES LES DIRECTIONS SUR UN FORM   



L'auteur

ybenam
Algérie Algérie
Membre Simple
# 0000002080
enregistré le 21/04/2008


Fiche personnelle


Note des membres
pas de note

Contributions > 05 - API et appels systèmes

ECRIRE DANS TOUTES LES DIRECTIONS SUR UN FORM
# 0000000579
ajouté le 20/05/2008 16:03:34 et modifié le 20/05/2008
consulté 7197 fois
Niveau initié

Version(s) Foxpro :
VFP 6.0

Description
Ecrire avec n'importe quelle fonte dans n'importe quelle direction sur un form et sous VFP6.0 Utilisation des API windows pour réaliser cela.
Code source :
&&Ecrire dans toutes les directions sur un form avec API Windows...sous VFP6.0..

oform=createobject("ywrite_form")
oform.show
read events
return

DEFINE CLASS ywrite_form AS form
  Height = 600
  Width = 800
  ShowWindow = 2
  Borderstyle=2
  DoCreate = .T.
  ShowTips = .T.
  AutoCenter = .T.
  Caption = "Ecrire dans toutes les directions...sous VFP6.0....."
  TitleBar = 1
  Name = "Form1"

  ADD OBJECT command1 AS commandbutton WITH ;
    Top = 365, ;
    Left = 483, ;
    Height = 27, ;
    Width = 60, ;
    Caption = "Write", ;
    Name = "Command1"

  ADD OBJECT text1 AS textbox WITH ;
    Height = 25, ;
    InputMask = "XXXXXXXXXXXXXXXXXXXXXXXXX", ;
    Left = 151, ;
    ToolTipText = "25 Caractères max !", ;
    Top = 369, ;
    Width = 301, ;
    Name = "Text1"

  ADD OBJECT command3 AS commandbutton WITH ;
    Top = 363, ;
    Left = 615, ;
    Height = 27, ;
    Width = 24, ;
    Caption = "X", ;
    Name = "Command3"


  PROCEDURE _print
    lparameters lcText, lnColor, lnAngle,x,y,xsize
    #DEFINE ANSI_CHARSET          0
    #DEFINE OUT_DEFAULT_PRECIS    0
    #DEFINE OUT_DEVICE_PRECIS     5
    #DEFINE OUT_OUTLINE_PRECIS    8

    #DEFINE CLIP_DEFAULT_PRECIS   0
    #DEFINE CLIP_STROKE_PRECIS    2

    #DEFINE DEFAULT_QUALITY       0
    #DEFINE PROOF_QUALITY         2

    #DEFINE DEFAULT_PITCH         0
    #DEFINE FW_BOLD             700

    #DEFINE TRANSPARENT           1
    #DEFINE OPAQUE                2


      hFont = CreateFont (;
        xsize,0, lnAngle,lnAngle, FW_BOLD, 0,0,0, ANSI_CHARSET,;
        OUT_OUTLINE_PRECIS, CLIP_STROKE_PRECIS,;
        PROOF_QUALITY, DEFAULT_PITCH, "Monotype Corsiva")
      hwnd = GetActiveWindow()
      hdc = GetWindowDC (hwnd)
      * select new font into the device context
      * and delete the old one
      = DeleteObject (SelectObject (hdc, hFont))
      * set text color on a transparent background
      = SetTextColor (hdc, lnColor)
      = SetBkMode (hdc, TRANSPARENT)
      * the printing
      = TextOut (hdc, x, y, lcText, Len(lcText))
      * release system resources
      = DeleteObject (hFont)
      = ReleaseDC (hwnd, hdc)
  ENDPROC


  PROCEDURE Resize
    this.text1.top=this.height-30
    this.command1.top=this.text1.top
    this.command3.top=this.text1.top
    this.text1.width=this.width/3
    THIS.TEXT1.left=this.width/2-this.text1.width
    this.command1.left=this.text1.left+this.text1.width+2
    this.command3.left=this.command1.left+this.command1.width+2

    if tour=1
    thisform.command1.click
    endi
  ENDPROC


  PROCEDURE Init
  THISFORM.TITLEBAR=0
    publi tour
    tour=0
      DECLARE INTEGER GetActiveWindow IN user32
      DECLARE INTEGER GetWindowDC IN user32 INTEGER hwnd
      DECLARE INTEGER DeleteObject IN gdi32 INTEGER hObject
      DECLARE INTEGER ReleaseDC IN user32;
        INTEGER hwndINTEGER hdc
      DECLARE INTEGER SetTextColor IN gdi32;
        INTEGER hdc, INTEGER crColor
      DECLARE INTEGER SelectObject IN gdi32;
        INTEGER hdc, INTEGER hObject
       DECLARE INTEGER TextOut IN gdi32;
        INTEGER hdc, INTEGER x, INTEGER y,;
        STRING  lpString, INTEGER nCount
        DECLARE INTEGER SetBkMode IN gdi32;
        INTEGER hdc, INTEGER iBkMode

      DECLARE INTEGER CreateFont IN gdi32;
        INTEGER nHeight, INTEGER nWidth,;
        INTEGER nEscapement, INTEGER nOrientation,;
        INTEGER fnWeight, INTEGER fdwItalic,;
        INTEGER fdwUnderline, INTEGER fdwStrikeOut,;
        INTEGER fdwCharSet,;
        INTEGER fdwOutputPrecision,;
        INTEGER fdwClipPrecision,;
        INTEGER fdwQuality,;
        INTEGER fdwPitchAndFamily,;
        STRING  lpszFace

        this.resize()

        THISFORM.TEXT1.SETFOCUS()
  ENDPROC

PROCEDURE MOUSEDOWN
LPARAMETERS nButton, nShift, nXCoord, nYCoord
DECLARE INTEGER GetFocus IN WIN32API
lnHandle = GetFocus()
param1 = 274
param2 = 0xF012
DECLARE INTEGER ReleaseCapture IN WIN32API
DECLARE INTEGER SendMessage IN WIN32API INTEGERINTEGERINTEGERINTEGER
bb=ReleaseCapture()
bb=SendMessage(lnHandle, param1, param2,0)
ENDPROC

  PROCEDURE Destroy
  CLEA DLLS
    clea events
  ENDPROC


  PROCEDURE command1.Click
    tour=1
    THISFORM.CLS
    IF EMPTY(THISFORM.TEXT1.VALUE)
      lcText = "Yousfi Benameur"
    else
      lcText =thisFORM.text1.value
    endi

    x=120
    y=320+70
    xsize=36
    thisform._print (lcText, Rgb(164,0,0), 0,x,y,xsize)

    x=100
    y=320+70
    xsize=36
    thisform._print (lcText, Rgb(164,210,155), 900,x,y,xsize)

    x=120
    y=300+70
    thisform._print (lcText, Rgb(164,10,100), 450,x,y,xsize)

    x=440
    y=170+70
    xsize=16

    FOR ii=3600 TO 1 STEP-100
        lnColor = Rgb(Max(0,255-ii), Max(0,128-ii*5), Min(255,128+ii*10))
        thisform._print (lcText, lnColor, -ii,x,y,xsize)
        ii = ii -120
        thisform._print (lcText, Rgb(80,80,80),-ii,x,y,xsize)
    ENDFOR

    lcText1="VFP6.0"
    x=440
    y=315+70
    xsize=48
    thisform._print (lcText1, Rgb(184,5,150), 0,x,y,xsize)


  ENDPROC


  PROCEDURE command3.Click
    CLEA
    THISFORM.RELEASE
  ENDPROC




ENDDEFINE
*
*-- EndDefine: ywrite_form
**************************************************

Commentaires
Aucun commentaire enregistré ...

Publicité

Les pubs en cours :

www.atoutfox.org - Site de la Communauté Francophone des Professionnels FoxPro - v3.4.0 - © 2004-2024.
Cette page est générée par un composant COM+ développé en Visual FoxPro 9.0-SP2-HF3