Extracteur d'icones et Transfert d'icone

[MLD]

Bonjour a tous

Je suis toujours aussi nul avec les images et dessins.
Et je sèche depuis plusieurs jours sur le problème suivant:
Comment faire le transfert d'une icône se trouvant dans une ListIconeGadget vers le presse papier?
Merci d'avance

Michel

PS Zorro tu devrais bien avoir une idée toi qui tritoulle les images comme un chef

[Zorro]

ben j'avais sortie un code qui converti les images en icone ...

le probleme du presspapier, c'est que c'est pas vraiment prevu pour des images (meme si on peut)
mais le format icone est particulier

mieux vaux ecrire ton icone en dur sur le Disque (via mon code .... je vais essayer de le retrouver )
que de passer par le presspapier ... qui ne sert vraiment qu'a transmettre du text (ou des liens)

voir code ici :
http://www.purebasic.fr/french/viewtopi ... ilit=icone

[falsam]

Bonjour MLD.

J'ai supposé que l'image de l'icone se situant dans un item de ta ListIconGadget() est aussi sur ton disque.

1-Dans ce cas tu peux stocker le nom du fichier en data-item avec la fonction SetGadgetItemData()
2-Quand un utilisateur clique sur un item, tu récupéres le nom du fichier correspondant à ton image avec la fonction GetGadgetItemData()
3-Tu charge l'image en mémoire
4-Tu copie l'image dans le presse papier avec la fonction SetClipboardImage()

Ouvre ton application de traitement d'images pour vérifier que ça fonctionne.

Code : Tout sélectionner

EnableExplicit

Enumeration Window
  #mf
EndEnumeration

Enumeration gadget
  #mfList
EndEnumeration

Declare Start()
Declare OnSelect()
Declare Exit()

Start()

