Anzeige
Archiv - Navigation
1164to1168
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

Tabellenausschnitt als Bild in Image einer UF

Tabellenausschnitt als Bild in Image einer UF
Peter
Hallo und guten Abend,
mit diesem Makro lade ich ein Diagramm in ein Image einer Userform.
Jetzt möchte ich aber gern eine Tabelle oder besser einen Tabellenausschnitt in eine Userform bringen.
Problem ist: ich möchte ein Ranging darstellen. Siehe Bsp. Wenn ich aber das Diagramm in die Userform lade verführt es den Betrachter in eine Ungewissheit - Ranging Platz 1 aber die kleinste Säule.
Daher die Überlegung nur den Tabellenausschnitt als Bild im Image darzustellen.
oder hat jemand eine ganz andere Idee ein Ranging darzustellen.
Danke für Hilfe vorab
Gruß Peter

Die Datei https://www.herber.de/bbs/user/70398.xls wurde aus Datenschutzgründen gelöscht


Daten ab A151
Private Sub LoadDiagramm(Optional booKill As Boolean = True)
Application.Visible = False
Dim Diagramm As Chart, sngW As Single, sngH As Single
strPfad = ThisWorkbook.Path
If Right(strPfad, 1)  "\" Then strPfad = strPfad & "\"
strPfad = strPfad & "DiaImage.gif"
If Not booKill Then
Set Diagramm = Tabelle1.ChartObjects(7).Chart
With Diagramm.Parent
sngW = .Width
sngH = .Height
.Width = Image2.Width / 0.75
.Height = Image2.Height / 0.75
Diagramm.Export Filename:=strPfad, FilterName:="GIF"
Image2.Picture = LoadPicture(strPfad)
.Width = sngW
.Height = sngH
End With
Else
On Error Resume Next
Kill strPfad
On Error GoTo 0
End If
End Sub

AW: Tabellenausschnitt als Bild in Image einer UF
03.07.2010 00:14:05
Nepumuk
Hallo,
und warum nicht einfach Tabelle und Diagramm?
https://www.herber.de/bbs/user/70399.xls
Gruß
Nepumuk
P.S. Ranging gibt es zwar auch (Entfernung messen) aber ich denke du meine Ranking (Rangliste)
AW: Tabellenausschnitt als Bild in Image einer UF
03.07.2010 00:28:35
Peter
Hallo
Danke sieht ja gut aus
Ja ich meine Rangliste
Gruß Peter
AW: Tabellenausschnitt als Bild in Image einer UF
03.07.2010 08:17:22
Ramses
Hallo Max
Unter E2007 funktioniert das nicht.
Da kommt ständig die Fehlermeldung: "Error - Chart can't show....."
Entweder klappt das Kopieren der Grafik schon nicht
Tabelle1.ChartObjects(1).Chart.CopyPicture _
Appearance:=xlScreen, Format:=xlBitmap
oder die Abfrage nach Bildtyp wird unter W7 nicht verstanden
If IsClipboardFormatAvailable(CF_BITMAP) 0 Then
Denn objPicture ist nach dieser Zeile
Set objPicture = Paste_Picture
nothing, und demzufolge kommt es zur Fehlermeldung.
Witzigerweise wird die Tabelle korrekt als Image dargestellt.
Hast du eine Idee an was das liegen kann ?
Gruss Rainer
Anzeige
AW: Tabellenausschnitt als Bild in Image einer UF
03.07.2010 09:01:14
Nepumuk
Hallo Rainer,
unter Excel 2007 füge ich das Charts erst als Bild in eine Tabelle und dann diese Bild ins Userform.
In die selbe Tabelle einfügen ist mir zu Umständlich, denn anders als in den Vorgängerversionen von Excel 2007 bekommt ein eingefügtes Shape nicht automatisch den höchsten Index, sondern irgendeinen dazwischen. Ich hab's noch nicht ganz durchschaut, aber anscheinend werden da "Type-Groups" gebildet. Daher ist das nicht mehr so eindeutig wie früher. Weiß der Teufel an welcher geistiger Umnachtung der verantwortliche Programmierer litt.
Beispiel:
Option Explicit

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
    ByRef PicDesc As PIC_DESC, _
    ByRef RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    ByRef IPic As IPictureDisp) As Long
