kopiranje objekata iz jednog lista u drugi kao picture

[ superr @ 11.02.2025. 18:12 ] @

pozdrav! vba pravi neke objekte po dimenzijama iz tekst boxova, zamisao je da se zatim svi ti objekti kopiraju i zalepe na drugi list u formi slike... donekle sam i uspeo problem se povremeno javlja ne mogu da definišem iz kog razloga jer nekada ponovim proceduru 7-8 puta i nema greške pa se javi a nekada nakon prvog pokretanja ili trćeg-petog... nema nekog pravila!ako je neko raspložen da se priključi u rešavanju problema...

Code:
Sub CopyShapesAsJednokrilno()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim shpRam As shape
    Dim shpKrilo As shape
    Dim cell As Range
    Dim rngPrintArea As Range
    Dim pasteRange As Range
    Dim aspectRatio As Double
    Dim picName As String
    Dim shapeInCell As Boolean
    Dim picObject As Picture
    Dim pic As shape
    Dim shp As shape
    Dim shpGroup As shape

    On Error GoTo ErrorHandler

    ' Set the source and target worksheets
    Set wsSource = ThisWorkbook.Sheets("crtez")
    Set wsTarget = ThisWorkbook.Sheets("crtezi")

    ' Set the shapes
    Set shpRam = wsSource.shapes("grpRam")
    Set shpKrilo = wsSource.shapes("grpKrilo")

    ' Group the shapes
    Set shpGroup = wsSource.shapes.Range(Array(shpRam.name, shpKrilo.name)).Group

    ' Define the print area on the target worksheet
    Set rngPrintArea = wsTarget.Range(wsTarget.PageSetup.PrintArea)

    ' Find the first empty cell in the print area with no shapes in it
    For Each cell In rngPrintArea
        shapeInCell = False
        For Each shp In wsTarget.shapes
            If Not Intersect(cell, Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing Then
                shapeInCell = True
                Exit For
            End If
        Next shp

        If IsEmpty(cell) And Not shapeInCell Then
            Set pasteRange = cell
            Exit For
        End If
    Next cell

    ' If a suitable cell is found, copy and paste the grouped shapes as a picture
    If Not pasteRange Is Nothing Then
        ' Copy the group shape as a picture
        shpGroup.Copy
        Set picObject = wsTarget.Pictures.Paste
        Set pic = wsTarget.shapes(picObject.name)

        ' Get the name for the picture from the cell above the target cell
        picName = pasteRange.Offset(-1, 0).value

        ' Set the name of the picture
        pic.name = picName

        ' Set the top-left corner of the image to the top-left corner of the target cell
        With pic
            .top = pasteRange.top
            .left = pasteRange.left

            ' Maintain the original aspect ratio
            aspectRatio = .width / .height

            ' Resize the image to fit within the cell while maintaining the aspect ratio
            If pasteRange.width / pasteRange.height > aspectRatio Then
                .height = pasteRange.height
                .width = .height * aspectRatio
            Else
                .width = pasteRange.width
                .height = .width / aspectRatio
            End If

            .Placement = xlMoveAndSize
        End With
    Else
        MsgBox "No suitable cell found in the print area.", vbExclamation
    End If

    ' Ungroup the shapes after copying
    shpGroup.Ungroup

    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbExclamation
    Exit Sub
End Sub

[ 3okc @ 12.02.2025. 07:55 ] @

Pogledao sam na brzinu i mislim da je mogući problem što imaš dve ugnježdene For petlje i izlaziš nasilno, konkretno

[att_img]

Čak je i greška konzistentna sa - potencijalno - prepunjenim stekom, ili šta se već "puni" sa svakim otvaranjem nove petlje.

Tako da bih taj deo prvo preradio/izmenio, da me se pita.

Npr. prvi nasilni izlaz je 1/1 povezan sa promenom vrednosti shapeInCell iz False u True pa to možeš da upotrebiš npr da ti ta petlja bude Do-While i rešio si se jednog nasilnog izlaska.

[ superr @ 12.02.2025. 16:15 ] @

@3okc ...po sugeriranom uputstvu nešto sam ispetljao ali i dalje sam bez 100% rešenja...

Code:
Sub CopyShapesAsJednokrilno()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim shpRam As shape
    Dim shpKrilo As shape
    Dim cell As Range
    Dim rngPrintArea As Range
    Dim pasteRange As Range
    Dim aspectRatio As Double
    Dim picName As String
    Dim shapeInCell As Boolean
    Dim picObject As Picture
    Dim pic As shape
    Dim shp As shape
    Dim shpGroup As shape

    On Error GoTo ErrorHandler

    ' Set the source and target worksheets
    Set wsSource = ThisWorkbook.Sheets("crtez")
    Set wsTarget = ThisWorkbook.Sheets("crtezi")

    ' Set the shapes
    Set shpRam = wsSource.shapes("grpRam")
    Set shpKrilo = wsSource.shapes("grpKrilo")

    ' Group the shapes
    Set shpGroup = wsSource.shapes.Range(Array(shpRam.name, shpKrilo.name)).Group

    ' Define the print area on the target worksheet
    Set rngPrintArea = wsTarget.Range(wsTarget.PageSetup.PrintArea)

    ' Find the first empty cell in the print area with no shapes in it
    For Each cell In rngPrintArea
        shapeInCell = False
        Dim shpIndex As Integer
        shpIndex = 1

        Do While shpIndex <= wsTarget.shapes.Count
            Set shp = wsTarget.shapes(shpIndex)
            If Not Intersect(cell, Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing Then
                shapeInCell = True
                Exit Do
            End If
            shpIndex = shpIndex + 1
        Loop

        If IsEmpty(cell) And Not shapeInCell Then
            Set pasteRange = cell
            Exit For
        End If
    Next cell

    ' If a suitable cell is found, copy and paste the grouped shapes as a picture
    If Not pasteRange Is Nothing Then
        ' Copy the group shape as a picture
        shpGroup.Copy
        Set picObject = wsTarget.Pictures.Paste
        Set pic = wsTarget.shapes(picObject.name)

        ' Get the name for the picture from the cell above the target cell
        picName = pasteRange.Offset(-1, 0).value

        ' Set the name of the picture
        pic.name = picName

        ' Set the top-left corner of the image to the top-left corner of the target cell
        With pic
            .top = pasteRange.top
            .left = pasteRange.left

            ' Maintain the original aspect ratio
            aspectRatio = .width / .height

            ' Resize the image to fit within the cell while maintaining the aspect ratio
            If pasteRange.width / pasteRange.height > aspectRatio Then
                .height = pasteRange.height
                .width = .height * aspectRatio
            Else
                .width = pasteRange.width
                .height = .width / aspectRatio
            End If

            .Placement = xlMoveAndSize
        End With
    Else
        MsgBox "No suitable cell found in the print area.", vbExclamation
    End If

    ' Ungroup the shapes after copying
    shpGroup.Ungroup

    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbExclamation
    Exit Sub
End Sub

[ superr @ 12.02.2025. 16:32 ] @

_{[Ovu poruku je menjao superr dana 12.02.2025. u 20:46 GMT+1]}

[ Jpeca @ 13.02.2025. 07:12 ] @

Ne mogu da budem siguran u čemu je problem bez detaljnijeg testiranja - debug procedure, ali dve stvari možeš da probaš:

1. Dodaj neko čekanje pre paste da budeš sigura da je Copy odrađen

Code:
Application.Wait Now + TimeValue("00:00:02") ' Wait 2 seconds

2. Dodaj posle Paste comandu koja će očistiti Clipboard - da ne dođe do prepunjavanja memorije

Code:
Application.CutCopyMode = False

[ 3okc @ 13.02.2025. 13:46 ] @

Citat:

superr:
@3okc ...po sugeriranom uputstvu nešto sam ispetljao ali i dalje sam bez 100% rešenja...

Šta znači bez 100%? Ima pomaka ili nema?

Ako je zaista problem bio sa punjenjem steka, ovo bi sada trebalo makar da utiče na interval do izbijanja greške - ako nije sasvim eliminisao.

[ superr @ 19.02.2025. 20:40 ] @

Citat:

Jpeca:
Ne mogu da budem siguran u čemu je problem bez detaljnijeg testiranja - debug procedure, ali dve stvari možeš da probaš:

1. Dodaj neko čekanje pre paste da budeš sigura da je Copy odrađen

Code:
Application.Wait Now + TimeValue("00:00:02") ' Wait 2 seconds

2. Dodaj posle Paste comandu koja će očistiti Clipboard - da ne dođe do prepunjavanja memorije

Code:
Application.CutCopyMode = False

čekanje od 2 sekunde je odradilo posao... iako ne razumem kako-zašto ali radi! Klipboard se puni i dalje sa unosom svake pozicije taj deo me plaši pa za sad brišem slike ručno iz klipboarda...

[ superr @ 19.02.2025. 20:59 ] @

evo ispravljenog koda... imao sam 1 grešku u vidu trećeg uslova koji nije bio definisan... znači još clipboard ako uspem da praznim posle unosa nove pozicije to bi bilo to.

Code:
Sub CopyShapesAsJednokrilno()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim shpRam As shape
    Dim shpKrilo As shape
    Dim cell As Range
    Dim rngPrintArea As Range
    Dim pasteRange As Range
    Dim aspectRatio As Double
    Dim picName As String
    Dim shapeInCell As Boolean
    Dim picObject As Picture
    Dim pic As shape
    Dim shp As shape
    Dim shpGroup As shape

    On Error GoTo ErrorHandler

    ' Set the source and target worksheets
    Set wsSource = ThisWorkbook.Sheets("crtez")
    Set wsTarget = ThisWorkbook.Sheets("crtezi")

    ' Set the shapes
    Set shpRam = wsSource.shapes("grpRam")
    Set shpKrilo = wsSource.shapes("grpKrilo")

    ' Group the shapes
    Set shpGroup = wsSource.shapes.Range(Array(shpRam.name, shpKrilo.name)).Group

    ' Define the print area on the target worksheet
    Set rngPrintArea = wsTarget.Range(wsTarget.PageSetup.PrintArea)

    ' Find the first empty cell in the print area with no shapes in it
    For Each cell In rngPrintArea
        shapeInCell = False
        Dim shpIndex As Integer
        shpIndex = 1

        Do While shpIndex <= wsTarget.shapes.Count
            Set shp = wsTarget.shapes(shpIndex)
            If Not Intersect(cell, Range(shp.TopLeftCell, shp.BottomRightCell)) Is Nothing Then
                shapeInCell = True
                Exit Do
            End If
            shpIndex = shpIndex + 1
        Loop

        If IsEmpty(cell) And Not shapeInCell Then
            Set pasteRange = cell
            Exit For
        End If
    Next cell

    ' If a suitable cell is found, copy and paste the grouped shapes as a picture
    If Not pasteRange Is Nothing Then
        ' Copy the group shape as a picture
        shpGroup.Copy
        Application.Wait Now + TimeValue("00:00:02") ' Wait 2 seconds
        Set picObject = wsTarget.Pictures.Paste

        ' Clear the clipboard
        Application.CutCopyMode = False

        Set pic = wsTarget.shapes(picObject.name)

        ' Get the name for the picture from the cell above the target cell
        picName = pasteRange.Offset(-1, 0).value

        ' Set the name of the picture
        pic.name = picName

        ' Set the top-left corner of the image to the top-left corner of the target cell
        With pic
            .top = pasteRange.top
            .left = pasteRange.left

            ' Maintain the original aspect ratio
            aspectRatio = .width / .height

            ' Resize the image to fit within the cell while maintaining the aspect ratio
            If pasteRange.width / pasteRange.height > aspectRatio Then
                .height = pasteRange.height
                .width = .height * aspectRatio * 0.99
            ElseIf pasteRange.width / pasteRange.height < aspectRatio Then
                .width = pasteRange.width
                .height = (.width / aspectRatio) * 0.99
            Else
                .width = pasteRange.width * 0.99
                .height = pasteRange.height * 0.99
            End If

            .Placement = xlMoveAndSize
        End With
    Else
        MsgBox "No suitable cell found in the print area.", vbExclamation
    End If

    ' Ungroup the shapes after copying
    shpGroup.Ungroup

    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbExclamation
    Exit Sub
End Sub