2003-12-31 15:52

'=======================================================
' Type Objet
' Classe QImageDialog version 1.0
'=======================================================
     $IFNDEF TRUE
      $DEFINE True 1
     $ENDIF

     $IFNDEF FALSE
      $DEFINE False 0
     $ENDIF

     $IFNDEF boolean
      $DEFINE boolean INTEGER
     $ENDIF

     DECLARE FUNCTION ImgDlgGetDrive LIB "kernel32" ALIAS "GetDriveTypeA" (nDrive AS STRING) AS LONG
     DECLARE FUNCTION ImgDlgSetFocus LIB "USER32" ALIAS "SetFocus" (Handle AS LONG) AS LONG
     DECLARE FUNCTION ImgDlgGetSystemDir LIB "kernel32" ALIAS "GetSystemDirectoryA" (lpBuffer AS LONG,nSize AS LONG) AS LONG
     DECLARE FUNCTION ImgDlgCreateDC LIB "gdi32" ALIAS "CreateCompatibleDC" (hdc AS LONG) AS LONG
     DECLARE FUNCTION ImgDlgSelectObject LIB "gdi32" ALIAS "SelectObject" (hdc AS LONG,hObject AS LONG) AS LONG
     DECLARE FUNCTION ImgDlgBitBlt LIB "gdi32" ALIAS "BitBlt" (hDestDC AS LONG,x AS LONG,y AS LONG,nWidth AS LONG,nHeight AS LONG,hSrcDC AS LONG,xSrc AS LONG,ySrc AS LONG,dwRop AS LONG) AS LONG
     DECLARE FUNCTION ImgDlgDeleteDC LIB "gdi32" ALIAS "DeleteDC" (hdc AS LONG) AS LONG
     DECLARE FUNCTION ImgDlgDeleteObject LIB "gdi32" ALIAS "DeleteObject" (hObject AS LONG) AS LONG
     DECLARE FUNCTION ImgDlgDrawIcon LIB "user32" ALIAS "DrawIconEx" (hdc AS LONG,xLeft AS LONG,yTop AS LONG,hIcon AS LONG,cxWidth AS LONG,cyWidth AS LONG,istepIfAniCur AS LONG,hbrFlickerFreeDraw AS LONG,diFlags AS LONG) AS LONG
     DECLARE FUNCTION ImgDlgExtractIcon LIB "shell32.dll" ALIAS "ExtractIconA" (hInst AS LONG,lpszExeFileName AS STRING,nIconIndex AS LONG) AS LONG
     DECLARE FUNCTION ImgDlgDestroyIcon LIB "user32" ALIAS "DestroyIcon" (hIcon AS LONG) AS LONG

     DECLARE FUNCTION ImgDlgLoad LIB "NVIEWLIB" ALIAS "NViewLibLoad" (FileName AS STRING,Progress AS INTEGER) AS LONG
     DECLARE FUNCTION ImgDlgSetLanguage LIB "NVIEWLIB" ALIAS "NViewLibSetLanguage" (Language AS STRING) AS INTEGER
     DECLARE FUNCTION ImgDlgGetWidth LIB "NVIEWLIB" ALIAS "GetWidth" () AS INTEGER
     DECLARE FUNCTION ImgDlgGetHeight LIB "NVIEWLIB" ALIAS "GetHeight" () AS INTEGER

     TYPE QImageDialog EXTENDS QOBJECT
Private:
      Form AS QFORM
      Label1 AS QLABEL
      Label2 AS QLABEL
      Drive AS QCOMBOBOX
      DirList AS QFILELISTBOX
      FileList AS QFILELISTBOX
      Name AS QEDIT
      FileType AS QCOMBOBOX
      BtOpen AS QBUTTON
      BtCancel AS QBUTTON
      ScrollBox1 AS QSCROLLBOX
      Image AS QIMAGE
      Bitmap AS QBITMAP
      OPEN AS INTEGER
      PopupMenu AS QPOPUPMENU
      EnterKey AS QMENUITEM
      BoxWidth AS INTEGER
      BoxHeight AS INTEGER
      Path AS STRING
      DllName AS STRING
Public:
      FileName AS STRING PROPERTY SET SetFileName
      CAPTION AS STRING PROPERTY SET SetCaption
      Filter AS STRING PROPERTY SET SetFilter
      FilterIndex AS INTEGER PROPERTY SET SetFilterIndex
      InitialDir AS STRING
      DlgCaption(4) AS STRING
      ErrorLanguage AS STRING
      MultiSelect AS boolean PROPERTY SET SetMultiSelect
      SelCount AS INTEGER PROPERTY SET SetSelCount
      Selected AS QSTRINGLIST

