[es] - kopiranje objekata iz jednog lista u drugi kao picture

superr
Pančevo

Član broj: 129200
Poruke: 31
2a06:63c0:8d04:3400:aa:c04c:..

+3 Profil

kopiranje objekata iz jednog lista u drugi kao picture

^{11.02.2025. u 18:12 - pre 2 meseca}

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

Odgovor na temu

3okc
Χoᴘᴦoѡ

Moderator
Član broj: 811
Poruke: 1330

Jabber: 3okc@elitesecurity.org

+121 Profil

Re: kopiranje objekata iz jednog lista u drugi kao picture

^{12.02.2025. u 07:55 - pre 2 meseca}

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

Č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.

Have you found helpful examples, solutions or ideas-in-work, please consider the
following:
• Citation of *actual page* you are going to using is welcome.
• Have you saw "Value Added" examples you are going to incorporate to your
profitable blog, daily job or any money making venture: How about online donation?
↗Ana & Vlade Divac Foundation
Hvala!

Prikačeni fajlovi

vba-code.png - 7.85k

Odgovor na temu

superr
Pančevo

Član broj: 129200
Poruke: 31
2a06:63c0:8d04:3400:6c10:554..

+3 Profil

Re: kopiranje objekata iz jednog lista u drugi kao picture

^{12.02.2025. u 16:15 - pre 2 meseca}

@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

Odgovor na temu

superr
Pančevo

Član broj: 129200
Poruke: 31
2a06:63c0:8d04:3400:6c10:554..

+3 Profil

Re: kopiranje objekata iz jednog lista u drugi kao picture

^{12.02.2025. u 16:32 - pre 2 meseca}

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

Prikačeni fajlovi

Screenshot 2025-02-12 172103.jpg - 112.35k

Odgovor na temu

Jpeca
Predrag Jovanović
poslovni analitičar
Gowi
Pančevo

Moderator
Član broj: 25683
Poruke: 2286
*.dynamic.isp.telekom.rs.

Sajt: www.gowi.rs

+112 Profil

Re: kopiranje objekata iz jednog lista u drugi kao picture

^{13.02.2025. u 07:12 - pre 2 meseca}

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

Nije to loše Rembrante, samo što ne bi dodao još malo boje?

Odgovor na temu

3okc
Χoᴘᴦoѡ

Moderator
Član broj: 811
Poruke: 1330

Jabber: 3okc@elitesecurity.org

+121 Profil

Re: kopiranje objekata iz jednog lista u drugi kao picture

^{13.02.2025. u 13:46 - pre 2 meseca}

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.

Odgovor na temu

superr
Pančevo

Član broj: 129200
Poruke: 31
2a06:63c0:8d04:3400:719a:666..

+3 Profil

Re: kopiranje objekata iz jednog lista u drugi kao picture

^{19.02.2025. u 20:40 - pre 57 dana i 16h}

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...

Odgovor na temu

superr
Pančevo

Član broj: 129200
Poruke: 31
2a06:63c0:8d04:3400:719a:666..

+3 Profil

Re: kopiranje objekata iz jednog lista u drugi kao picture

^{19.02.2025. u 20:59 - pre 57 dana i 16h}

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

Odgovor na temu