2013-08-20 12:34

'=======================================================
' Type Objet
' Classe QICON Version 1.1
'=======================================================
     $IFNDEF TRUE
      $DEFINE True 1
     $ENDIF

     $IFNDEF FALSE
      $DEFINE False 0
     $ENDIF

     $IFNDEF boolean
      $DEFINE boolean INTEGER
     $ENDIF

     $IFNDEF __WIN32API				   'windows 32 definitions
      DECLARE FUNCTION ExtractAssociatedIcon LIB "shell32.dll" ALIAS "ExtractAssociatedIconA" (hInst AS LONG,ByRef lpIconPath AS STRING ,byref lpiIcon AS LONG) AS LONG
      DECLARE FUNCTION ExtractIcon LIB "shell32.dll" ALIAS "ExtractIconA" (hInst AS LONG,lpszExeFileName AS STRING,nIconIndex AS LONG) AS LONG
      DECLARE FUNCTION DestroyIcon LIB "user32" ALIAS "DestroyIcon" (hIcon AS LONG) AS LONG
      DECLARE FUNCTION DrawIcon 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

      CONST DI_MASK_ICO=&H1
      CONST DI_IMAGE_ICO=&H2
      CONST DI_NORMAL_ICO=DI_IMAGE_ICO OR DI_MASK_ICO
     $ENDIF

     DEFBYTE IconHead16(1 TO 62)={&h0,&h0,&h01,&h0,&h01,&h0,&h20,&h20,&h10,&h0,&h0,&h0,&h0,&h0,&hE8,&h02,&h0,&h0,&h16,&h0,&h0,&h0,&h28,&h0,&h0,&h0,&h20,&h0,&h0,&h0,&h40,&h0,&h0,&h0,&h01,&h0,&h04,&h0,&h0,&h0,&h0,&h0,&h80,&h02,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0}
     DEFBYTE IconHead256(1 TO 62)={&h0,&h0,&h01,&h0,&h01,&h0,&h20,&h20,&h0,&h0,&h01,&h0,&h08,&h0,&hA8,&h08,&h0,&h0,&h16,&h0,&h0,&h0,&h28,&h0,&h0,&h0,&h20,&h0,&h0,&h0,&h40,&h0,&h0,&h0,&h01,&h0,&h08,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0,&h0}
     DIM IconMem AS QMEMORYSTREAM


     TYPE QICON EXTENDS QOBJECT
Private:
      head AS STRING
      monochrome AS STRING
      AsciiData AS STRING
      bitmap AS QBITMAP
      databmp AS STRING
      dataTrans AS STRING
      maskBit AS STRING
Public:
      FileName AS STRING PROPERTY SET SetFileName
      count AS INTEGER
      handle AS LONG
      Associated AS boolean
      index AS INTEGER PROPERTY SET SetIndex


  '========================================
  ' proprieté nom fichier icone
  '========================================
      PROPERTY SET SetFileName(name AS STRING)
       DIM lpIcon AS LONG
       DIM Path AS STRING

       IF name<>"" THEN
        IF Qicon.handle<>0 THEN
         DestroyIcon(Qicon.handle)
        END IF
        IF Qicon.Associated THEN
         lpIcon=2
         Qicon.FileName=name
         Path=name
         Qicon.handle=ExtractAssociatedIcon(application.handle,Path,lpIcon)
         IF Qicon.handle>0 THEN Qicon.count=1
        ELSE
         Qicon.count=ExtractIcon(application.handle,name,-1)
         Qicon.FileName=name
         IF Qicon.count<>0 THEN
          Qicon.handle=ExtractIcon(application.handle,name,0)
         END IF
        END IF
       ELSE
        IF Qicon.handle<>0 THEN
         DestroyIcon(Qicon.handle)
        END IF
       END IF
      END PROPERTY

  '========================================
  ' proprieté index icone
  '========================================
      PROPERTY SET SetIndex(value AS INTEGER)
       IF Qicon.handle<>0 THEN
        DestroyIcon(Qicon.handle)
       END IF
       IF value<=Qicon.count THEN
        Qicon.handle=ExtractIcon(application.handle,Qicon.FileName,value)
       END IF
      END PROPERTY

