• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

MS Excel

Téma: VBA - export rozsah jako jpg

Zaslal/a hard 24.1.2016 20:50

Dobrý den,

rád bych exportoval tabulku jako obrázek pomocí VBA.
Mám tabulku na Listu názvaném "CELKEM", a rád bych tabulku rozsahu A2:U40 exportoval dynamickým názvem - název souboru by byl v buňce A1 a umístění cesty, kam bych exportoval, by bylo např. v buňce AM1. Formát by měl být jpg, png, nebo bmp.
Děkuji za Vaše rady, případně odkazy.

Zaslat odpověď >

---

tarantula222(24.1.2016 23:41)#029529

Myslím že takto by to mohlo stačiť. Poprípade si to upravte.


Sub Export_Ako_PNG()

Dim List As Object, Graf As Object
Dim NazObr As String, NazList As String
Dim ObrH As Single, ObrW As Single
Dim Cesta As String, Nazov As String

Application.ScreenUpdating = False
NazList = "CELKEM"
Set List = Sheets(NazList)
With List
.Select
Nazov = .Range("A1").Text & ".PNG" 'nazov obrazku
Cesta = .Range("AM1").Text & "\" 'kam sa ma ulozit obrazok
.Range("A2:U40").Copy 'oblast ktora sa ma ulozit
.Pictures.Paste.Select
End With
NazObr = Selection.Name
With Selection
ObrH = .ShapeRange.Height
ObrW = .ShapeRange.Width
End With
List.Cells(1, Columns.Count).Select
Set Graf = List.ChartObjects.Add(10, 10, ObrW, ObrH).Chart
With Graf
.Parent.Border.LineStyle = 0
List.Shapes(NazObr).Copy
.ChartArea.Select
.Paste
.Export Filename:=Cesta & Nazov, FilterName:="PNG"
.Parent.Delete
End With
List.Shapes(NazObr).Delete
Application.ScreenUpdating = True
End Sub
citovat

elninoslov(24.1.2016 23:43)#029530

Akurát som našiel jeden kódik, už ho sem dám...
Private Sub SaveRngAsJPG(Rng As Range, FileName As String)
Dim Cht As Chart, bScreen As Boolean, Shp As Shape
bScreen = Application.ScreenUpdating
Application.ScreenUpdating = False
Set Cht = Workbooks.Add(xlChart).Charts(1)
Cht.ChartArea.Clear
Rng.CopyPicture xlScreen, xlPicture
Cht.Paste
With Cht.Shapes(1)
.Left = 0
.Top = 0
.Width = Cht.ChartArea.Width
.Height = Cht.ChartArea.Height
End With
Cht.Export FileName, "JPEG", False
Cht.Parent.Close False
Application.ScreenUpdating = bScreen
End Sub

Sub TestIt2()
Dim Rng As Range, Fn As String
Set Rng = ThisWorkbook.Worksheets("Hárok1").Range("A1:D3")
Fn = "d:\MyFile.jpg"
SaveRngAsJPG Rng, Fn
End Sub
PS: Vo Win8 sú problematické práva pre disk C, ukladajte radšej inde. Bolo by treba ale ešte doriešiť nastavovanie rozmerov, bo malé rozsahy sú deformované.

EDIT: @tarantula222 : Tieto kódy sú nespoľahlivé. Aj ten Váš mi zastaví na
.Pictures.Paste.Select
Ak dám pokračovať, pekne dobehne...citovat

hard(25.1.2016 7:48)#029532

Mockrát děkuji, to je přesně ono! Skvělé a díky oběma!citovat

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse