Como Carregar Imagens Dentro da Propria Planilha

Recentemente eu recebi o seguinte e-mail: “ Como carregar imagens dentro da propria planilha ??”. Então…

“Há muito tempo em uma galáxia muito distante…”

Essa é uma dúvida que atormenta vários entusiastas em VBA! E aqui você vai conseguir achar sua resposta.
Logo se você estava tentando saber como passar seu sistema para o cliente com as imagens (loadpicture) dentro da própria planilha chegou uma nova esperança!

Passo 1 – Faça seu formulário:

Conforme a imagem acima pegue a sua “Caixa de Ferramentas” e crie um “Controle de Imagem” e não esqueça de dar um nome (Name), pois vamos utiliza-lo mais tarde
Como exemplo você pode usar Image1

Passo 2 – Função API

Essa função API é o grande trunfo para a funcionalidade de carregar imagens Dentro da Propria Planilha , esta foi desenvolvida pelo Stephen Bullen.
Copie o código abaixo, crie um módulo em seu projeto vba e cole na integra.

Option Explicit
Option Compare Text

''' User-Defined Types for API Calls

'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

'Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type

'''Windows API Function Declarations

'Does the clipboard contain a bitmap/metafile?
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

'Open the clipboard to read
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

'Get a pointer to the bitmap/metafile
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

'Close the clipboard
Private Declare Function CloseClipboard Lib "user32" () As Long

'Convert the handle into an OLE IPicture interface.
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

'The API format types we're interested in
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture

'Some pointers
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long

'Convert the type of picture requested from the xl constant to the API constant
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)

'Check if the clipboard contains the required format
hPicAvail = IsClipboardFormatAvailable(lPicType)

If hPicAvail <> 0 Then
'Get access to the clipboard
h = OpenClipboard(0&)

If h > 0 Then
'Get a handle to the image data
hPtr = GetClipboardData(lPicType)

'Create our own copy of the image on the clipboard, in the appropriate format.
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If

'Release the clipboard to other programs
h = CloseClipboard

'If we got a handle to the image, convert it into a Picture object and return it
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If

End Function

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture

' IPicture requires a reference to "OLE Automation"
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture

'OLE Picture types
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4

' Create the Interface GUID (for the IPicture interface)
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

' Fill uPicInfo with necessary parts.
With uPicInfo
.Size = Len(uPicInfo) ' Length of structure.
.Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture
.hPic = hPic ' Handle to image.
.hPal = IIf(lPicType = CF_BITMAP, hPal, 0) ' Handle to palette (if bitmap).
End With

' Create the Picture object.
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)

' If an error occured, show the description
If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)

' Return the new Picture object.
Set CreatePicture = IPic

End Function
Private Function fnOLEError(lErrNum As Long) As String

'OLECreatePictureIndirect return values
Const E_ABORT = &H80004004
Const E_ACCESSDENIED = &H80070005
Const E_FAIL = &H80004005
Const E_HANDLE = &H80070006
Const E_INVALIDARG = &H80070057
Const E_NOINTERFACE = &H80004002
Const E_NOTIMPL = &H80004001
Const E_OUTOFMEMORY = &H8007000E
Const E_POINTER = &H80004003
Const E_UNEXPECTED = &H8000FFFF
Const S_OK = &H0

Select Case lErrNum
Case E_ABORT
fnOLEError = " Aborted"
Case E_ACCESSDENIED
fnOLEError = " Access Denied"
Case E_FAIL
fnOLEError = " General Failure"
Case E_HANDLE
fnOLEError = " Bad/Missing Handle"
Case E_INVALIDARG
fnOLEError = " Invalid Argument"
Case E_NOINTERFACE
fnOLEError = " No Interface"
Case E_NOTIMPL
fnOLEError = " Not Implemented"
Case E_OUTOFMEMORY
fnOLEError = " Out of Memory"
Case E_POINTER
fnOLEError = " Invalid Pointer"
Case E_UNEXPECTED
fnOLEError = " Unknown Error"
Case S_OK
fnOLEError = " Success!"
End Select

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

Option Explicit

Option Compare Text

''' User-Defined Types for API Calls

'Declare a UDT to store a GUID for the IPicture OLE Interface

Private Type GUID

Data1 As Long

Data2 As Integer

Data3 As Integer

Data4(0 To 7) As Byte

End Type

'Declare a UDT to store the bitmap information

Private Type uPicDesc

Size As Long

Type As Long

hPic As Long

hPal As Long

End Type

'''Windows API Function Declarations

'Does the clipboard contain a bitmap/metafile?

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

'Open the clipboard to read

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

'Get a pointer to the bitmap/metafile

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long

'Close the clipboard