Private:
  '==========================================
  ' méthode transforme binaire en decimal
  '==========================================
      FUNCTION BinToDec(bin AS STRING)AS LONG
       DIM bit AS INTEGER
       DIM i AS INTEGER
       DIM value AS INTEGER

       bin=REVERSE$(bin)
       bit=1
       value=0
       FOR i=1 TO LEN(bin)
        IF MID$(bin,i,1)="1" THEN value=value+bit
        bit=bit*2
       NEXT i
       result=value
      END FUNCTION

  '=============================================
  ' méthode transforme hexadecimal en decimal
  '=============================================
      FUNCTION HexToDec(hex AS STRING)AS LONG
       DIM bit AS LONG
       DIM valbit AS INTEGER
       DIM i AS INTEGER
       DIM value AS INTEGER

       hex=REVERSE$(hex)
       bit=1
       value=0
       FOR i=1 TO LEN(hex)
        IF MID$(hex,i,1)="A" THEN
         value=value+(10*bit)
        ELSEIF MID$(hex,i,1)="B" THEN
         value=value+(11*bit)
        ELSEIF MID$(hex,i,1)="C" THEN
         value=value+(12*bit)
        ELSEIF MID$(hex,i,1)="D" THEN
         value=value+(13*bit)
        ELSEIF MID$(hex,i,1)="E" THEN
         value=value+(14*bit)
        ELSEIF MID$(hex,i,1)="F" THEN
         value=value+(15*bit)
        ELSE
         value=value+(VAL(MID$(hex,i,1))*bit)
        END IF
        IF (bit*16)<2147483647 THEN bit=bit*16
       NEXT i
       result=value
      END FUNCTION

  '=============================================
  ' méthode création format icon 16 couleur
  '=============================================
      SUB CreateFormat16(bitmap AS QBITMAP,convert AS INTEGER)
       DIM i AS INTEGER

       IF convert<>true THEN
      ' mise au format 16 couleur du bitmap
        bitmap.width=32
        bitmap.height=32
        bitmap.pixelformat=2
        bitmap.fillRect(0,0,32,32,&hffffff)
      ' transfert icon dans bitmap
        DrawIcon(bitmap.handle,0,0,Qicon.handle,32,32,0,0,DI_NORMAL_ICO)
       ELSE
        bitmap.pixelformat=2
       END IF
    ' sauvegarde bitmap en memoire
       IconMem.position=0
       IconMem.size=0
       bitmap.savetostream(IconMem)
       IconMem.position=0
    'lecture données bitmap
       Qicon.databmp=IconMem.readStr(630)
       IconMem.CLOSE
       Qicon.head=""
    'creation en tete icone
       FOR i=1 TO 62
        Qicon.head=Qicon.head+CHR$(IconHead16(i))
       NEXT i
       Qicon.head=Qicon.head+MID$(Qicon.databmp,55,64)
    ' extraction pixel
       Qicon.databmp=RIGHT$(Qicon.databmp,512)
      END SUB

  '=============================================
  ' méthode création format icon 256 couleur
  '=============================================
      SUB CreateFormat256(bitmap AS QBITMAP,convert AS INTEGER)
       DIM i AS INTEGER
       DIM j AS INTEGER

       IF convert<>true THEN
      ' mise au format 256 couleur du bitmap
        bitmap.width=32
        bitmap.height=32
        bitmap.pixelformat=3
        bitmap.fillRect(0,0,32,32,&hffffff)
      ' transfert icon dans bitmap
        DrawIcon(bitmap.handle,0,0,Qicon.handle,32,32,0,0,DI_NORMAL_ICO)
       ELSE
        bitmap.pixelformat=3
       END IF
    ' sauvegarde bitmap en memoire
       IconMem.position=0
       IconMem.size=0
       bitmap.savetostream(IconMem)
       IconMem.position=0
    'lecture données asci du bitmap
       Qicon.databmp=IconMem.readStr(2102)
       IconMem.CLOSE
       Qicon.head=""
    'creation en tete icone 256 couleur
       FOR i=1 TO 62
        Qicon.head=Qicon.head+CHR$(IconHead256(i))
       NEXT i
    'ajout de la palette de couleur
       Qicon.head=Qicon.head+MID$(Qicon.databmp,55,1024)
    ' extraction pixel du bitmap
       Qicon.databmp=RIGHT$(Qicon.databmp,1024)
      END SUB

  '=================================================
  ' méthode création mask transparence 256 couleur
  '=================================================
      SUB CreateMask256
       DIM i AS INTEGER

    ' transformation data du bitmap pour la transparence
       Qicon.datatrans=""
       FOR i=1 TO LEN(Qicon.databmp)
        Qicon.AsciiData=HEX$(ASC(MID$(Qicon.databmp,i,1)))
        IF INSTR(Qicon.AsciiData,"13")>0 THEN
         Qicon.AsciiData=REPLACESUBSTR$(Qicon.AsciiData,"13","0")
         Qicon.datatrans=Qicon.datatrans+CHR$(Qicon.hexToDec(Qicon.AsciiData))
        ELSE
         Qicon.datatrans=Qicon.datatrans+MID$(Qicon.databmp,i,1)
        END IF
       NEXT i
    ' creation image monochrome pour le mask
       Qicon.maskBit=""
       Qicon.monochrome=""
       FOR i=1 TO LEN(Qicon.databmp)
        Qicon.AsciiData=HEX$(ASC(MID$(Qicon.databmp,i,1)))
        IF INSTR(Qicon.AsciiData,"13")>0 THEN
         Qicon.maskBit=Qicon.maskBit+"1"
        ELSE
         Qicon.maskBit=Qicon.maskBit+"0"
        END IF
       NEXT i
    ' transformation du mask en 8 bit
       FOR i=1 TO LEN(Qicon.maskBit) STEP 8
        Qicon.monochrome=Qicon.monochrome+CHR$(Qicon.BinToDec(MID$(Qicon.maskBit,i,8)))
       NEXT i
      END SUB

  '=================================================
  ' méthode création mask transparence 16 couleur
  '=================================================
      SUB CreateMask16
       DIM i AS INTEGER

       Qicon.datatrans=""
       FOR i=1 TO LEN(Qicon.databmp)
        Qicon.AsciiData=HEX$(ASC(MID$(Qicon.databmp,i,1)))
        IF INSTR(Qicon.AsciiData,"F")>0 THEN
         Qicon.AsciiData=REPLACESUBSTR$(Qicon.AsciiData,"F","0")
         Qicon.datatrans=Qicon.datatrans+CHR$(Qicon.hexToDec(Qicon.AsciiData))
        ELSE
         Qicon.datatrans=Qicon.datatrans+MID$(Qicon.databmp,i,1)
        END IF
       NEXT i
   ' creation mask en bit monochrome
       Qicon.maskBit=""
       Qicon.monochrome=""
       FOR i=1 TO LEN(Qicon.databmp)
        Qicon.AsciiData=HEX$(ASC(MID$(Qicon.databmp,i,1)))
        IF MID$(Qicon.AsciiData,7,1)="F" THEN
         Qicon.maskBit=Qicon.maskBit+"1"
        ELSE
         Qicon.maskBit=Qicon.maskBit+"0"
        END IF
        IF MID$(Qicon.AsciiData,8,1)="F" THEN
         Qicon.maskBit=Qicon.maskBit+"1"
        ELSE
         Qicon.maskBit=Qicon.maskBit+"0"
        END IF
       NEXT i
       FOR i=1 TO LEN(Qicon.maskBit) STEP 8
        Qicon.monochrome=Qicon.monochrome+CHR$(Qicon.BinToDec(MID$(Qicon.maskBit,i,8)))
       NEXT i
      END SUB

  '=================================================
  ' méthode création mask opaque
  '=================================================
      SUB CreateMaskOpaque
       DIM i AS INTEGER

       Qicon.monochrome=""
       FOR i=1 TO 128
        Qicon.monochrome=Qicon.monochrome+CHR$(0)
       NEXT i
      END SUB

