XLS-makro pro změnu velikosti obrázku(ů)

[MK_Vs]

Dobrý den,

jakým příkazem pomocí VBA zmenším vždy aktuálně vybraný obrázek(y), nebo zástupce na definovanou velikost. Pomocí záznamu makra bohužel vyberu jen aktuální obrázek. Každý další získává vyšší číslo a není poté příkazem není nalezen.

Jak bude prosím vypadat makro pro výběr obrázku a jeho změnu velikosti na definované rozměry?

Děkuji za pomoc.

[Reklama]

[mike007]

Asi nějak takto:

Kód: Vybrat vše

Sub zmenit_velikosti()
ActiveSheet.Pictures.Select
Selection.ShapeRange.ScaleWidth 1.34, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1.34, msoFalse, msoScaleFromTopLeft
End Sub

Hodnoty (1.34) si změň podle sebe.

[m.niki]

nedávno jsem taky bezvýsledně řešil tento problém, nemůžu přijít na to jak jednoznačně definovat nějakým názvem vložený obrázek, aby s ním mohlo makro pracovat. Teď jsem zkusil kód, který zde vložil mike007, ale na obrázek vložený v sešitě to vůbec nereaguje, označí to všechny ovládací talačítka a pracuje s nimi (Excel 2007)

[mike007]

Vyzkoušel jsem to v Excel 2007 a pracuje korektně.

[m.niki]

tak jsem to zkusil znovu a zjistil jsem, že to (u mě) funguje, pouze pokud se na listu nenachází žádný ovládací prvek ActiveX, ovládací prvek formuláře tomu nevadí, když je na listu pouze obrázek tak to funguje v pohodě.

[MK_Vs]

Tímto postupem lze zmenšit o určitý poměr. Pokud by bylo cílem mít všechny obrázky nebo i ikony vložených dokumentů stejné, bylo by možno použít předdefinovanou šířku nebo výšku?

[navstevnik]

V te nejjednodussi podobe pro vlozene obrazky "Picture xx", demo uprav, zmen dle potreby:

Kód: Vybrat vše

Option Explicit

Sub SrovnatVelikosti()
  Dim Shp As Shape
  Dim W As Single, H As Single
  W = 100: H = 150  ' pozadovane rozmery obrazku
  For Each Shp In ActiveSheet.Shapes
    If Left(Shp.Name, 4) = "Pict" Then
      Shp.LockAspectRatio = msoFalse  ' odemknou uzamknuti pomeru stran
      Shp.Width = W
      Shp.Height = H
    End If
  Next Shp
  Set Shp = Nothing
End Sub

nebo:

Kód: Vybrat vše

Option Explicit

Sub UpravitSirkuObr()
  Dim Shp As Shape
  For Each Shp In ActiveSheet.Shapes
    If Shp.Type = msoPicture Then
      With Shp
        .LockAspectRatio = msoTrue ' uzamknout pomer stran
        .Width = 100 ' sirka obrazku
      End With
    End If
  Next Shp
  Set Shp = Nothing
End Sub

[MK_Vs]

DObrý den, na ikonu jako zástupce souboru tento postup nefunguje. Lez měnit velikost i u ikon, vložených zástupců souborů?

[navstevnik]

Pripoj soubor obsahujici vsechny objekty vlozene na list, u kterych chces upravit rozmer (ktery - W,H a jak- pomerne, absolutne).