Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1576to1580
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA soll Werte aus Tabelle verwenden.

VBA soll Werte aus Tabelle verwenden.
02.09.2017 18:21:02
Oli
Hallo liebe Ecxelianer,
mit diesem Schnipsel (vielen Dank für die Hilfe vor ein paar Tagen) lässt sich nun ein ein gewisser Teil der Tabelle als Bildschirmkopie abspeichern.
Sub TabelleExportierenAlsBild()
Application.ScreenUpdating = False
ActiveSheet.Range("A1:M34").CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ActiveSheet.ChartObjects.Add(0, 0, Range("A1:M34").Width, Range("A1:M34").Height).Chart
.Paste
.Export "C:\Users\Oli\Cloud\IchBinDeko.gif"
.Parent.Delete
End With
Application.ScreenUpdating = True
End Sub
Ich möcht jedoch das immer nur die aktuellen 14 Monate ab heute aus dem Kalender gespeichert werden. Also ein Bild eben nur von diesem begrenzen Bereich machen.
Jetzt habe ich mir beholfen, in dem ich vom aktuellen Tagesdatum den Monat ausrechne und dann per SVERWEIS den Startbereich und Endbereich zu berechnen.
Aber wie kann ich vba beibringen, das ich eben genau nur diesen Bereich kopiert und abgespeichert haben möchte?
Zur Veranschaulichkeit habe ich hier das betreffende Dokument hochgeladen:
https://www.herber.de/bbs/user/115962.xlsm
Hat jemand eine Tipp für mich? Ich habe es schon mit .Cell(X,X) probiert, bekomme es aber einfach nicht hin.
Ich bedanke mich bereits jetzt ganz freundlich fürs grübeln.
Viele Grüße
Oli

24
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 18:54:25
Sepp
Hallo Oli,
den Umweg über das Diagramm kann man sich sparen und das Bild direkt speichern.
Die Berechnung der Spalten geht auch einfach.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
'© 2015 by Nepumuk - http://www.herber.de/forum/messages/1458287.html

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef _
  PicDesc As PICT_DESC, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, ByRef _
  IPic As IPicture) As LongPtr
Private Declare PtrSafe Function CopyImage Lib "user32.dll" (ByVal handle As LongPtr, _
  ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal _
  wFormat As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hwnd As LongPtr) As _
  Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) _
  As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) _
  As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" (ByVal lpsz As Any, ByRef _
  pCLSID As GUID) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Type PICT_DESC
  lSize As Long
  lType As Long
  hPic As LongPtr
  hPal As LongPtr
End Type

Private Const PICTYPE_BITMAP As Long = 1
Private Const CF_BITMAP As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG As Long = &H4
Private Const GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"

Sub TabelleExportierenAlsBild()
Dim strFile As String
Dim varRet1 As Variant, varRet2 As Variant
Dim objRange As Object

strFile = "E:\Forum\test.jpg"

varRet1 = Application.Match(Clng(DateSerial(Year(Date), Month(Date), 1)), Rows(4), 0)
varRet2 = Application.Match(Clng(DateSerial(Year(Date), Month(Date) + 13, 1)), Rows(4), 0)

If IsNumeric(varRet1) And IsNumeric(varRet2) Then
  Set objRange = Range(Cells(1, varRet1), Cells(34, varRet2))
  Call SaveRange2Image(objRange, strFile)
End If

End Sub

Private Function PastePicture(ByRef prlngptrCopy As LongPtr) As IPictureDisp

Dim lngReturn As Long, lngptrPointer As LongPtr