Public:

  '=================================================
  ' méthode sauvegarde icone
  '=================================================
      SUB SaveToFile(FileName AS STRING,pixelFormat AS INTEGER,mask AS INTEGER)
       DIM file AS QFILESTREAM

       IF Qicon.handle<>0 THEN
        IF pixelFormat=2 THEN
         Qicon.CreateFormat16(Qicon.bitmap,false)
         IF mask THEN
          Qicon.CreateMask16
         ELSE
          Qicon.CreateMaskOpaque
         END IF
        ELSE
         Qicon.CreateFormat256(Qicon.bitmap,false)
         IF mask THEN
          Qicon.CreateMask256
         ELSE
          Qicon.CreateMaskOpaque
         END IF
        END IF
        file.OPEN(FileName,65535)
        file.WriteStr(Qicon.head,LEN(Qicon.head))
        IF mask THEN
         file.WriteStr(Qicon.datatrans,LEN(Qicon.datatrans))
        ELSE
         file.WriteStr(Qicon.databmp,LEN(Qicon.databmp))
        END IF
        file.WriteStr(Qicon.monochrome,LEN(Qicon.monochrome))
        file.CLOSE
       END IF
      END SUB

  '=================================================
  ' méthode sauvegarde bitmap au format icone
  '=================================================
      SUB SaveBmpToFile(bitmap AS QBITMAP,FileName AS STRING,pixelFormat AS INTEGER,mask AS INTEGER)
       DIM file AS QFILESTREAM

       IF bitmap.width=32 AND bitmap.height=32 THEN
        IF pixelFormat=2 THEN
         Qicon.CreateFormat16(bitmap,true)
         IF mask THEN
          Qicon.CreateMask16
         ELSE
          Qicon.CreateMaskOpaque
         END IF
        ELSE
         Qicon.CreateFormat256(bitmap,true)
         IF mask THEN
          Qicon.CreateMask256
         ELSE
          Qicon.CreateMaskOpaque
         END IF
        END IF
        file.OPEN(FileName,65535)
        file.WriteStr(Qicon.head,LEN(Qicon.head))
        IF mask THEN
         file.WriteStr(Qicon.datatrans,LEN(Qicon.datatrans))
        ELSE
         file.WriteStr(Qicon.databmp,LEN(Qicon.databmp))
        END IF
        file.WriteStr(Qicon.monochrome,LEN(Qicon.monochrome))
        file.CLOSE
       END IF
      END SUB
     END TYPE

2013-08-20 12:34