XL 2019 Probleme olepro32 et/ou LongPtr

[carlos]

Bonjour,
Je tourne sous VBA excel 64
Lorsque je veux importer une image sur mon USF j'ai l'errreur de" olepro32 qui n'est pas installée".
J'ai essayé de mettre Long en longPtr mais ca ne marche pas
. hPic As Longptr
hPal As Longptr
Voic mon code si quelqu'un peut ma'aider :
Option Explicit
Option Private Module
'!* MODULE NAME: Paste Picture
'!* AUTHOR & DATE: STEPHEN BULLEN, Business Modelling Solutions Ltd.
'!* 15 November 1998
'!* CONTACT: Stephen@BMSLtd.co.uk
'!* WEB SITE: http://www.BMSLtd.co.uk
'!un peu modifié par Ti (10/04)
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function IsClipboardFormatAvailable& Lib "user32" (ByVal wFormat%)
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function OleCreatePictureIndirect& Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle&, IPic As IPicture)
Private Declare PtrSafe Function CopyEnhMetaFile& Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare PtrSafe Function CopyImage& Lib "user32" (ByVal Handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
#Else
Private Declare Function IsClipboardFormatAvailable& Lib "user32" (ByVal wFormat%)
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare Function CloseClipboard& Lib "user32" ()
Private Declare Function OleCreatePictureIndirect& Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle&, IPic As IPicture)
Private Declare Function CopyEnhMetaFile& Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function CopyImage& Lib "user32" (ByVal Handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
#End If
Const CF_BITMAP = 2, CF_PALETTE = 9, CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0, LR_COPYRETURNORG = &H4
Const PICTYPE_BITMAP = 1, PICTYPE_ENHMETAFILE = 4

Private Function CreatePicture(hPic&, hPal&, lPicType&) As IPicture
Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
.hPic = hPic
.hPal = IIf(lPicType = CF_BITMAP, hPal, 0)
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set CreatePicture = IPic
End Function

Function PastePicture(Optional lXlPicType& = xlPicture) As IPicture
Dim hPtr&, lPicType&, hCopy&, hPicAvail&
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
hPicAvail = IsClipboardFormatAvailable(lPicType)
If hPicAvail <> 0 Then
If OpenClipboard(0&) > 0 Then
hPtr = GetClipboardData(lPicType)
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
CloseClipboard
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If
End Function

 

[patricktoulon]

Bonjour

Lorsque je veux importer une image sur mon USF j'ai l'errreur de" olepro32 qui n'est pas installée".

question 1°
qu'a telle de si spéciale cette image pour que tu soit obligée d'aller chercher le module create picture de stephen bullen

déjà ceci me perturbe
je suis étonné que Mr Bullen ai fait cette erreur dans les déclarations 64
Private Declare PtrSafe Function OleCreatePictureIndirect& Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle&, IPic As IPicture)

d'ailleurs toute les déclaration 64 sont fausses elle sont faites en vba 7 32 bits
je précise
"&" veut dire "As long" et pas "As LongPtr"

sans doute travaille t il en vba7 mais sur une version 32 comme moi d'ailleurs

mais j'insiste sur ma question 1

 

[carlos]

Bonjour patricktoulon,
Merci pour ta réponse.
Cette image est juste une capture d'ecran d'une plage de la feuille active. Rien de plus.
Je capture la plage puis la place dans mon controle image de mon USF.
Bonne journée

 

[patricktoulon]

re
Bonjour @carlos
si ce n'est que ça j'ai deux solutions simple prêt à l'emploi pour toi
pas la peine d'aller chercher le pastepicture de stephen bullen

1. méthode sans api avec un graphique
2. méthode copie avec en metafichier

ces deux méthodes sont dans le fichier joint

2 userforms utilisant chacun une méthodes

fonction prêtes à l'emploi

démo méthode 1

démo méthode 2

 

[carlos]

Super Merci Patrick toulon,
je regarde tes fichiers.
Bonne journée

 

[carlos]

Re,
J'ai cette erreur sur la solution 1.

 

[carlos]

Avec le chemin du fichier :
E

 

[carlos]

J'ai testé sous "D:" & "\mon image.gif" et ca marche.
Donc ton fichier fonctionne parfaitement.
J'ai donc un probleme avec mon dossier ou est enregistré ce fichier car il reprend le chemin du drive "Http ..."et non celui du chemin local. Je ne sais pas pourquoi nia qui demandé de m'aider

En tout cas, merci Patricktoulon d'avoir pris le temps de me faire 2 exemples d'import.
Bonne journée

 

[patricktoulon]

Bonjour
cherche les problème d’accès au dossier sharepoint
ça vient de là
tu dois bien trouver des exemples ici dans le forum

 

[patricktoulon]

re
remarque on s'en fout c'est une image temporaire
tu peux utiliser si tu es sur windows plein de solutions
par exemple
FICHIER=environ("userprofile")&"\Desktop\mon image.gif"
ou encore
FICHIER=environ("Temp")&"\mon image.gif"
etc.....

 

[carlos]

Re,
Oui ca marche. Super Merci.
Tres belle journée

 

[patricktoulon]