Hi All,
I have the following issue that i cant seem to solve.
I have got a Macro that important JPEG images with an unique name (style code) to a field in Excel with the same unique name.
However this Macro only works with JPEG images, now the issue is that all the images have been changed to PNG and I'm not able to run the macro anymore.
Can anyone help me out to get the macro working again?
Thanks a lot, I really appreciate it.
Regards,
Kevin
I have the following issue that i cant seem to solve.
I have got a Macro that important JPEG images with an unique name (style code) to a field in Excel with the same unique name.
However this Macro only works with JPEG images, now the issue is that all the images have been changed to PNG and I'm not able to run the macro anymore.
Can anyone help me out to get the macro working again?
Thanks a lot, I really appreciate it.
Regards,
Kevin
Code:
Attribute VB_Name = "InsertImageBasedonStyleName"
Option Explicit
' rkratt 8 Juni 2010
' select cells with style colorway
Sub Insert_Image_Based_on_StyleName()
Dim cCell As Range
Dim cDest As Range
Dim rngSelection As Range
Dim strHLink As String
Dim cComment As Comment
Dim strPicFileName As String
Dim VarBrwFldr As String
Dim FileNameWithPath As Variant
Dim ListOfFilenamesWithParh As New Collection ' create a collection of filenames
On Error GoTo Err1:
Sheets("Price overview").Select
Range("F9:OV1210").Select
VarBrwFldr = BrowseForFolder
'if browse for folder was canceled quit
If VarBrwFldr = "" Then Exit Sub
'builds a list of all files in the folder including sub folders
Call FileSearchByHavrda(ListOfFilenamesWithParh, VarBrwFldr, "*.jpg", True)
'will look at every cell that is selected. will give an error if any #N/A cells are selected but blanks are okay.
For Each cCell In Selection
With cCell
Set cDest = .Offset(ColumnOffset:=0)
On Error Resume Next
If .Value = "" Then GoTo lastline
'only works with jpg, would need adjustment to work with other image file.
'strHLink = VarBrwFldr & "\" & .Value & ".jpg"
'loop list of file names from Havrda sub
For Each FileNameWithPath In ListOfFilenamesWithParh
If (InStr(FileNameWithPath, .Value) > 0) Then
strHLink = FileNameWithPath
If strHLink <> "" Then
'Build a picture shape
strPicFileName = "pic_" & cCell.Row & cCell.Column
If InsertPicFromFile( _
strFileLoc:=strHLink, _
rDestCells:=cDest, _
blnFitInDestHeight:=True, _
strPicName:=strPicFileName) _
= True Then
With ActiveSheet.Shapes(strPicFileName)
'logic decides if it should base picture ratio on cell height or width
.LockAspectRatio = msoTrue
If .Width > .Height Then
.Width = cDest.Width * 0.8
If .Height > cDest.Height * 0.8 Then .Height = cDest.Height * 0.8
Else
.Height = cDest.Height * 0.8
If .Width > cDest.Width * 0.8 Then .Width = cDest.Width * 0.8
End If
End With
'gets rid of memory to start next cell
cCell.Hyperlinks.Delete
End If
End If
End If
Next FileNameWithPath
lastline:
End With
Next cCell
Err1Exit:
Exit Sub
Err1:
MsgBox "Folder was not valid"
Resume Err1Exit
End Sub
Private Sub FileSearchByHavrda(pFoundFiles As Collection, pPath As String, pMask As String, pIncludeSubdirectories As Boolean)
'
' Search files in Path and create FoundFiles list(collection) of file names(path included) accordant with Mask (search in subdirectories if enabled)
' 01.06.2009, Author: P. Havrda, Czech Republic
'
Dim DirFile As String
Dim CollectionItem As Variant
Dim SubDirCollection As New Collection
' Add backslash at the end of path if not present
pPath = Trim(pPath)
If Right(pPath, 1) <> "\" Then pPath = pPath & "\"
' Searching files accordant with mask
DirFile = Dir(pPath & pMask)
Do While DirFile <> ""
pFoundFiles.Add pPath & DirFile 'add file name to list(collection)
DirFile = Dir ' next file
Loop
' Procedure exiting if searching in subdirectories isn't enabled
If Not pIncludeSubdirectories Then Exit Sub
' Searching for subdirectories in path
DirFile = Dir(pPath & "*", vbDirectory)
Do While DirFile <> ""
' Add subdirectory to local list(collection) of subdirectories in path
If DirFile <> "." And DirFile <> ".." Then If ((GetAttr(pPath & DirFile) And vbDirectory) = 16) Then SubDirCollection.Add pPath & DirFile
DirFile = Dir 'next file
Loop
' Subdirectories list(collection) processing
For Each CollectionItem In SubDirCollection
Call FileSearchByHavrda(pFoundFiles, CStr(CollectionItem), pMask, pIncludeSubdirectories) ' Recursive procedure call
Next
End Sub
'* InserPicFromFile
Function InsertPicFromFile( _
strFileLoc As String, _
rDestCells As Range, _
blnFitInDestHeight As Boolean, _
strPicName As String) As Boolean
Dim Pic As IPictureDisp
Const ScaleChange As Double = (635 / 24)
Dim oNewPic As Shape
Dim shtWS As Worksheet
Dim tmpWidth As Integer
Dim tmpHeight As Integer
Set shtWS = rDestCells.Parent
On Error Resume Next
'Delete the named picture (if it already exists)
shtWS.Shapes(strPicName).Delete
On Error GoTo Finish
With rDestCells
'uses the picture ratio to build the virtual rectangle (see below)
Set Pic = LoadPicture(strFileLoc)
tmpWidth = 0.4 * (Pic.Width / ScaleChange)
tmpHeight = 0.4 * (Pic.Height / ScaleChange)
'Create the new picture
'(virtual rectangle that is the height and width of image to import. the with and top refer to cDest Cell)
Set oNewPic = shtWS.Shapes.AddPicture( _
Filename:=strFileLoc, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=.Left + (.Width * 0.1), Top:=.Top + (.Height * 0.05), Width:=tmpWidth, Height:=tmpHeight)
'Maintain original aspect ratio and set to full size
oNewPic.LockAspectRatio = msoTrue
oNewPic.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
oNewPic.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
If blnFitInDestHeight = True Then
'Resize the picture to fit in the destination cells
oNewPic.Height = .Height - 1
End If
'Assign the desired name to the picture
oNewPic.Name = strPicName
End With 'rCellDest
Finish:
If Err.Number <> 0 Then
InsertPicFromFile = False
rDestCells.Cells(1, 1).Value = rDestCells.Cells(1, 1).Value
Else
InsertPicFromFile = True
' rDestCells.Cells(1, 1).Value = rDestCells.Cells(1, 1).Value
End If
End Function
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, www.VBAExpress.com..portion of Knowledge base submission
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
End Function
Sub TlBarOpen()
Dim msg As String
Dim Ans As String
'I added a message to allow a cancel in case macro selected by mistake.
msg = "File should be saved on computer before adding toolbar!!!" & vbCrLf
msg = msg + "A folder under My Documents in C Drive is best (do not use network drive)." & vbCrLf & vbCrLf
msg = msg + "Continue with adding buttons to toolbar?"
Ans = MsgBox(msg, vbYesNo)
Select Case Ans
Case vbNo
GoTo Canceled
Case vbYes
GoTo KeepGoing
End Select
KeepGoing:
'Application.Iteration = True
'Set Toolbar options
With Application
.ShowToolTips = True
.LargeButtons = False
.ColorButtons = True
End With
On Error Resume Next
'If the "ProductCodeImages" toolsbar already exists Then delete the "Add Images" toolbar
Toolbars("ProductCodeImages").Delete
'Add a new toolbar "ProductCodeImages"
Toolbars.Add Name:="ProductCodeImages"
On Error GoTo 0
'Set the "Add Images" toolbar optoins
With Toolbars("ProductCodeImages")
.Visible = True
.Position = xlFloating
.Left = 600
.Top = 24
.Width = 145
'Add all buttons to the "ProductCodeImages" toolbar
.ToolbarButtons.Add Button:=231
.ToolbarButtons(1).OnAction = "Insert_Image_Based_on_StyleName"
ThisWorkbook.Worksheets("Buttons").DrawingObjects("Picture 1").Copy
.ToolbarButtons(1).PasteFace
.ToolbarButtons(1).Name = "InsertImages"
'Add all buttons to the "ProductCodeImages" toolbar
.ToolbarButtons.Add Button:=231
.ToolbarButtons(2).OnAction = "DeleteSelectedPics"
ThisWorkbook.Worksheets("Buttons").DrawingObjects("Picture 2").Copy
.ToolbarButtons(2).PasteFace
.ToolbarButtons(2).Name = "DeleteSelectedImages"
' Add a gap between buttons
.ToolbarButtons.Add Button:=0, before:=2
End With
'error handle
Canceled:
End Sub
Sub TlBarClose()
On Error Resume Next
Toolbars("ProductCodeImages").Delete
On Error GoTo 0
End Sub
Sub DeleteSelectedPics()
'This sub makes it possible to delete pictures within a given range.
'all pictures in selected area are deleted.
'other image types remain
Sheets("Price overview").Select
Range("F9:OV1210").Select
Dim Sh As Shape
Dim Rng As Range
Dim ThisSheet As Worksheet
'rename current sheet so it can later be used as a variable
Set ThisSheet = ActiveSheet
'rename selection so it can later be used as a variable
Set Rng = Selection
With ThisSheet
For Each Sh In .Shapes
'intersect command defines area for macro to perform task
' If Not Application.Intersect(Sh.TopLeftCell, Rng) Is Nothing Then
If Sh.Type = msoPicture Then Sh.Delete
' End If
Next Sh
End With
End Sub