Declare Function CopyImage Lib "user32.dll" ( _
    ByVal handle As Long, _
    ByVal un1 As Long, _
    ByVal n1 As Long, _
    ByVal n2 As Long, _
    ByVal un2 As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
    ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Integer) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare 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 PIC_DESC
    lngSize As Long
    lngType As Long
    lnghPic As Long
    lnghPal As Long
End Type

Private Const PICTYPE_BITMAP = 1
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"

Private Function Paste_Picture() As IPictureDisp
    
    Dim lngReturn As Long, lngCopy As Long, lngPointer As Long
    
    If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
        lngReturn = OpenClipboard(Application.hWnd)
        If lngReturn > 0 Then
            lngPointer = GetClipboardData(CF_BITMAP)
            lngCopy = CopyImage(lngPointer, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
            Call CloseClipboard
            If lngPointer <> 0 Then Set Paste_Picture = Create_Picture(lngCopy, 0&, CF_BITMAP)
        End If
    End If
    
End Function

Private Function Create_Picture( _
        ByVal lnghPic As Long, _
        ByVal lnghPal As Long, _
        ByVal lngPicType As Long) As IPictureDisp

    
    Dim udtPicInfo As PIC_DESC, udtID_IDispatch As GUID
    Dim objPicture As IPictureDisp
    
    With udtID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    
    With udtPicInfo
        .lngSize = Len(udtPicInfo)
        .lngType = PICTYPE_BITMAP
        .lnghPic = lnghPic
        .lnghPal = lnghPal
    End With
    
    Call OleCreatePictureIndirect(udtPicInfo, udtID_IDispatch, 0&, objPicture)
    
    Set Create_Picture = objPicture
    
End Function

Public Sub Show_Sheet()
    
    Dim objPicture As IPictureDisp
    Dim objWorksheet As Worksheet
    
    Call EmptyClipboard
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Tabelle1.ChartObjects(1).Copy
    
    Set objWorksheet = Worksheets.Add
    objWorksheet.PasteSpecial Format:="Bild (JPEG)"
    objWorksheet.Shapes(1).CopyPicture _
        Appearance:=xlScreen, Format:=xlBitmap
    
    Set objPicture = Paste_Picture
    
    objWorksheet.Delete
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    
    If Not objPicture Is Nothing Then
        UserForm1.Image1.Picture = objPicture
    Else
        MsgBox "Error - Chart can't show in Userform", vbCritical, "Error"
    End If
    
    Tabelle1.Range("A151:E159").CopyPicture _
        Appearance:=xlScreen, Format:=xlBitmap
    
    Set objPicture = Paste_Picture
    
    If Not objPicture Is Nothing Then
        UserForm1.Image2.Picture = objPicture
    Else
        MsgBox "Error - Sheet can't show in Userform", vbCritical, "Error"
    End If
    
    UserForm1.Show
    
End Sub

Gruß
Max
Anzeige
Danke für die Korrektur und Info...
03.07.2010 15:34:51
Ramses
Hallo Max
Weil bei den API Funktionen kapituliere ich relativ früh weil ich sie einfach zu wenig brauche :-)
Gruss Rainer
Auch Dir Dankeschön für die Info o.w.T
03.07.2010 15:35:21
Ramses
...
AW: Auch Dir Dankeschön für die Info o.w.T
04.07.2010 12:31:14
Peter
Hallo wertes Forum
möchte mich bei allen nochmals recht herzlich bedanken für die tollen Ideen
Alles kann ich 100%ig in meine Datei einbauen
Gruß Peter
Bis bald

308 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige