Am creat un macro care iti permite sa adaugi un comentariu cu o poza inserata.
Macro-ul face urmatoarele:
- adauga poza
- seteaza automat aspect ratio (marimea comment-ului), ca poza nu fie deformata si sa se incadreze corect
- comprima poza, ca dimensiunea fisierului excel sa nu fie foarte mare (comprima toate pozele din excel automat)
Sper sa va ajute, mi-a luat ceva timp sa il fac.
Nume macro - adauga_poza -
Cod: Selectaţi tot
Private Type ImgageInfo
Height As Long
Width As Long
FileExtension As String
HorizontalResolution As Double
VerticalResolution As Double
PixelDepth As Long
End Type
Public Img As ImgageInfo
Function Shell_GetImgDimensions(ByVal sFile As String) As Boolean
On Error GoTo Error_Handler
Dim oShell As Object 'Shell
Dim oFolder As Object 'Folder2
Dim oFile As Object 'FolderItem
Dim sPath As String
Dim sFilename As String
Dim sDims As String
sPath = Left(sFile, InStrRev(sFile, "\") - 1)
sFilename = Right(sFile, Len(sFile) - InStrRev(sFile, "\"))
Set oShell = CreateObject("Shell.Application")
Set oFolder = oShell.Namespace(CStr(sPath))
Set oFile = oFolder.ParseName(sFilename)
sDims = oFile.ExtendedProperty("Dimensions") '-> ?470 x 668?
sDims = Right(sDims, Len(sDims) - 1)
sDims = Left(sDims, Len(sDims) - 1)
Img.Width = CLng(Split(sDims, "x")(0))
Img.Height = CLng(Split(sDims, "x")(1))
Error_Handler_Exit:
On Error Resume Next
If Not oFile Is Nothing Then Set oFile = Nothing
If Not oFolder Is Nothing Then Set oFolder = Nothing
If Not oShell Is Nothing Then Set oShell = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: Shell_GetImgDimensions" & vbCrLf & _
"Error Description: " & Err.Description & _
Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
, vbOKOnly + vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
Sub adauga_poza()
'adauga poza in comentariu
Dim cale_poza As String
Dim sFile As String
Dim inaltime As Integer
Dim latime As Integer
Dim answer As Integer
On Error GoTo manager_erori
If Selection.Count > 1 Then
MsgBox "Selecteaza numai o celula.", vbCritical
Exit Sub
End If
cale_poza = Application.GetOpenFilename(Title:="Selecteaza poza.", FileFilter:="Poze (*.jpg;*.jpeg;*.bmp;*.png;*.heic), *.jpg;*.jpeg;*.bmp;*.png;*.heic")
If cale_poza = "False" Then
Exit Sub
End If
sFile = cale_poza
Call Shell_GetImgDimensions(sFile)
latime = Img.Width
inaltime = Img.Height
Do While latime > 300 And inaltime > 300
latime = latime / 1.1
inaltime = inaltime / 1.1
Loop
If Not ActiveCell.Comment Is Nothing Then
ActiveCell.Comment.Delete
End If
With ActiveCell
.AddComment.Shape.Fill.UserPicture cale_poza
.Comment.Shape.Width = latime
.Comment.Shape.Height = inaltime
' .Comment.Shape.LockAspectRatio = msoTrue
End With
answer = MsgBox("Vrei sa comprimi imaginea?" & vbCrLf & "Se va reduce dimensiunea fisierului." & vbCrLf & "ATENTIE!!!" _
& vbCrLf & "Macro-ul va comprima toate pozele din fisier.", vbQuestion + vbYesNo + vbDefaultButton2, "Picture compression")
If answer = vbYes Then
'pentru disable dele cropped areas
Application.SendKeys "%{e}"
'pentru rez de 200, pentru rezolutine mai mica SendKeys "%{w}" 96
Application.SendKeys "%{p}"
Application.SendKeys "{ENTER}"
'anuleaza notificarea daca esti sigur, se selecteza alceva daca s-a bifat sa nu mai apara notificarea, nu este nimic grav!
Application.SendKeys "%{a}"
Application.CommandBars.ExecuteMso "PicturesCompress"
End If
Exit Sub
manager_erori:
MsgBox "Poza incompatibila!", vbCritical
ActiveCell.ClearComments
End Sub