Procedure Start()
  Protected FileName.s = #PB_Compiler_Home + "\examples\sources\data\CdPlayer.ico"
  Protected Image = LoadImage(-1, FileName)
  
  OpenWindow(#mf, 0, 0, 800, 600, "Test", #PB_Window_SystemMenu|#PB_Window_ScreenCentered)
  ListIconGadget(#mfList, 5, 5, 700, 580, "Col 0", 500)
  
  AddGadgetItem(#mfList, -1, "Une icone de test", ImageID(Image))
  
  ;Astuce pour associé une variable alphanumérique ou un pointeur à un item (ou un gadget)
  SetGadgetItemData(#mfList, CountGadgetItems(#mfList) - 1, @FileName) 
  
  ;Triggers
  BindGadgetEvent(#mfList, @OnSelect(), #PB_EventType_LeftClick)
  BindEvent(#PB_Event_CloseWindow, @Exit())
  
  Repeat : WaitWindowEvent() : ForEver
EndProcedure

Procedure OnSelect()
  Protected Item = GetGadgetState(#mfList)
  Protected FileName.s = PeekS(GetGadgetItemData(#mfList, Item))
  Protected Image = LoadImage(-1, FileName)
  
  SetClipboardImage(Image)  
EndProcedure

Procedure Exit()  
  End
EndProcedure

[falsam]

Cette deuxième solution évite de recharger l'image quand on clique sur l'item contenant l'icone.

Pour cette exercice j'ai sélectionné quatres images du dossier d'installation de PureBasic.

Code : Tout sélectionner

EnableExplicit

Enumeration Window
  #mf
EndEnumeration

Enumeration gadget
  #mfList
EndEnumeration

Declare Start()
Declare OnSelect()
Declare Exit()

Start()

Procedure Start()
  Protected Dim *Images(3), n
  
  UsePNGImageDecoder()
  ;Chargement de 4 images
  *Images(0) = LoadImage(#PB_Any, #PB_Compiler_Home + "\examples\sources\data\CdPlayer.ico")
  *Images(1) = LoadImage(#PB_Any, #PB_Compiler_Home + "\examples\sources\data\Drive.bmp")
  *Images(2) = LoadImage(#PB_Any, #PB_Compiler_Home + "\examples\sources\data\File.bmp")
  *Images(3) = LoadImage(#PB_Any, #PB_Compiler_Home + "\examples\sources\data\world.png")
  
  OpenWindow(#mf, 0, 0, 800, 600, "Test", #PB_Window_SystemMenu|#PB_Window_ScreenCentered)
  ListIconGadget(#mfList, 5, 5, 700, 580, "Col 0", 500)
  
  For n = 0 To 3
    AddGadgetItem(#mfList, -1, "Une image de test " + Str(n), ImageID(*Images(n)))
    
    ;Astuce pour associé une variable alphanumérique ou un pointeur à un item (ou un gadget)
    SetGadgetItemData(#mfList, CountGadgetItems(#mfList) - 1, *Images(n)) 
  Next
  
  ;Triggers
  BindGadgetEvent(#mfList, @OnSelect(), #PB_EventType_LeftClick)
  BindEvent(#PB_Event_CloseWindow, @Exit())
  
  Repeat : WaitWindowEvent() : ForEver
EndProcedure

Procedure OnSelect()
  Protected Item  = GetGadgetState(#mfList)
  Protected *Buffer = GetGadgetItemData(#mfList, Item)
  
  SetClipboardImage(*Buffer)  
EndProcedure

Procedure Exit()  
  End
EndProcedure

[MLD]

Merci a Zorro et falsam
en fait je souhaite faire pour les adeptes PB un extracteur d’icônes
Je pensai faire un fichier image.BMP, éventuellement ll transformer en ico ensuite le mettre dans le presse papier pour l'incorporer dans un dossier quelconque.
Mais j'ai un fichier image trés moche. avez vous d'autre idées ??
le bouton RAZ n'est pas fonctionnel
faite un essai avec C:\windows\system32\shell32 et l’icône 210
Le fait de sélectionner une icône produit automatiquement le fichier image.

Code : Tout sélectionner

;MLD EXTACTEUR D'ICONES 30/09/2017
;***constantes***
#fenpr =0:#eticpres = 1:#eticexp1 = 2:#eticexp2 = 3:#eticexp3 = 4:#eticexp4 = 5:#eticexp5 = 6
#explorer = 10:#cadre1 = 11:#cadre2 = 12:#cadre3 = 13:#cadre4 = 14
#text1 = 20:#coche1 = 23:#coche2 = 24:#listico = 25:#conteneur = 26:#gadimg = 27
#btraz = 31:#btok = 32:btstop = 33
#txtinfofich1 = 40:#txtinfonbico3 = 41:#txtfich = 42:#txtnbico = 43:#txt_attente = 44

Global FontID1 = LoadFont(50,"Tahoma",14,#PB_Font_Bold)
Global FontID2 = LoadFont(51,"Tahoma",12,#PB_Font_HighQuality)
Global FontID3 = LoadFont(52,"Segoe Print",16,#PB_Font_HighQuality)
Global FontID4 = LoadFont(53,"Tahoma",8,#PB_Font_HighQuality)
Global FontID5 = LoadFont(54,"Segoe Print",32,#PB_Font_HighQuality)
Global nbf.f
Global nbico.q,flagico.b =1,icontrans 
Global Dim tabicochem.s(0)

Macro couletic(gad)
  SetGadgetFont(gad,FontID3) 
  SetGadgetColor(gad,#PB_Gadget_FrontColor,$8515C7)
  SetGadgetColor(gad,#PB_Gadget_BackColor,$DCE4DC)
EndMacro

Procedure WindowProc(hWnd, msg, wParam, lParam)
   If msg=#WM_CTLCOLORSTATIC
    Select GetDlgCtrlID_(lParam)   
       Case 23 To 24
         ProcedureReturn CreateSolidBrush_($DCE4DC) 
    EndSelect
  EndIf
  ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure

Procedure Listico(fich$)
 Protected j, icon,nbi.q
  nbi.q =  ExtractIconEx_(fich$, -1, #Null, #Null, #Null) - 1
  If nbi <> -1
   For j = 0 To nbi.q 
     If GetGadgetState(23)
       z = ExtractIconEx_(fich$, j, #Null, @icon, 1)    ;16x16         
      Else
       z = ExtractIconEx_(fich$, j, @icon, #Null, 1) ;32x32    EndIf
     EndIf
     If z <> 0 
      nbico = nbico +1
      ReDim tabicochem.s(nbico)
      tabicochem.s(nbico)= fich$ +"," + Str(j)
      AddGadgetItem(25, j,Str(CountGadgetItems(25)+1), icon)
     EndIf  
     DestroyIcon_(icon)
   Next
  EndIf
EndProcedure
Structure InfoSDirectory
  SubDirectories.i
  Files.i
EndStructure
Define Info.InfoSDirectory
Procedure rech_ico(fich$, *Info.InfoSDirectory)
 nbf = nbf +1
 SetGadgetText(42,"F n°:"+ Str(nbf) + "  " + fich$ )  
 Protected Numf.q
  Numf.q = ExamineDirectory(#PB_Any, fich$, "*.*")
  If  Numf.q = 0
   a$ = LCase(Right(fich$,3))
   Select a$
    Case "exe","dll","icl","ico"
     Listico( fich$ )
   EndSelect 
  Else  
   If Numf.q
    While NextDirectoryEntry(Numf.q)
     If DirectoryEntryName(Numf.q) <> "." And DirectoryEntryName(Numf.q) <> ".."
      If DirectoryEntryType(Numf.q) = #PB_DirectoryEntry_File
       a$ = LCase(Right(fich$ + "\" + DirectoryEntryName(Numf.q),3))
        Select a$
         Case "exe","dll","icl","ico"
          Listico( fich$ + "\" + DirectoryEntryName(Numf.q))
         EndSelect
      Else
       *Info\SubDirectories + 1
       rech_ico(fich$ + "\" + DirectoryEntryName(Numf.q), *Info)
      EndIf
     EndIf
    Wend
    FinishDirectory(Numf.q)
   EndIf
  EndIf
EndProcedure

Procedure cdico()
 nbf.f = 0:HideGadget(40,0):HideGadget(42,0):HideGadget(41,1):HideGadget(43,1):HideGadget(25,1):HideGadget(44,0)
 ClearGadgetItems(25)
 fich$ = GetGadgetText(20)
 If fich$ = "Ce PC"
  For I = 0 To 12 ; balaye l'alphabet
   Lecteur.S = Chr(65 + I) + ":\"
   ID = ExamineDirectory(#PB_Any, Lecteur, "*")
   If ID
     While WindowEvent() : Wend  
     rech_ico(Lecteur.S,@Info )
      FinishDirectory(ID)
   EndIf
  Next
 Else
   While WindowEvent() : Wend 
  rech_ico(fich$,@Info)
 EndIf 
  HideGadget(40,1):HideGadget(42,1):HideGadget(41,0):HideGadget(43,0):HideGadget(25,0):HideGadget(44,1)
  SetGadgetText(43,Str(CountGadgetItems(25))) 
EndProcedure

Procedure selectico(numico.q)
  i$ = tabicochem.s(numico)
  fich$ =StringField(i$,1,",")
  j = Val(StringField(i$,2,","))
  If GetGadgetState(23)
   z = ExtractIconEx_(fich$, j, #Null, @icon, 1)    ;16x16         
  Else
   z = ExtractIconEx_(fich$, j, @icon, #Null, 1) ;32x32    EndIf
  EndIf
  If z <> 0
   SetGadgetState(27,icon)
   ID_Image = GetGadgetState(27)
   CreateImage(500, 32, 32,32,#PB_Image_Transparent)
   If StartDrawing(ImageOutput(500))
    BackColor(RGBA(255,255,255,0))
    DrawingMode(#PB_2DDrawing_Transparent)
    DrawImage(ID_Image, 0, 0)
    StopDrawing()
  EndIf
  SaveImage(500, "icone.bmp",#PB_ImagePlugin_BMP) ;c'est ici que ça coince ????????  l'image produite est trés moche. 
EndIf 
EndProcedure

OpenWindow(0,0,0,1600,900,"Ma Fenêtre",#PB_Window_BorderLess | #PB_Window_Invisible | #PB_Window_ScreenCentered)
SetWindowCallback(@WindowProc())
SetClassLongPtr_(WindowID(#fenpr),#GCL_STYLE,$00020000)
HideWindow(#fenpr,0)
SetWindowColor(#fenpr,$DCE4DC)
N$ = "        EXTRACT | ICONES"
For x = 1 To Len(N$)
 L$ = L$ + Mid(N$,x,1) + Chr(10) 
Next
TextGadget(1,0,0,30,900,L$,#PB_Text_Center)
SetGadgetColor(1,#PB_Gadget_BackColor,$7FFF00)
SetGadgetFont(1,FontID1)
TextGadget(2,40,10,100,28,"Source")
TextGadget(3,40,530,100,28,"Taille")
TextGadget(4,40,610,200,28,"Sélection / Copie")
TextGadget(5,40,710,150,28,"Commandes")
TextGadget(6,380,10,150,28,"Icone(s)")
For gad = 2 To 6
 couletic(gad)
Next
ExplorerTreeGadget(10,31,50,310,430, "",#PB_Explorer_NoMyDocuments|#PB_Explorer_GridLines|#PB_Explorer_AlwaysShowSelection )
SetGadgetColor(10,#PB_Gadget_BackColor,$DCE4DC)
SetGadgetColor(10,#PB_Gadget_FrontColor,$EE6E43)
SetGadgetColor(10,#PB_Gadget_LineColor,$13458B)
SetGadgetFont(10,FontID2)
FrameGadget(11,31,480,310,50,"",#PB_Frame_Flat)
FrameGadget(12,31,565,310,30,"",#PB_Frame_Flat)
FrameGadget(13,31,645,310,50,"",#PB_Frame_Flat)
FrameGadget(14,31,745,310,110,"",#PB_Frame_Flat)
TextGadget(20,32,481,308,40,"")
SetGadgetFont(20,FontID2)
SetGadgetColor(20,#PB_Gadget_BackColor,$DCE4DC)
SetGadgetColor(20,#PB_Gadget_FrontColor,$EE6E43)
OptionGadget(23,80,568,80,25,"16 X 16")
SetGadgetFont(23,FontID2)
OptionGadget(24,220,568,80,25,"32 X 32")
SetGadgetFont(24,FontID2)
SetGadgetState(24,1)
ContainerGadget(26,349,49,1231,806,#PB_Container_Double) 
SetGadgetColor(26,#PB_Gadget_BackColor,$DCE4DC)
ListIconGadget(25,0,0,1230,804, "Column 1", 100)
SetGadgetColor(25,#PB_Gadget_BackColor,$DCE4DC)
SetGadgetAttribute(25, #PB_ListIcon_DisplayMode, #PB_ListIcon_LargeIcon)
TextGadget(44,200,300,900,70,"Recherche et extraction d'icone(s)")
HideGadget(44,1)
SetGadgetColor(44,#PB_Gadget_BackColor,$DCE4DC)
SetGadgetFont(44,FontID5) 
CloseGadgetList()
ImageGadget(27,160,655, 35, 35, 0)
ButtonGadget(31,35,801,150,45,"R A Z")
ButtonGadget(32,35,755,301,45,"Extraction")
ButtonGadget(33,186,801,150,45,"Stop")
For x = 30 To 33
  SetGadgetFont(x,FontID2)
Next
TextGadget(40,40,865,180,28,"Examine fichiers:")
SetGadgetFont(40,FontID1) 
SetGadgetColor(40,#PB_Gadget_FrontColor,$FF0000)
TextGadget(41,1330,865,100,28,"Icone(s):")
SetGadgetFont(41,FontID1) 
SetGadgetColor(41,#PB_Gadget_FrontColor,$FF0000)
TextGadget(42,230,872,1200,20,"")
SetGadgetFont(42,FontID4) 
SetGadgetColor(42,#PB_Gadget_FrontColor,$E22B8A)
TextGadget(43,1440,865,140,28,"")
SetGadgetFont(43,FontID1) 
SetGadgetColor(43,#PB_Gadget_FrontColor,$FF0000)
For zz = 40 To 43
 SetGadgetColor(zz,#PB_Gadget_BackColor,$DCE4DC)
 HideGadget(zz,1)
Next 
;  Boucle générale
Repeat
Event = WaitWindowEvent(10)
 If Event = #WM_LBUTTONDOWN
  SendMessage_(WindowID(#fenpr), #WM_NCLBUTTONDOWN, #HTCAPTION, 0)
 EndIf
 If Event = #PB_Event_Gadget
   Select EventGadget()
     Case 10 ;source
       Select EventType()
         Case #PB_EventType_LeftClick
          If GetGadgetText(10) <> GetGadgetText(20) :ClearGadgetItems(25):EndIf 
          pathcible$ = GetGadgetText(10) 
          If pathcible$ = "":pathcible$ = "Ce PC":EndIf  
          SetGadgetText(20,pathcible$)
         EndSelect 
       Case 23; 16 x 16
         Dim tabicochem.s(0):nbico.q =0
         SetGadgetState(23, 1)
         cdico()
       Case 24; 32 x 32
        Dim tabicochem.s(0):nbico.q = 0
         SetGadgetState(24, 1)
         cdico()  
       Case 25
        Select EventType()
          Case #PB_EventType_LeftClick 
            item = GetGadgetState(25) 
            If item <> -1
              numitem$ = GetGadgetItemText(25,item )
              numitem.q = Val(numitem$)
              selectico(numitem.q)
            EndIf
        EndSelect
       Case 32
         Dim tabicochem.s(0):nbico.q = 0
         Dim tabicochem(0):nbico.q = 0
         cdico()
       Case 33 ;stop
         FreeArray(tabicochem.s())
         CloseWindow(0)
         Break 
   EndSelect
 EndIf
ForEver
End

falsam il me semble que tes codes ne rentre rien dans le presse papier??
Michel

[Zorro]

un extracteur a 2 balles

Code : Tout sélectionner

File.s =OpenFileRequester("ouvrir un fichier","c:\","*.exe;*.dll",0)
;File.s = "shell32.dll" ; < ---------------- le fichier dont on extrait les icones a décommenter pour tester

IconCount = ExtractIcon_(0, File, -1)
IconMax = IconCount-1
If IconMax>0
		Dim Icons.i(IconMax)
		For i = 0 To IconMax
				Icons(i) = ExtractIcon_(0, File, i)
		Next
		
		
		
		#W = 512
		#H = 384
		
		OpenWindow(0, 0, 0, #W, #H, "", #PB_Window_ScreenCentered | #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget)
		ListIconGadget(0, 10, 10, 400, 300, "Small icons", 96)
		SetGadgetAttribute(0, #PB_ListIcon_DisplayMode, #PB_ListIcon_LargeIcon)
		For i = 0 To IconMax
				AddGadgetItem(0, 0, "", Icons(i))
		Next
		
		Repeat
				Select WaitWindowEvent()
						Case #PB_Event_CloseWindow
						Break
				EndSelect
		ForEver
		Else 
		MessageRequester("info","pas d'icones la dedans")
Endif

[falsam]

@Zorro : J'aime bien ton extracteur a 2 balles. Je vais mettre à jour mon utilitaire de création d’icônes. Thank for sharing.

falsam il me semble que tes codes ne rentre rien dans le presse papier??

[PB 5.60] pas de souci.

[GallyHC]

Bonjour,

Je viens de tester le code de "falsam" et pour moi tout fonctionne, merci pour le partage.

Cordialement,
GallyHC

[MLD]

Oui Zorro c'est la base
Mais tous,les deux (ou trois maintenant)comment faite vous pour mertte l'icone extrait dans le presse papier et ensuite dans n'importe quel dossier présent sur le disque.
Comme windows quand vous cliquer sur un icone avec copier et coller dans un autre dossier.
Je suis parfois un lourd , mais je n'est pas encore compris.
Merçi Gally

[Zorro]

ben bong sang, je t'ai pourtant tout donnée la solution

mon code de conversion d'image en icone contient une procedure
qui permet de sauvegarder une icone
il m'a suffit de l'ajouter voila
le code suivant, va lire le contenu de la DLL "Shell32.dll"
puis va extraire les icones, ensuite, il va pondre les icones dans le meme dossier que le prg
sous la forme "1.ico" ,"2.ico" etc ...


avantage, pas besoin de passer par le presspapier, tu ponds, les icones, ou tu veux , (path a definir dans la fonction SaveIcone(Handle_icone,Chemin+nom_icone)

Code : Tout sélectionner

;***********************************************
;Titre  :*extracteur d'icone a 2 balles
;Auteur  : Zorro ; Sur melange de plusieurs sources trop ancienne pour savoir si j'en suis a l'origine ou pas LOL
;Date  :30/09/2017
;Heure  :14:51:58
;Version Purebasic :  PureBasic 5.60 (Windows - x86)
;Version de l'editeur :EPB V2.64
; Libairies necessaire : Aucune 
;***********************************************


;File.s =OpenFileRequester("ouvrir un fichier","c:\","*.exe;*.dll",0)
File.s = "shell32.dll" ; < ---------------- le fichier dont on extrait les icones
Declare.i saveicon(hicon, filename$)
;
IconCount = ExtractIcon_(0, File, -1)
IconMax = IconCount-1
If IconMax>0
		Dim Icons.i(IconMax)
		For i = 0 To IconMax
				Icons(i) = ExtractIcon_(0, File, i)
		Next
		calldebugger
		#W = 512
		#H = 384
		OpenWindow(0, 0, 0, #W, #H, "", #PB_Window_ScreenCentered | #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget)
		ListIconGadget(0, 10, 10, 400, 300, "Small icons", 96)
		SetGadgetAttribute(0, #PB_ListIcon_DisplayMode, #PB_ListIcon_LargeIcon)
		For i = 0 To IconMax
				AddGadgetItem(0, 0, "", Icons(i))
				SaveIcon( Icons(i), GetCurrentDirectory()+str(i)+".ico")
		Next
		Repeat
				Select WaitWindowEvent()
						Case #PB_Event_CloseWindow
						Break
				EndSelect
		ForEver
Else 
		MessageRequester("info","pas d'icones la dedans")
Endif
FOr i=0 to IconMax
		;SaveFileRequester("Choisissez un fichier à sauvegarder",Str(ExtractLargeIconFile(IconPath)), Filtre$, Filtre)
Next i
;
Procedure.i SaveIcon(hIcon, filename$)
		;Srod
		Protected result, iconinfo.ICONINFO, hbmMask, hbmColor
		Protected cbitmap.BITMAP, cwidth, cheight, cbitsperpixel, colorcount, colorplanes
		Protected mbitmap.BITMAP, mwidth, mheight, fIcon, xHotspot, yHotspot
		Protected file, imagebytecount, hdc, oldbitmap, mem, bytesinrow, temp
		Protected *bitmapinfo.BITMAPINFO
		;Get information regarding the icon.
		If Not(GetIconInfo_(hIcon, iconinfo)) : ProcedureReturn 0 : EndIf ;Not a valid icon handle.
		fIcon=2-iconinfo\fIcon  ;icon = 1, cursor = 2,
		If fIcon=2  ;Cursor.
				xHotspot=iconinfo\xHotspot
				yHotspot=iconinfo\yHotspot
		EndIf
		;Allocate memory for a BITMAPINFO structure + a color table with 256 entries.
		*bitmapinfo = AllocateMemory(SizeOf(BITMAPINFO) + SizeOf(RGBQUAD)<<8)
		If *bitmapinfo = 0 : ProcedureReturn 0 :EndIf
		;Get the mask (AND) bitmap, which, if the icon is B/W monochrome, contains the colour bitmap.
		hbmMask=iconinfo\hbmMask
		GetObject_(hbmMask, SizeOf(BITMAP),mbitmap)
		mwidth= mbitmap\bmWidth
		mheight= mbitmap\bmHeight
		;Get the colour (XOR) bitmap.
		hbmColor=iconinfo\hbmColor
		If hbmColor
				GetObject_(hbmColor, SizeOf(BITMAP),cbitmap)
				cwidth= cbitmap\bmWidth
				cheight= cbitmap\bmHeight
				cbitsperpixel = cbitmap\bmBitsPixel
				If cbitsperpixel = 0 : cbitsperpixel = 1 : EndIf
				If cbitsperpixel < 8
						colorcount=Pow(2,cbitsperpixel) ;colorcount = 0 if 8 or more bpp.
				EndIf
				colorplanes=cbitmap\bmplanes
		Else ;Monochrome icon.
				cwidth= mwidth
				cheight= mheight/2
				cbitsperpixel = 1
				colorcount=2
				colorplanes=1
				mheight=cheight
		EndIf
		;Ready to start creating the file.
		file=CreateFile(#PB_Any,filename$)
		If file
				;Write the data.
				;word = 0
				WriteWord(file,0)
				;word = 1 for icon, 2 for cursor.
				WriteWord(file,ficon) ;1 for icon, 2 for cursor.
				;word = number of icons in file.
				WriteWord(file,1)  ;***CHANGE IF EXTENDING CODE TO MORE THAN ONE ICON***
				;16 byte ICONDIRENTRY structure, one for each icon.
				WriteByte(file, cwidth)
				WriteByte(file, cheight)
				WriteByte(file, colorcount)
				WriteByte(file, 0) ;Reserved.
				If ficon=1   ;Icon.
						WriteWord(file, colorplanes) ;Should equal 1, -but just in case!
						WriteWord(file, cbitsperpixel)
				Else ;Cursor.
						WriteWord(file, xhotspot)
						WriteWord(file, yhotspot)
				EndIf
				WriteLong(file,0) ;TEMPORARY! WE NEED TO RETURN WHEN WE KNOW THE EXACT QUANTITY.
				; Size of (InfoHeader + ANDbitmap + XORbitmap)
				WriteLong(file,Loc(file)+4)  ;FilePos, where InfoHeader starts
				;Now the image data in the form BITMAPINFOHEADER (40 bytes) + colour map for the colour bitmap
				;+ bits of colour bitmap + bits of mask bitmap. Gulp! One for each icon.
				;40 byte BITMAPINFOHEADER structure.
				imagebytecount=SizeOf(BITMAPINFOHEADER)
				WriteLong(file, imagebytecount) ;Should be 40.
				WriteLong(file, cwidth)
				WriteLong(file, cheight+mheight) ;Combined heights of colour + mask images.
				WriteWord(file, colorplanes) ;Should equal 1, -but just in case!
				WriteWord(file, cbitsperpixel)
				WriteLong(file, 0) ;Compression.
				WriteLong(file, 0) ;Image size. Valid to set to zero if there's no compression.
				WriteLong(file, 0) ;Unused.
				WriteLong(file, 0) ;Unused.
				WriteLong(file, 0) ;Unused.
				WriteLong(file, 0) ;Unused.
				;Colour map. Only applies for <= 8 bpp.
				hdc=CreateCompatibleDC_(0) ;Needed in order to get the colour table.
				If hbmColor = 0   ;Monochrome icon.
						WriteLong(file, #Black)
						WriteLong(file, #White)
						imagebytecount+SizeOf(rgbquad)*2
				Elseif cbitsperpixel<=8 ;Includes 1 bit non-monochrome icons.
						;Get colour table.
						temp=Pow(2,cbitsperpixel)
						bytesinrow = SizeOf(rgbquad)*temp
						mem=AllocateMemory(bytesinrow)
						oldbitmap=SelectObject_(hdc, hbmColor)
						GetDIBColorTable_(hdc, 0, temp, mem)     
						WriteData(file, mem, bytesinrow) ;Write color table.
						FreeMemory(mem)
						SelectObject_(hdc, oldbitmap)
						imagebytecount+bytesinrow
				Endif
				;Now the colour image bits. We use GetDiBits_() for this.
				bytesinrow = (cwidth*cbitsperpixel+31)/32*4  ;Aligned to a 4-byte boundary.
				bytesinrow * cheight
				mem=AllocateMemory(bytesinrow)
				*bitmapinfo\bmiHeader\biSize=SizeOf(BITMAPINFOHEADER)
				*bitmapinfo\bmiHeader\biWidth=cwidth
				*bitmapinfo\bmiHeader\biPlanes=colorplanes
				*bitmapinfo\bmiHeader\biBitCount=cbitsperpixel
				If hbmColor
						*bitmapinfo\bmiHeader\biHeight=cheight
						GetDIBits_(hdc,hbmColor,0,cheight,mem,*bitmapinfo,#DIB_RGB_COLORS)
				Else ;Monochrome color image is the bottom half of the mask image.
						*bitmapinfo\bmiHeader\biHeight=2*cheight
						GetDIBits_(hdc,hbmMask,0,cheight,mem,*bitmapinfo,#DIB_RGB_COLORS)
				Endif
				WriteData(file, mem, bytesinrow)
				FreeMemory(mem)
				imagebytecount+bytesinrow
				;Now the mask image bits. We use GetDiBits_() for this.
				bytesinrow = (mwidth+31)/32*4  ;Aligned to a 4-byte boundary.
				bytesinrow * mheight
				mem=AllocateMemory(bytesinrow)
				*bitmapinfo\bmiHeader\biWidth=mwidth
				*bitmapinfo\bmiHeader\biPlanes=1
				*bitmapinfo\bmiHeader\biBitCount=1
				If hbmColor
						*bitmapinfo\bmiHeader\biHeight=mheight
						GetDIBits_(hdc,hbmMask,0,mheight,mem,*bitmapinfo,#DIB_RGB_COLORS)
				Else
						*bitmapinfo\bmiHeader\biHeight=2*mheight
						GetDIBits_(hdc,hbmMask,mheight,mheight,mem,*bitmapinfo,#DIB_RGB_COLORS)
				EndIf
				WriteData(file, mem, bytesinrow)
				FreeMemory(mem)
				imagebytecount+bytesinrow
				DeleteDC_(hdc)
				;Finally, return to the field we missed out.
				FileSeek(file, 14)
				WriteLong(file, imagebytecount)
		CloseFile(file)
		result= 1 ;Signal everything is fine.
		Else ;>
		result= 0
		EndIf;>
		DeleteObject_(hbmMask) ;These are copies created as a result of GetIconInfo_() and so require deleting.
		DeleteObject_(hbmColor)
		FreeMemory(*bitmapinfo)
		ProcedureReturn result
EndProcedure
; Epb

[MLD]

@zorro merçi beaucoup.
Avec ton code je pense pouvoir faire un truc sympa . Tu mas fais entrevoir une petite lumière
Mais comme je suis Breton, je suis têtu. Je pense toujours que ce serait mieux avec le presse papier.
PB manque cruellement de fonctions de manipulation d'icône.
Si d'autres ont des idées, ils sont les bien venus

[MLD]

@falsam

Oui tes codes fonctionnent.Merci
J'avais zappé le fait qu'il fallait un logiciel de dessin pour voir l'icone.
J'avais tellement dans la tête d'utiliser le presse papier comme avec Windows que j'ai oublier l’essentiel.
Je verrai cela lundi car la soirée et le dimanche sont chargés

[zaphod_b]

Salut,

Pour utiliser le presse papier pour copier un fichier : en fait on transfère dans le presse papier le nom du fichier.

Je sais pas si c'est ce que tu veux, mais bon :

Code : Tout sélectionner

EnableExplicit
;
Procedure filenametoclipboard(f.s)
  Protected *df.dropfiles, hglobal.l,ilen,n,*mem
  ;
  If OpenClipboard_(0)
            EmptyClipboard_()
            iLen + StringByteLength(f,#PB_Ascii)
            *mem = AllocateMemory(iLen)
            PokeS(*mem, f,-1,#PB_Ascii)
            hGlobal = GlobalAlloc_(#GMEM_SHARE | #GMEM_MOVEABLE | #GMEM_ZEROINIT, SizeOf(DROPFILES) + iLen +SizeOf(ascii))
            *df = GlobalLock_(hGlobal)
            *df\pFiles = SizeOf(DROPFILES)
            *df\fWide = SizeOf(ascii)-1
            MoveMemory(*mem, *df + SizeOf(DROPFILES), iLen )
            GlobalUnlock_(hGlobal)
            SetClipboardData_(#CF_HDROP, hGlobal)            
            FreeMemory(*mem)
            CloseClipboard_() 
            EndIf
EndProcedure

Define fi.s
fi=GetPathPart(ProgramFilename())+"cf_hdrop.txt" ; choisir un fichier
filenametoclipboard(fi)

Pour copier il suffit de lancer un explorateur de fichiers, choisir un dossier et bouton droit puis faire coller.
Ca copie le fichier dont le nom est dans fi.

[falsam]

@zaphod_b: Je ne sais pas pourquoi je sens que tu es dans les choux.

PureBasic à une superbe librairie Clipboard qui comportes ces fonctions
-ClearClipboard()
-GetClipboardImage()
-GetClipboardText()
-SetClipboardImage()
-SetClipboardText()

[MLD]

@zaphod_b
Merci.
Bon je progresse. Quand ce sera chaud je vous passerait le plat.