MS Excel

Téma: VBA náhledy orbázků z jiných listů

Zaslal/a xim 2.8.2025 20:24

Ahoj,
mámm problém s kopírováním orbázků z jiných listů.
Na prvním listu mám výplně, přes prefix a ID hledám v tabulce na drhuém listu. Kliknu na výpln a vedle se mi zobrazí náhled - obrázek z druhého listu.
Ale někdy se mi náhled zobrazí jako prázdný, tedy obrázek se nezkopíruje. Někdy dostanu chybu 1004 Metoda CopyPicture třídy Range selhala. Jindy mi to jede bez problému. Nerozumím kde je problém :-/

Pokud dostanu 1004, je to zde: If Not foundPic Then wsList.Range("B" & dataRow).CopyPicture xlScreen

ublic 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, foundPic As Boolean
Dim areaR As Range, s As Shape
Dim previewShape As Shape
Dim origW As Double, origH As Double, scaleRatio As Double

' Turn off screen updating to avoid flicker
Application.ScreenUpdating = False

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

' Find row
With wsList.Columns("A")
Set foundCell = .Find(CStr(ID), , xlValues, xlWhole)
If foundCell Is Nothing Then
Application.ScreenUpdating = True
Exit Sub
End If
dataRow = foundCell.Row
End With

' Remove existing preview named PreviewPic
On Error Resume Next
wsMap.Shapes("PreviewPic").Delete
On Error GoTo 0

' Copy picture
foundPic = False
For Each shpCandidate In wsList.Shapes
If shpCandidate.TopLeftCell.Row = dataRow And shpCandidate.TopLeftCell.Column = 2 Then
shpCandidate.Copy
foundPic = True
Exit For
End If
Next shpCandidate
If Not foundPic Then wsList.Range("B" & dataRow).CopyPicture xlScreen, xlPicture

' Paste as Picture object
Dim picObj As Picture
On Error Resume Next
Set picObj = wsMap.Pictures.Paste
On Error GoTo 0
If picObj Is Nothing Then
Application.ScreenUpdating = True
Exit Sub
End If
Set previewShape = picObj.ShapeRange(1)
previewShape.Name = "PreviewPic"

' Scale and position
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

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

' Restore screen updating
Application.ScreenUpdating = True
End Sub

Moc díky za jakokouliv radu

Zaslat odpověď >

Nebyly zaslány žádné odpovědi.

Uživatelské menu

Nejste přihlášen(a)

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.