VBA Findingaids Image Digital - habibmarzuqi/Atom GitHub Wiki

Untuk memodifikasi kode VBA agar sel yang mengandung gambar secara otomatis menyesuaikan ukuran dengan gambar yang diinsert, kita bisa mengatur RowHeight dan ColumnWidth dari sel target berdasarkan dimensi gambar. Berikut adalah modifikasi pada kode sebelumnya:

Sub InsertImageBesideCell()
    Dim ws As Worksheet
    Dim urlCell As Range
    Dim imageUrl As String
    Dim imgHeight As Double
    Dim imgWidth As Double
    Dim targetCell As Range
    Dim maxRowHeight As Double
    Dim maxColumnWidth As Double
    Dim filePath As String
    Dim fileName As String
    Dim xml As Object
    Dim stream As Object
    On Error GoTo ErrorHandler

    ' Set worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Ganti dengan nama sheet Anda
    
    ' Loop through each cell in the range containing image URLs
    For Each urlCell In ws.Range("AB5:AB45382") ' Sesuaikan range dengan range yang Anda inginkan
        ' Get the image URL from the cell
        imageUrl = urlCell.Value
        
        ' Check if the URL is not empty
        If imageUrl <> "" Then
            ' Download the image and save it locally
            fileName = "temp_image_" & CStr(urlCell.Row) & ".jpg"
            filePath = ThisWorkbook.Path & "\" & fileName
            
            ' Create XMLHTTP object to download the image
            Set xml = CreateObject("MSXML2.ServerXMLHTTP.6.0")
            
            ' Ignore SSL certificate errors
            xml.setOption 2, 13056 ' 13056 = SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS

            xml.Open "GET", imageUrl, False
            xml.send
            
            If xml.Status = 200 Then
                ' Create stream object to save the image
                Set stream = CreateObject("ADODB.Stream")
                stream.Open
                stream.Type = 1 ' Binary data
                stream.Write xml.responseBody
                stream.SaveToFile filePath, 2 ' Overwrite if exists
                stream.Close
                Set stream = Nothing
                
                ' Insert the image into the worksheet using Shapes.AddPicture to embed it
                Dim shp As Shape
                Set shp = ws.Shapes.AddPicture(filePath, _
                    msoFalse, msoCTrue, _
                    urlCell.Offset(0, 1).Left, _
                    urlCell.Top, _
                    -1, -1) ' Allow Excel to auto scale the image
                
                ' Get the image dimensions
                imgHeight = shp.Height
                imgWidth = shp.Width
                
                ' Set the target cell (next cell to the right of the URL cell)
                Set targetCell = urlCell.Offset(0, 1) ' Ini akan menempatkan gambar di sel yang langsung di sebelah kanan
                
                ' Adjust the row height and column width to fit the image
                With targetCell
                    ' Set max row height (maximum row height in Excel is 409.5 points)
                    maxRowHeight = 409.5
                    maxColumnWidth = 255 ' Maximum column width
                    
                    ' Adjust row height, but not exceed maxRowHeight
                    If imgHeight > maxRowHeight Then
                        .RowHeight = maxRowHeight
                    Else
                        .RowHeight = imgHeight
                    End If
                    
                    ' Adjust column width based on image width
                    Dim widthInCharacters As Double
                    widthInCharacters = imgWidth / 5.5 ' Faktor untuk mengkonversi dari poin ke karakter
                    If widthInCharacters > maxColumnWidth Then
                        .ColumnWidth = maxColumnWidth
                    Else
                        .ColumnWidth = widthInCharacters
                    End If
                End With
                
                ' Delete the image file after inserting to keep the folder clean
                Kill filePath
            Else
                MsgBox "Failed to download image from URL: " & imageUrl, vbExclamation
            End If
        End If
    Next urlCell

    Exit Sub

ErrorHandler:
    MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Error"
End Sub

Penjelasan Modifikasi:

  1. imgHeight dan imgWidth: Mengambil dimensi gambar yang di-insert untuk kemudian digunakan untuk mengatur tinggi dan lebar sel.
  2. RowHeight dan ColumnWidth: Mengatur tinggi baris (RowHeight) dan lebar kolom (ColumnWidth) berdasarkan dimensi gambar yang di-insert.
  3. maxColumnWidth: Menyimpan lebar kolom maksimum di Excel, yang disesuaikan agar gambar tidak melebihi batas lebar kolom.
  4. widthInCharacters: Faktor konversi dari poin ke karakter, digunakan untuk mengatur lebar kolom agar sesuai dengan lebar gambar.

Kode ini memastikan bahwa setiap sel di sebelah kanan URL akan menyesuaikan tinggi dan lebarnya agar sesuai dengan gambar yang di-insert. Dengan demikian, gambar akan tampil sepenuhnya tanpa memotong atau menumpuk teks dalam sel.

  1. ' Set worksheet Set ws = ThisWorkbook.Sheets("Sheet1") ' Ganti dengan nama sheet Anda

  2. ' Loop through each cell in the range containing image URLs For Each urlCell In ws.Range("AB5:AB45382") ' Sesuaikan range dengan range yang Anda inginkan isi dengan kolom url image, AB5 untuk 1 kolom, AB5:AB45382 untuk range

  3. sesuaikan kolom di excel, hide dll

image