MS Excel

Nejlepší fix s nejvyšší spolehlivostí bez Range.CopyPicture

Ty už primárně hledáš Shape na řádku (obrázek v B sloupci). Tak to využij a exportuj Shape do PNG a pak ho vlož jako obrázek. Tím úplně obejdeš clipboard a CopyPicture.

Shape - PNG - vložit do náhledu

Výhoda: funguje stabilně i když list není aktivní, žádné 1004 z CopyPicture.

Public Sub DisplayPreview(prefix As String, ID As Long)
Dim wsMap As Worksheet: Set wsMap = ThisWorkbook.Sheets(MapSheetName)
Dim wsList As Worksheet: Set wsList = ThisWorkbook.Sheets(GetListName(prefix))
Dim foundCell As Range, dataRow As Long
Dim shpCandidate As Shape, srcShape As Shape
Dim areaR As Range
Dim previewShape As Shape
Dim origW As Double, origH As Double, scaleRatio As Double
Dim tmpPng As String

On Error GoTo CleanFail

Application.ScreenUpdating = False
Application.EnableEvents = False

LastPrefix = prefix
LastID = ID
Set areaR = wsMap.Range(PreviewAreaRange)

' Najdi řádek podle ID
With wsList.Columns("A")
Set foundCell = .Find(What:=CStr(ID), LookIn:=xlValues, LookAt:=xlWhole)
If foundCell Is Nothing Then GoTo CleanExit
dataRow = foundCell.Row
End With

' Smazat starý náhled
On Error Resume Next
wsMap.Shapes("PreviewPic").Delete
On Error GoTo CleanFail

' Najdi obrázek (Shape) v buňce B na daném řádku
Set srcShape = Nothing
For Each shpCandidate In wsList.Shapes
If shpCandidate.TopLeftCell.Row = dataRow And shpCandidate.TopLeftCell.Column = 2 Then
Set srcShape = shpCandidate
Exit For
End If
Next shpCandidate

If srcShape Is Nothing Then
' Pokud nemáš Shape, tak aspoň fallback na text/desc a konec
wsMap.Range(PreviewDescName).Value = wsList.Range("C" & dataRow).Value
GoTo CleanExit
End If

' Export shape do PNG (TEMP)
tmpPng = Environ$("TEMP") & "\PreviewPic_" & prefix & "_" & CStr(ID) & ".png"
On Error Resume Next
Kill tmpPng
On Error GoTo CleanFail
srcShape.Export Filename:=tmpPng, FilterName:="PNG"

' Vložit PNG do map sheetu jako picture/shape
Set previewShape = wsMap.Shapes.AddPicture( _
Filename:=tmpPng, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=areaR.Left, Top:=areaR.Top, Width:=-1, Height:=-1)

previewShape.Name = "PreviewPic"

' Scale + centrování do PreviewArea
origW = previewShape.Width: origH = previewShape.Height
scaleRatio = Application.Min(areaR.Width / origW, areaR.Height / origH)

With previewShape
.LockAspectRatio = msoTrue
.Width = origW * scaleRatio
.Height = origH * scaleRatio
.Left = areaR.Left + (areaR.Width - .Width) / 2
.Top = areaR.Top + (areaR.Height - .Height) / 2
End With

' Popisek
wsMap.Range(PreviewDescName).Value = wsList.Range("C" & dataRow).Value

CleanExit:
Application.CutCopyMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub

CleanFail:
' Když něco selže, radši se vrať do konzistentního stavu
Application.CutCopyMode = False
Application.EnableEvents = True
Application.ScreenUpdating = True
' volitelně: Debug.Print Err.Number, Err.Description
End Subcitovat