If Cbool(IsClipboardFormatAvailable(CF_BITMAP)) Then
  
  lngReturn = OpenClipboard(CLngPtr(Application.hwnd))
  
  If lngReturn > 0 Then
    
    lngptrPointer = GetClipboardData(CF_BITMAP)
    
    prlngptrCopy = CopyImage(lngptrPointer, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
    
    Call CloseClipboard
    
    If lngptrPointer <> 0 Then Set PastePicture = CreatePicture(prlngptrCopy, 0)
    
  End If
End If
End Function

Private Function CreatePicture(ByVal lngptrhPic As LongPtr, ByVal lngptrhPal As LongPtr) As IPictureDisp

Dim udtPicInfo As PICT_DESC, udtID_IDispatch As GUID
Dim objPicture As IPictureDisp

Call CLSIDFromString(StrPtr(GUID_IPICTUREDISP), udtID_IDispatch)

With udtPicInfo
  .lSize = Len(udtPicInfo)
  .lType = PICTYPE_BITMAP
  .hPic = lngptrhPic
  .hPal = lngptrhPal
End With

Call OleCreatePictureIndirect(udtPicInfo, udtID_IDispatch, 0&, objPicture)

Set CreatePicture = objPicture

Set objPicture = Nothing

End Function

Public Function SaveRange2Image(ByRef Target As Range, ByVal FileName As String) As Long
Static slngptrCopy As LongPtr

Call OpenClipboard(0&)
Call EmptyClipboard
Call CloseClipboard

If slngptrCopy <> 0 Then Call DeleteObject(slngptrCopy)

Target.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

If SaveClipboardImage(FileName) Then
  SaveRange2Image = -1
Else
  SaveRange2Image = 0
End If

End Function

Private Function SaveClipboardImage(FileName As String) As Boolean
Dim lPicType As Long, oPic As Variant
lPicType = xlBitmap
Set oPic = PastePicture(lPicType)
If oPic Is Nothing Then Exit Function
SavePicture oPic, FileName
SaveClipboardImage = True
End Function

https://www.herber.de/bbs/user/115963.xlsm
Gruß Sepp

Anzeige
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 20:00:53
Oli
Hallo SEPP,
vielen lieben Dank. Leider funktioniert dein Lösungsvorschlag bei mir nicht. Ich hatte davon bereits sehr lange experimentiert (da das Makro auf unterschiedlichen Windows- und Officeversionen laufen soll, und das tut es mit der Version von mir sehr gut) und kam nur auf die Lösung, die ich oben angeführt hatte. Ich würde davon ungern abweichen, nur eben um die variablen ergänzen. Ich verstehe ich leider nicht recht und alle experimente scheitern. Eine idee war auch:
Sub TabelleExportierenAlsBild()
Dim varRet1 As Variant, varRet2 As Variant
Dim objRange As Object
varRet1 = Application.Match(CLng(DateSerial(Year(Date), Month(Date), 1)), Rows(4), 0)
varRet2 = Application.Match(CLng(DateSerial(Year(Date), Month(Date) + 13, 1)), Rows(4), 0)
Application.ScreenUpdating = False
ActiveSheet.Range(varRet1 & ":" & varRet2).CopyPicture Appearance:=xlScreen, Format:= _
xlPicture
With ActiveSheet.ChartObjects.Add(0, 0, Range(varRet1 & ":" & varRet2).Width, Range(varRet1 & _
":" & varRet2).Height).Chart
.Paste
.Export "C:\Users\Oli\Cloud\IchBinDeko.gif"
.Parent.Delete
End With
Application.ScreenUpdating = True
End Sub
Leider funktioniert es nicht. Vielleicht hast du eine Idee.
Ich könnte verstehen wenn du mir nun einen imaginären Vogel zeigst, wieso ich da weiter machen will.
Viele Grüße
Oli
Anzeige
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 20:16:05
Sepp
Hallo Oli,
"funktioniert nicht" ist meine Lieblings-Fehlermeldung.
aber egal, dann halt so.
Sub TabelleExportierenAlsBild()
Dim varRet1 As Variant, varRet2 As Variant
Dim objRange As Object

varRet1 = Application.Match(Clng(DateSerial(Year(Date), Month(Date), 1)), Rows(4), 0)
varRet2 = Application.Match(Clng(DateSerial(Year(Date), Month(Date) + 13, 1)), Rows(4), 0)

Application.ScreenUpdating = False

If IsNumeric(varRet1) And IsNumeric(varRet2) Then
  With ActiveSheet
    Set objRange = .Range(.Cells(1, varRet1), .Cells(34, varRet2))
    objRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    With .ChartObjects.Add(0, 0, objRange.Width, objRange.Height).Chart
      .Paste
      .Export "C:\Users\Oli\Cloud\IchBinDeko.gif"
      .Parent.Delete
    End With
  End With
End If

Application.ScreenUpdating = True
Set objRange = Nothing
End Sub

Gruß Sepp

Anzeige
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 20:34:15
Oli
Hallo SEPP,
du hast natürlich absolut recht, was für eine duppe Aussge von mir. Aber auf Grund deiner Ironie musste ich absolut laut loslachen. Danke.
Leider funktioniert es nicht, es wird zwar ein Bild abgespeichert, dies ist jedoch weiß (also leer). Das war auch der Grund weswegen ich mich für den ursprünglichen Code entschieden hatte. Mit Win 7 und Office 2013 funktioniert es. Aber unter Win 10 mit Office 2016 geht es nicht. Ich hatte auch nie eine Erklätung dafür.
Vielleicht fällt dir ja noch etwas ein.
https://www.herber.de/bbs/user/115965.xlsm
Viele Grüße
Oli
Anzeige
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:00:21
Oli
Hallo, als Alternative würde mir es auch reichen, wenn ich wüsste wie man es hinbekomt das in einem Monat ein Makro und im nächsten Monat ein anderes Makro ausgelößt wird.
Vielleicht hat da ja auch jemand eine Idee?
Besten Dank und beste Grüße
Oliver
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:09:52
Sepp
Hallo Oli,
was funktioniert den an meinem zweiten Code nicht?
Gruß Sepp

AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:23:35
Oli
Es wird einzig ein leeres (weißes) Bild abgespeichert.
Viele Grüße
Oli
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:26:05
Sepp
Hallo Oli,
das ist aber der Code, der laut deiner Aussage funktioniert.
Gruß Sepp

Anzeige
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:32:25
onur

Sub TabelleExportierenAlsBild()
Dim varRet1 As Variant, varRet2 As Variant
Dim objRange As Object
varRet1 = Application.Match(CLng(DateSerial(Year(Date), Month(Date), 1)), Rows(4), 0)
varRet2 = Application.Match(CLng(DateSerial(Year(Date), Month(Date) + 13, 1)), Rows(4), 0)
Application.ScreenUpdating = False
If IsNumeric(varRet1) And IsNumeric(varRet2) Then
With ActiveSheet
Set objRange = .Range(.Cells(1, varRet1), .Cells(34, varRet2))
objRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With .ChartObjects.Add(0, 0, objRange.Width, objRange.Height).Chart
'Folgende Zeile fehlte
ActiveSheet.ChartObjects(1).Activate
.Paste
.Export "C:\Users\Oli\Cloud\IchBinDeko.gif"
.Parent.Delete
End With
End With
End If

Anzeige
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:42:16
Oli
Hallo,
exakt das Gleiche. Der Code funktioniert gut, aber es wird ein leeres (weißes) bild abgespeichert.
Ich bin wirklich Ratlos.
Beste Grüße
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:51:29
onur
Hast du alles so übernommen wie oben?
Bei mir läuft es mit dieser Version - mit Deiner nicht.
Userbild
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:53:19
Oli
Hallo, ja es ist wie verhext. Unter Windows 7 mit Office 2013 funktioniert es bei bei dir und unter windows 10 mit office 2016 geht es nicht. Ich verstehe das nicht.
Viele Grüße
Oli
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:56:20
onur
Wie kommst du drauf, ich hätte Windows 7 und Office 2013?
Ich habe Windows 10 und Office 2016-
Anzeige
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:57:40
Oli
Nein, ich habe es auf meinem Windows 7 mit Office 2013 getestet dort geht es wunderbar und bei mir an meinem privatrechner geht es nicht.
Das meinte ich.
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 23:04:42
onur
Schmeiss doch mal die Zeilen mit
Application.ScreenUpdating......
raus.
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 23:14:28
Oli
Ja hatte ich als erstes Probiert... das Ergebnis ist immer das gleiche... Deswegen viel mir etzt nur noch die umständliche Lösung ein, den Monat herauszufinden um dann ein Makro für jeden Monat zu Bastelln.
Mhhhh echt verflixt
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 23:19:47
onur
Bau doch mal auf dem Rechner, wo es nicht klappt, ein "Stop" vor der ".Paste"-Zeile ein und schaue nach, ob du das Diagramm mit dem Bild sehen kannst.
Wenn nein, hast du ein anderes Problem.
Anzeige
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 23:33:31
Oli
Das Diagramm ist bereits weiß (also leer)
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 23:35:56
onur
Sorry - unmittelbar NACH Paste.
AW: VBA soll Werte aus Tabelle verwenden.
03.09.2017 00:11:49
Oli
Da ist alles wunderbar! Es funktioniert!!!! Danke! Woran es nun lag, keine Ahnung habe noch etwas an den Diagrammeinstellungen gewerkelt und siehe da, es klappt. Wieso es davor nicht geklappt hat ist mir ein Rätsel.
Wie kann ich mich dir gegenüber erkenntlich zeigen? Kann ich dir etwas gutes tun, da du so viel Zeit mit mir verbracht hast?
Viele Grüße
Oli
AW: VBA soll Werte aus Tabelle verwenden.
03.09.2017 01:00:05
onur
Kein Problem - Gerne geschehen!
AW: VBA soll Werte aus Tabelle verwenden.
02.09.2017 22:59:03
onur
Name: Oli Version: 2013 - Office 365
Betreff: AW: VBA soll Werte aus Tabelle verwenden. Level: Excel gut - VBA bescheiden
Jetzt weiss ich, wie du drauf kommst.
Ich weiss nicht, wo die das Forum diese Angaben hat, sie sind nicht von mir gemacht.
Anzeige
AW: VBA soll Werte aus Tabelle verwenden.
03.09.2017 10:24:58
Werner
Hallo Onur,
das sind Angaben vom Beitragsersteller, die aber dann auch bei den Beiträgen der Antowrter angezeigt werden.
Gruß Werner
AW: VBA soll Werte aus Tabelle verwenden.
03.09.2017 11:16:05
onur
Hallo Werner,
Stimmt ja - Danke.
Ich konnte mich nie erinnern, irgend welche Angaben dieser Art gemacht zu haben.
Onur

301 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige