Screenshot abspeichern mit VBA

Hallo zusammen,
heute habe ich voller Stolz meinen ersten VBA code hier zu Bewunderung veröffentlicht!
(nur ein kleiner Spaß, Ich weiß sehr gut, dass der code ehe eine "Krankheit als gut ist)
Ziel ist es ein koordiniertes abfragen von Datenquellen mit abschließendem speichern als .htm
und dann wieder als .xlsm, weil als .htm Arbeitsmappe meine Codes und abfragen nicht mehr gelaufen sind.
Leider ist die Datei extrem groß und somit auch langsam als Webseite und da mir auf der Webseite eigentlich ein Screenshot reichen würde
hab ich leider erfolglos einige Codes und auch Makro Rekords probiert zum Thema Screenshot.
Könnte mir jemand bitte mich von meinem Leid erlösen und mir helfen anstatt HTML-File, einem Screenshot vom
"Druckbereich" oder "A1:V47" auf demselben Speicherplatz zu speichern.
Jetzt mein Code der so weit funktioniert
Vielen Dank
Hannes


Sub save2()
Dim Duration, Start
Duration = 60
Start = Timer
Do While Timer

und die codes die ich versucht habe aber nicht funktionieren (alle .jpg zeigen nur weisses bild).


Sub bild()
' nur weisses bild im abgespeicherten .JPG aber perfekte grafik mitten im Bildschirm
CODE 1
Application.ScreenUpdating = False
Dim bild As Chart
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Selection.CopyPicture
Set bild = Charts.Add
On Error Resume Next
bild.ChartArea.Clear
bild.Location Where:=xlLocationAsObject, Name:=ws.Name
Set bild = ActiveChart
bild.Paste
With ActiveSheet.Shapes(Right(bild.Name, InStr(1, bild.Name, "Dia") + 1))
.Height = Selection.ShapeRange.Height + 50
.Width = Selection.ShapeRange.Width + 50
'pfad anpassen!!!!!
bild.Export Filename:="G:\FTP_Main_Folder\Hannes\Webseite Excel\test.jpg", filterName:="jpg"
.Delete
End With
Application.ScreenUpdating = True
End Sub

--------------------------------------------------------------------------------------------------------------------------------------------------------------------------
CODE 2
--------------------------------------------------------------------------------------------------------------------------------------------------------------------------


Sub BereichAlsBildExportieren()
Application.ScreenUpdating = False
Range(ActiveSheet.PageSetup.PrintArea).CopyPicture Appearance:=xlPrinter, Format:=xlPicture
With ActiveSheet.ChartObjects.Add(0, 0, Range(ActiveSheet.PageSetup.PrintArea).Width, Range( _
ActiveSheet.PageSetup.PrintArea).Height).Chart
.Paste
.Export Filename:="G:\FTP_Main_Folder\Hannes\Webseite Excel\" & ThisWorkbook.Name & ".jpg", filterName:="JPG"
.Parent.Delete
End With
Application.ScreenUpdating = True
'leider nur ein weisses feld im .jpg
End Sub

--------------------------------------------------------------------------------------------------------------------------------------------------------------------------
CODE 3 Makro record
--------------------------------------------------------------------------------------------------------------------------------------------------------------------------


Sub Screenshot_Macro_2()
' Screenshot_Macro_2 Makro
' 2. versuch
Sheets("All").Select
ActiveWindow.SmallScroll ToRight:=-1
Range("A1:V47").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Sheets("Tabelle1").Select
ActiveSheet.Paste
ActiveSheet.Shapes.Range(Array("Picture 4")).Select
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc][+][-] Option Explicit Sub bild() Dim objChartObject As ChartObject Dim objRange As Range Application.ScreenUpdating = False Set objRange = Range(ActiveSheet.PageSetup.PrintArea) objRange.CopyPicture Set objChartObject = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, _ Width:=objRange.Width + 50, Height:=objRange.Height + 50) With objChartObject .Activate With .Chart .Paste .Export Filename:="G:\FTP_Main_Folder\Hannes\Webseite Excel\test.jpg", filterName:="jpg" End With .Delete End With Set objRange = Nothing Set objChartObject = Nothing Application.ScreenUpdating = True End Sub

Einen wunderschönen Montagmorgen,
hallo Nepomuck
Ein update, das Updaten des Sheets all mit diesem Code funktioniert jetzt, aber ich habe eine Fehlermeldung ab und zu, anscheinend, wenn ich an der Arbeitsmappe arbeite und anscheinend nicht auf dem "Sheet All" bin. Könnte ich da was ändern, dass es nicht passiert?
Sub Publish_HTM()
With ThisWorkbook.PublishObjects
Call .Add(SourceType:=xlSourceRange, Filename:="G:\FTP_Main_Folder\Hannes\Webseite Excel\wwwroot\CopyFX_Live1.htm", _
Sheet:="All", Source:="$A$1:$V$47", HtmlType:=xlHtmlStatic, _
DivID:="Tabelle1").Publish(Create:=True)
End With
End Sub Und-Oder wäre es möglich diesen code zu ändern
das der screenshot immer von.... Sheet"All" ...nimmt egal wo man gerade ist.
das =range Sheet All......PageSetup.PrintArea oder so
'Screenshot Nepomuck HerbersExcel
Application.ScreenUpdating = False
Set objRange = Range(ActiveSheet.PageSetup.PrintArea)
objRange.CopyPicture
Set objChartObject = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, _
Width:=objRange.Width, Height:=objRange.Height)
With objChartObject
.Activate
With .Chart
.Paste
.Export Filename:="G:\FTP_Main_Folder\Hannes\Webseite Excel\wwwroot\CopyFX_Live.jpg", filterName:="jpg"
End With
.Delete
End With
Set objRange = Nothing
Set objChartObject = Nothing
Application.ScreenUpdating = True
Die Echtzeitanzeige hat mir nur probleme gemacht und alles im 5 sekundentackt upgedatet und somit alles blockiert(wahrscheinlich mein Fehler). Gibts da eine andere lösung die man auch abschalten kann?Is aber nicht so wichtig
und weil mir das VBA wirklich spass macht und ich mich da weiterentwickeln will, noch eine frage die ich noch nicht so richtig in mich reinkriege.
"Diese Arbeitsmappe" --->


Private Sub Workbook_Open()
Application.OnTime Now + TimeValue("00:10:00"), "SaveThis"
End Sub

Das Workbook_Open() kann ich ja nur einmal benutzen,
wenn ich mehrere Sub laufen lassen will bei workbook open kann ich dann die alle untereinander schreiben vor "End Sub "?
ist die reihenfolge wichtig? Bei dem thema stockt es grade ein bischen
Oder besser, ein neues modul einfügen und alle subs aus diesem aufrufen.
etwa so.
Sub Name
Versuch1()
Dim..
Dim...
Dim...
Sub1
EndSub
Sub2
EndSub
Sub3
EndSub
oder
Sub1
Sub2
Sub3
EndSub
EndSub
EndSub
danke für die wahnsinnsgeduld die du mit mir hast
Hannes

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread