Kopiranje vsebine in oblike iz "Shape" v celico

[dragopre]

Pozdravljeni.

Potrebno širino oblike ugotavljam tako, da vsebino prenesem v testno celico , tej določim avtomatsko določanje širine in le-to uporabim za določanje širine gradnika.

Koda: Izberi vse

  cTxt = Worksheets(pList).Shapes(pImeObl).TextFrame2.TextRange.Characters.Text         ' Izločim besedilo
  Worksheets("Test").Columns("H").ColumnWidth = 150                                     ' Širino stolpca H povečam na max
  nFontSize = Worksheets(pList).Shapes(cImeObl).TextFrame2.TextRange.Font.Size          ' Velikost pisave v gradniku
  cFontName = Worksheets(pList).Shapes(cImeObl).TextFrame2.TextRange.Font.Name          ' Ime pisave v gradniku

  Worksheets("Test").Range("H1").Font.Size = nFontSize                                  ' Testni celici določim velikost pisave
  Worksheets("Test").Range("H1").Font.Name = cFontName                                  ' Testni celici določim vrsto pisave
  Worksheets("Test").Range("H1").Value = cTxt                                           ' V celico zapišem vsebino iz gradnika

  Worksheets("Test").Range("H1").Columns.AutoFit                                        ' Širino stolpca avtomatiziram na vsebino
  nColWidth = Worksheets("Test").Range("H1").width                                      ' Ugotovim potrebno širino za ta tekst

Zdaj imam pa primer, ko je besedilo različno oblikovano ( večji manjši font, različna pisava, ..). Ali je možno to oblikovanje enostavno prekopirati v celico? Ker je oblikovanje precej variabilno ( imena. naslovi, opombe), vzporedno oblikovanje ne pride v poštev.

Lep pozdrav in hvala ker se trudite z nami.
Drago

[admin]

Pozdravljeni,

Za to kar želite ne potrebujete nobenega kopiranja. Preprosto zapišite besedilo v obliko in potem obliki rečite naj se prilagodi besedilu (

msoAutoSizeShapeToFitText

):

Koda: Izberi vse

Sub PrilagodiVelikostBesedilu()
    Dim shp As Shape
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Sheets("List1")
    Set shp = ws.Shapes("Srce")
    
    With shp.TextFrame2
        .AutoSize = msoAutoSizeShapeToFitText
    End With
End Sub

[dragopre]

Najlepša hvala.
Joj, kdaj pa znam po nepotrebnem komplicirat.

Lep pozdrav
Drago