Adauga comentariu cu poza

Mihai255
Mesaje: 1
Membru din: Mie Dec 30, 2020 3:49 pm

Adauga comentariu cu poza

Mesaj de Mihai255 » Mie Ian 20, 2021 4:33 pm

Buna ziua,

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
Ultima oară modificat Mie Dec 30, 2020 5:56 pm de către IPP, modificat 1 dată în total.
Motiv: adaugat tag code


Subiect ridicat ultima oară de Mihai255 Mie Ian 20, 2021 4:33 pm.

Scrie răspuns

Înapoi la “Visual Basic for Application (VBA) cu Excel - Intrebari tehnice”