การใช้ มาร์โค ในการแสดงรูปภาพ

Option Explicit

‘ Insert picture from local file/URL
‘ Author: Prasert Kanawattanachai
‘ prasert@cbs.chula.ac.th
‘ copyright 2021

‘ ======================== public functions ============================
Public Sub addQRCodes()
‘ how to run: select a range contains barcode data and run this macro
Application.ScreenUpdating = False
Dim c As Range ‘ current cell object
Dim img_url As String
For Each c In Selection
DeleteShape MsoShapeType.msoPicture, c.Offset(0, 1)
addPictureUrl a_cell:=c, img_url:=qrcode(c.Value), row_offset:=0, col_offset:=1
Next
Application.ScreenUpdating = True
End Sub

Public Sub addPictures()
‘ how to run: select a range contains image urls and run this macro
‘ add multiple pictures using values from selected range and place picture in the right column of selected range
‘ addPictures rngInput:=Selection, row_offset:=0, col_offset:=1
Dim c As Range ‘ current cell object
Dim img_url As String

Application.ScreenUpdating = False

Selection.Offset(0, 1).ColumnWidth = 50

For Each c In Selection
    DeleteShape MsoShapeType.msoPicture, c.Offset(0, 1)
    addPictureUrl a_cell:=c, img_url:=c.Value, row_offset:=0, col_offset:=1
Next
Application.ScreenUpdating = True

End Sub

‘ ======================== private functions ============================
Private Sub addPictureUrl(a_cell, Optional img_url = “”, Optional row_offset = 0, Optional col_offset = 1)
‘ add a single picture using value from a selected cell or img_url and place a picture in the right column
On Error GoTo check:
Dim c As Range
Set c = a_cell(1) ‘ select first cell in range

If img_url = "" Then
    img_url = c.Value
End If

Dim img_shape As Shape
Set img_shape = ActiveSheet.Shapes.addPicture(Filename:=img_url, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=c.Offset(row_offset, col_offset).Left + 8, _
    Top:=c.Offset(row_offset, col_offset).Top + 8, _
    Width:=-1, Height:=-1)

‘ MsgBox (img_shape.Width)
Dim max_long_edge As Integer
max_long_edge = 120
Dim scale_ratio As Double
If img_shape.Width > max_long_edge Then ‘ Or img_shape.Height > max_long_edge Then
scale_ratio = max_long_edge / img_shape.Width
img_shape.Width = Int(scale_ratio * img_shape.Width)
End If
If img_shape.Height > max_long_edge Then
scale_ratio = max_long_edge / img_shape.Height
img_shape.Height = Int(scale_ratio * img_shape.Height)
End If

If img_shape.Height > c.RowHeight + 15 Then
    c.RowHeight = img_shape.Height + 20

‘ c.ColumnWidth = img_shape.Width + 15
Else
c.RowHeight = img_shape.Height + 12
‘ c.ColumnWidth = img_shape.Width + 8
End If
‘img_shape.Placement = xlMove ‘ image properly moved when sort rows
img_shape.Placement = xlMoveAndSize ‘ able to delete column containing images
Exit Sub
check:
‘ MsgBox img_url & ” not found”, vbCritical
Dim msg As String
msg = “Error # ” & Str(Err.Number) & ” was generated by ” _
& Err.Source & Chr(13) & “Error Line: ” & Erl & Chr(13) & Err.Description
MsgBox msg, , “Error”, Err.HelpFile, Err.HelpContext
End Sub

‘ =============== delete picture from selection/selected range ==================
Public Sub deletePicture_X()
‘ delete pictures from selection
deletePicture Selection
End Sub

Private Sub deletePicture(rngInput As Range)
‘ delete all pictures in rngInput Range
Dim c As Range ‘ current cell object
For Each c In rngInput
‘ delete existing picture in cell
‘DeleteShape msoLinkedPicture, c
DeleteShape msoPicture, c
Next
End Sub

Private Sub DeleteShape(ByVal shapeType As MsoShapeType, ByVal Target As Range)
‘ delete all shapes with a given shape type from a target range
‘ usage: deleteshape msoLinkedPicture, range(“c8”)
‘ see: MsoShapeType enum
‘ http://msdn.microsoft.com/en-us/library/office/aa432678(v=office.12).aspx
On Error GoTo check:
Dim shp As Shape
If Not ActiveSheet.Shapes Is Nothing Then
For Each shp In ActiveSheet.Shapes
If Not Application.Intersect(shp.TopLeftCell, Target) Is Nothing Then
If shp.Type = shapeType Then
shp.Delete
End If
End If
Next
End If
Exit Sub
check:
End Sub

ใส่ Code ลงใน Module