Private:
  '======================================================
  ' Méthode retourne le nombre de filtre type de fichier
  '======================================================
      FUNCTION FilterCount(Filter AS STRING) AS INTEGER
       DIM count AS INTEGER
       DIM flag AS boolean

       flag=false
       count=0
       WHILE flag=false
        count++
        IF FIELD$(Filter,"|",count)="" THEN flag=true
       WEND
       result=count-1
      END FUNCTION

  '=================================================
  ' Méthode retourne l'index champs
  '=================================================
      FUNCTION GetField(name AS STRING,Filter AS STRING) AS INTEGER
       DIM i AS INTEGER

       IF name<>"" AND Filter<>"" THEN
        FOR i=1 TO This.FilterCount(This.Filter)
         IF FIELD$(Filter,"|",i)=name THEN
          result=i
          EXIT FOR
         END IF
        NEXT i
       ELSE
        result=0
       END IF
      END FUNCTION

  '=================================================
  ' Méthode initialise les lecteurs présents
  '=================================================
      SUB GetDrives
       DIM ASC_A AS INTEGER
       DIM ASC_Z AS INTEGER
       DIM i AS INTEGER
       DIM name AS STRING

       ASC_A=65
       ASC_Z=ASC_A+25
       This.Drive.Clear
       FOR i=ASC_A TO ASC_Z
        IF ImgDlgGetDrive(CHR$(i)&":\")<>1 THEN
         name=CHR$(i)+":\"
         This.Drive.AddItems name
        END IF
       NEXT i
       FOR i=0 TO This.Drive.ItemCount-1
        IF INSTR(UCASE$(This.Drive.Item(i)),UCASE$(this.DirList.drive+":\"))>0 THEN
         this.Drive.ItemIndex=i
         EXIT FOR
        END IF
       NEXT i
      END SUB

  '=================================================
  ' Méthode retourne le rapport en pourcentage
  '=================================================
      FUNCTION Ratio(Value1 AS DOUBLE,Value2 AS DOUBLE) AS DOUBLE
       Result=((Value1-Value2)*100)/Value1
      END FUNCTION

  '=================================================
  ' Méthode affiche l'image avec la réduction
  '=================================================
      SUB ShowImage
       DEFINT reduction=100
       DEFINT reduction1=100
       DEFINT reduction2=100

       IF this.bitmap.Width>this.BoxWidth OR this.bitmap.Height>this.BoxHeight THEN
        IF this.bitmap.Width>this.BoxWidth THEN
         reduction1=100-this.Ratio(this.bitmap.Width,this.BoxWidth)
        END IF
        IF this.bitmap.Height>this.BoxHeight THEN
         reduction2=100-this.Ratio(this.bitmap.Height,this.BoxHeight)
        END IF
        IF reduction1<reduction2 THEN
         reduction=reduction1
        ELSE
         reduction=reduction2
        END IF
        IF reduction1=reduction2 THEN reduction=reduction1
       END IF
       this.Image.left=INT((this.ScrollBox1.Width-((this.bitmap.Width*reduction)/100))/2)
       this.Image.top=INT((this.ScrollBox1.Height-((this.bitmap.Height*reduction)/100))/2)
       this.Image.Width=INT(this.bitmap.Width*(reduction/100))
       this.Image.Height=INT(this.bitmap.Height*(reduction/100))
       this.Image.bmp=this.bitmap.bmp
       this.Image.visible=true
      END SUB

  '=================================================
  ' Méthode retourne la présence de la dll
  '=================================================
      FUNCTION DllExist() AS boolean
       DIM lpBuffer AS STRING
       DIM SystemDir AS STRING
       DIM size AS SHORT

       IF FILEEXISTS(this.Path+this.DllName) THEN
        result=true
       ELSE
        lpBuffer=SPACE$(260)
        size=ImgDlgGetSystemDir(VARPTR(lpBuffer),260)
        SystemDir=LEFT$(lpBuffer,size)
        IF FILEEXISTS(SystemDir+"\"+this.DllName) THEN
         result=true
        ELSE
         result=false
        END IF
       END IF
      END FUNCTION

  '=================================================
  ' Méthode retourne le repertoire formaté
  '=================================================
      FUNCTION GetFormatDir(directory AS STRING) AS STRING
       IF rinstr(directory,"\")=LEN(directory) THEN
        result=directory
       ELSE
        result=directory+"\"
       END IF
      END FUNCTION

  '==================================================
  ' Méthode ouvre les fichiers au format graphique
  ' de la dll
  '==================================================
      SUB LoadOtherImage(FileName AS STRING)
       DIM hDC AS INTEGER
       DIM hBitmap AS INTEGER
       DIM hOldBitmap AS INTEGER

       hBitmap=ImgDlgLoad(FileName,false)
       IF hBitmap<>0 THEN
        this.bitmap.pixelformat=6
        this.bitmap.width=ImgDlgGetWidth()
        this.bitmap.height=ImgDlgGetHeight()
        hDC=ImgDlgCreateDC(this.bitmap.handle)
        hOldBitmap=ImgDlgSelectObject(hDC,hBitmap)
        ImgDlgBitBlt(this.bitmap.handle,0,0,this.bitmap.width,this.bitmap.height,hDC,0,0,&HCC0020)
        ImgDlgSelectObject(hDC,hOldBitmap)
        ImgDlgDeleteDC(hDC)
        ImgDlgDeleteObject(hBitmap)
       END IF
      END SUB

  '=================================================
  ' Méthode ouvre les fichiers icone et curseur
  '=================================================
      SUB LoadIcon(FileName AS STRING)
       DIM hIcon AS LONG

       hIcon=ImgDlgExtractIcon(0,FileName,0)
       IF hIcon<>0 THEN
        this.bitmap.pixelformat=6
        this.bitmap.width=32
        this.bitmap.height=32
        this.bitmap.fillRect(0,0,32,32,this.ScrollBox1.COLOR)
        ImgDlgDrawIcon(this.bitmap.handle,0,0,hIcon,32,32,0,0,&h3)
        ImgDlgDestroyIcon(hIcon)
       END IF
      END SUB

  '=================================================
  ' Méthode Retourne l'extension valide d'un
  ' fichier prise en compte par la dll
  '=================================================
      FUNCTION DllFormat(FileName AS STRING) AS boolean
       IF INSTR(LCASE$(FileName),".gif")>0 THEN
        result=true
       ELSEIF INSTR(LCASE$(FileName),".jpg")>0 THEN
        result=true
       ELSEIF INSTR(LCASE$(FileName),".jif")>0 THEN
        result=true
       ELSEIF INSTR(LCASE$(FileName),".dib")>0 THEN
        result=true
       ELSEIF INSTR(LCASE$(FileName),".rle")>0 THEN
        result=true
       ELSEIF INSTR(LCASE$(FileName),".tga")>0 THEN
        result=true
       ELSEIF INSTR(LCASE$(FileName),".pcx")>0 THEN
        result=true
       ELSE
        result=false
       END IF
      END FUNCTION

  '=================================================
  ' Méthode change l'etat curseur
  '=================================================
      SUB WaitCursor(flag AS boolean)
       DIM value AS INTEGER

       IF flag THEN
        value=-11
       ELSE
        value=0
       END IF
       this.Form.cursor=value
       this.Drive.cursor=value
       this.DirList.cursor=value
       this.FileList.cursor=value
       this.FileType.cursor=value
       this.BtOpen.cursor=value
       this.BtCancel.cursor=value
       this.ScrollBox1.cursor=value
       this.Image.cursor=value
      END SUB

Public:
  '=================================================
  ' Proprieté définition filtre type de fichier
  '=================================================
      PROPERTY SET SetFilter(filter AS STRING)
       DIM i AS INTEGER

       This.Filter=filter
       IF filter<>"" THEN
        FOR i=1 TO This.FilterCount(This.Filter) STEP 2
         This.FileType.AddItems FIELD$(This.Filter,"|",i)
        NEXT i
       ELSE
        This.FileType.Clear
       END IF
      END PROPERTY

  '=================================================
  ' Proprieté index filtre type de fichier
  '=================================================
      PROPERTY SET SetFilterIndex(FilterIndex AS INTEGER)
       DIM i AS INTEGER

       IF This.FileType.ItemCount>0 THEN
        This.FilterIndex=FilterIndex
        This.FileType.ItemIndex=FilterIndex
       END IF
      END PROPERTY

  '=================================================
  ' Proprieté titre boite de dialogue
  '=================================================
      PROPERTY SET SetCaption(CAPTION AS STRING)
       This.CAPTION=CAPTION
       This.Form.CAPTION=CAPTION
      END PROPERTY

  '=================================================
  ' Proprieté sélection multiple fichiers
  '=================================================
      PROPERTY SET SetMultiSelect(SELECT AS boolean)
       This.FileList.MultiSelect=SELECT
       This.MultiSelect=SELECT
      END PROPERTY

  '=================================================
  ' Proprieté nombre de fichiers sélectionnés
  '=================================================
      PROPERTY SET SetSelCount(count AS INTEGER)
    'Read only
      END PROPERTY

  '=================================================
  ' Proprieté nom fichier
  '=================================================
      PROPERTY SET SetFileName(filename AS STRING)
       IF INSTR(filename,"\")>0 THEN
        this.name.text=RIGHT$(filename,LEN(filename)-RINSTR(filename,"\"))
        IF DIREXISTS(LEFT$(filename,RINSTR(filename,"\"))) THEN
         this.DirList.Directory=LEFT$(filename,RINSTR(filename,"\"))
         this.FileList.Directory=LEFT$(filename,RINSTR(filename,"\"))
        END IF
       ELSE
        this.name.text=filename
       END IF
      END PROPERTY

  '=================================================
  ' Méthode ouverture boite de dialogue
  '=================================================
      FUNCTION EXECUTE() AS boolean
       This.Label1.CAPTION=this.DlgCaption(1)
       This.Label2.CAPTION=this.DlgCaption(2)
       This.BtOpen.CAPTION=this.DlgCaption(3)
       This.BtCancel.CAPTION=this.DlgCaption(4)
       This.OPEN=False
       This.GetDrives
       IF This.InitialDir<>"" THEN
        IF DIREXISTS(This.InitialDir) THEN
         this.DirList.Directory=This.InitialDir
         this.FileList.Directory=This.InitialDir
        END IF
       ELSE
        this.DirList.Directory=CURDIR$
        this.FileList.Directory=CURDIR$
       END IF
       IF This.FileType.ItemCount>0 THEN
        This.FileType.ItemIndex=This.FilterIndex
        This.FileList.Mask=FIELD$(This.Filter,"|",This.GetField(This.FileType.Item(This.FilterIndex),This.Filter)+1)
       END IF
       ImgDlgSetFocus(This.Name.Handle)
       This.Form.SHOWMODAL
       Result=This.OPEN
      END FUNCTION

  '=================================================
  ' Evenement double click sur liste repertoires
  '=================================================
      EVENT DirList.OnDblClick
       CHDIR(this.DirList.Item(this.DirList.ItemIndex)-"["-"]")
       this.DirList.Directory=CURDIR$
       this.FileList.Directory=CURDIR$
       this.Image.visible=false
       This.Name.Text=""
      END EVENT

  '=================================================
  ' Evenement changement sélection lecteurs
  '=================================================
      EVENT Drive.OnChange
       this.DirList.Directory=this.Drive.item(this.Drive.itemindex)
       this.FileList.Directory=this.Drive.item(this.Drive.itemindex)
       this.Image.visible=false
       This.Name.Text=""
      END EVENT

  '=================================================
  ' Evenement changement sélection type de fichiers
  '=================================================
      EVENT FileType.OnChange
       This.FilterIndex=This.FileType.ItemIndex
       This.FileList.Mask=FIELD$(This.Filter,"|",This.GetField(This.FileType.Item(This.FilterIndex),This.Filter)+1)
       This.FileList.Update
      END EVENT

  '=================================================
  ' Evenement click liste fichiers
  '=================================================
      EVENT FileList.OnClick
       This.Name.Text=RIGHT$(This.FileList.FileName,LEN(This.FileList.FileName)-RINSTR(This.FileList.FileName,"\"))
       IF INSTR(LCASE$(This.FileList.FileName),".bmp")>0 THEN
        This.WaitCursor(true)
        this.bitmap.bmp=This.FileList.FileName
        this.ShowImage
        This.WaitCursor(false)
       ELSEIF INSTR(LCASE$(This.FileList.FileName),".ico")>0 OR _
         INSTR(LCASE$(This.FileList.FileName),".ani")>0 OR _
         INSTR(LCASE$(This.FileList.FileName),".cur")>0 THEN
         this.LoadIcon(This.FileList.FileName)
         this.ShowImage
        ELSEIF this.DllFormat(This.FileList.FileName) THEN
         IF this.DllExist() THEN
          IF this.ErrorLanguage<>"" THEN ImgDlgSetLanguage(this.ErrorLanguage)
          This.WaitCursor(true)
          this.LoadOtherImage(This.FileList.FileName)
          this.ShowImage
          This.WaitCursor(false)
         ELSE
          this.Image.visible=false
         END IF
        ELSE
         this.Image.visible=false
        END IF
       END EVENT

  '=================================================
  ' Evenement click sur bouton ouvrir
  '=================================================
       EVENT BtOpen.OnClick
        DIM i AS INTEGER

        IF This.Name.Text<>"" THEN
         This.OPEN=True
         This.FileName=This.GetFormatDir(this.FileList.Directory)+This.Name.Text
         IF this.FileList.SelCount>1 THEN
          this.SelCount=this.FileList.SelCount
          This.Selected.Clear
          FOR i=0 TO this.FileList.ItemCount-1
           IF this.FileList.Selected(i) THEN
            This.Selected.AddItems(This.GetFormatDir(this.FileList.Directory)+this.FileList.Item(i))
           END IF
          NEXT i
         END IF
         This.Form.ModalResult=1
        END IF
       END EVENT

  '=================================================
  ' Evenement click sur bouton annuler
  '=================================================
       EVENT BtCancel.OnClick
        This.Form.ModalResult=1
       END EVENT

  '=================================================
  ' Evenement entrer sur liste repertoires
  '=================================================
       EVENT EnterKey.OnClick
        CHDIR(this.DirList.Item(this.DirList.ItemIndex)-"["-"]")
        this.DirList.Directory=CURDIR$
        this.FileList.Directory=CURDIR$
        this.Image.visible=false
        This.Name.Text=""
       END EVENT

       CONSTRUCTOR
        DlgCaption(1)="File name:"
        DlgCaption(2)="File type:"
        DlgCaption(3)="Open"
        DlgCaption(4)="Cancel"
        Form.CAPTION="Open"
        Form.Width=422
        Form.Height=325
        Form.Center
        Form.borderstyle=3
        Label1.PARENT=this.form
        Label1.CAPTION=this.DlgCaption(1)
        Label1.Left=5
        Label1.Top=245
        Label1.AutoSize=True
        Label2.PARENT=this.form
        Label2.CAPTION=this.DlgCaption(2)
        Label2.Left=5
        Label2.Top=272
        Label2.AutoSize=True
        Drive.PARENT=this.form
        Drive.TabOrder=1
        Drive.Style=2
        Drive.Left=5
        Drive.Top=5
        DirList.PARENT=this.form
        DirList.Left=5
        DirList.Top=30
        DirList.Height=100
        DirList.ShowIcons = True
        DirList.AddFileTypes(4)
        DirList.DelFileTypes(6)
        DirList.TabOrder=2
        FileList.PARENT=this.form
        FileList.Left=5
        FileList.Top=135
        FileList.Height=100
        FileList.TabOrder=3
        Name.PARENT=this.form
        Name.Left=106
        Name.Top=242
        Name.Width=217
        Name.TabOrder=4
        FileType.PARENT=this.form
        FileType.Style=2
        FileType.Left=106
        FileType.Top=270
        FileType.Width=217
        FileType.TabOrder=5
        BtOpen.PARENT=this.form
        BtOpen.CAPTION=this.DlgCaption(3)
        BtOpen.Left=334
        BtOpen.Top=242
        BtOpen.Height=22
        BtOpen.TabOrder=6
        BtCancel.PARENT=this.form
        BtCancel.CAPTION=this.DlgCaption(4)
        BtCancel.Left=334
        BtCancel.Top=270
        BtCancel.Height=22
        BtCancel.TabOrder=7
        ScrollBox1.PARENT=this.form
        ScrollBox1.Left=158
        ScrollBox1.Top=5
        ScrollBox1.Width=250
        ScrollBox1.Height=230
        BoxWidth=220
        BoxHeight=220
        Image.PARENT=This.ScrollBox1
        Image.Visible=False
        Image.stretch=true
        EnterKey.ShortCut="Enter"
        EnterKey.Visible=False
        PopupMenu.AddItems(This.EnterKey)
        DirList.PopupMenu=This.PopUpMenu
        Path=LEFT$(COMMAND$(0),rinstr(COMMAND$(0),"\"))
        DllName="Nviewlib.dll"
       END CONSTRUCTOR
      END TYPE

2003-12-31 15:52