Private Declare Function CloseClipboard Lib "user32" () As Long

'Convert the handle into an OLE IPicture interface.

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.

Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long

'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.

Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

'The API format types we're interested in

Const CF_BITMAP = 2

Const CF_PALETTE = 9

Const CF_ENHMETAFILE = 14

Const IMAGE_BITMAP = 0

Const LR_COPYRETURNORG = &H4

Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture

'Some pointers

Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long

'Convert the type of picture requested from the xl constant to the API constant

lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)

'Check if the clipboard contains the required format

hPicAvail = IsClipboardFormatAvailable(lPicType)

If hPicAvail <> 0 Then

'Get access to the clipboard

h = OpenClipboard(0&)

If h > 0 Then

'Get a handle to the image data

hPtr = GetClipboardData(lPicType)

'Create our own copy of the image on the clipboard, in the appropriate format.

If lPicType = CF_BITMAP Then

hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)

Else

hCopy = CopyEnhMetaFile(hPtr, vbNullString)

End If

'Release the clipboard to other programs

h = CloseClipboard

'If we got a handle to the image, convert it into a Picture object and return it

If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)

End If

End Function

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture

' IPicture requires a reference to "OLE Automation"

Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture

'OLE Picture types

Const PICTYPE_BITMAP = 1

Const PICTYPE_ENHMETAFILE = 4

' Create the Interface GUID (for the IPicture interface)

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

' Fill uPicInfo with necessary parts.

With uPicInfo

.Size = Len(uPicInfo) ' Length of structure.

.Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture

.hPic = hPic ' Handle to image.

.hPal = IIf(lPicType = CF_BITMAP, hPal, 0) ' Handle to palette (if bitmap).

End With

' Create the Picture object.

r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)

' If an error occured, show the description

If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)

' Return the new Picture object.

Set CreatePicture = IPic

End Function

Private Function fnOLEError(lErrNum As Long) As String

'OLECreatePictureIndirect return values

Const E_ABORT = &H80004004

Const E_ACCESSDENIED = &H80070005

Const E_FAIL = &H80004005

Const E_HANDLE = &H80070006

Const E_INVALIDARG = &H80070057

Const E_NOINTERFACE = &H80004002

Const E_NOTIMPL = &H80004001

Const E_OUTOFMEMORY = &H8007000E

Const E_POINTER = &H80004003

Const E_UNEXPECTED = &H8000FFFF

Const S_OK = &H0

Select Case lErrNum

Case E_ABORT

fnOLEError = " Aborted"

Case E_ACCESSDENIED

fnOLEError = " Access Denied"

Case E_FAIL

fnOLEError = " General Failure"

Case E_HANDLE

fnOLEError = " Bad/Missing Handle"

Case E_INVALIDARG

fnOLEError = " Invalid Argument"

Case E_NOINTERFACE

fnOLEError = " No Interface"

Case E_NOTIMPL

fnOLEError = " Not Implemented"

Case E_OUTOFMEMORY

fnOLEError = " Out of Memory"

Case E_POINTER

fnOLEError = " Invalid Pointer"

Case E_UNEXPECTED

fnOLEError = " Unknown Error"

Case S_OK

fnOLEError = " Success!"

End Select

End Function

Passo 3 – Carregar Imagens Dentro da Propria Planilha

Insira uma guia em sua planilha e cole as imagens que você irá usar.
Agora nomeie a sua nova guia, como exemplo eu usei “Produtos”
Nomeie também as imagens que você colou em sua planilha.

Passo 4 – Usando a “força”: Formulário + Imagem

Agora criem um botão em seu formulário e clique duas vezes para inserir o código abaixo:

Private Sub CommandButton1_Click()

   Worksheets("Produtos").Shapes("bb-8").CopyPicture
   Set Image1.Picture = PastePicture(xlPicture)

End Sub

Private Sub CommandButton1_Click()

Worksheets("Produtos").Shapes("bb-8").CopyPicture

Set Image1.Picture = PastePicture(xlPicture)

End Sub

Observem que para funcionar é muito importante os nomes utilizados:

Primeiro para localizar a imagem precisamos do nome da guia e nome da imagem
Em segundo precisamos do nome do controle de imagem no formulario (passo1)

Vídeo com Detalhes

Para ver detalhes de como carregar imagens dentro da propria planilha veja o vídeo! Ah e se gostaram não esqueçam de curtir e espalhar para os amigos!!!

Como Carregar Imagens Dentro da Propria Planilha

Passo 1 – Faça seu formulário:

Passo 2 – Função API

Passo 3 – Carregar Imagens Dentro da Propria Planilha

Passo 4 – Usando a “força”: Formulário + Imagem

Vídeo com Detalhes

Pesquisar

Tags