AW: Bild einer Textbox in einer UF "machen"?
06.07.2011 17:20:35
Reinhard
Hallo Christian,
PS: wer sich Hintergrundblabla ersparen möchte lese bitte unten erstmal nur das Fettgedruckte...
danke für die Gedanken die du dir gemacht hast.
Ich will die nächsten tage das sowieso auch in Excel lauffähig machen, kriege ich auch hin.
Und in Excel, da habe ich Code von Nepumuk, sogar recht frisch von vor paar tagen wo man einen Zellbereich in Excel als Bild in einem Image auf einer UF schnell darstellen kann.
Das geht über API aber es wird auch
.CopyPicture benutzt
Insofern bin ich mir sehr sicher ich bekomme das in Excel hin, auch mit dem optischen Blättern-Effekt durch Verkleinerung/vergrößerung der Image-Breiten.
Das "aber" bei .CopyPicture bezieht sich darauf daß Word das nicht kennt.
In Excel hat CopyPicture noch zwei Argumente, das eine ist/könnte z.B. xlBitmap sein, das andere weiß ich grad nicht müßte ich in der Hilfe nachschauen ist aber unwichtig *glaub* denn in Excel klappts ja.
In Word gibt es "CopyAsPicture", ohne Argumente, irgendwie ähnlich aber nicht das gleiche.
Nachfolgend ist der Code von Nepumuk der in Excel wie gewohnt super läuft.
Im Original steht/stand an der entscheidenden (leicht zu lokalisieren) Stelle:
Tabelle1.Range("A1:F10").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Wie ersichtlich habe ich da manches probiert, manche Versuche auch schon wieder gelöscht, jedenfalls klappt da nix, immer bleibt das Image leer. Seltsamerweise lief der Code oft durch, aber halt ohne sichtbares Ergebnis.
Userform2 hat nur das Image1.
Ich bräuchte/ erhoffe mir/wünsche mir Code dem ich sagen kann mache von Seite 7 im Worddokument ein Bild und füge es in das Image der UF ein.
Oder gleichwertig, mache ein Bild der TextboxA und füge es, ggfs. anstelle der textbox in ein Image der Uf ein.
Ich hoffe ich konnte mich verständlich machen. Dadurch daß ich so einen Bättern-Effekt dank Nepus Code in Excel hinkriege bin ich in Word noch keinen Schritt weiter. Insofern sehe ich für dieses problem nicht die Notwendigkeit von Code der in Excel funktioniert *glaub*
PS2: ich habe Kenntnis durch euch daß es da ein MOF o.ä. gibt, also ein Office-Forum auch für Word, hab auch den Link dazu.
Aber vielleicht schafft es auch ein hiesiger Excelianer da ein nettes Pic von soner mistegin Wordseite zu machen *lächel*
Gruß
Reinhard
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 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
Call EmptyClipboard
If TypeOf Selection Is Range Then
ActiveDocument.Range.CopyAsPicture
'.Content.r.CopyAsPicture
'ActiveDocument.Paragraphs(2).Range.CopyAsPicture 'Appearance:=wdScreen ', Format:= _
wdbitmap
' Tabelle1.Range("A1:F10").CopyPicture _
' Appearance:=xlScreen, Format:=xlBitmap
Set objPicture = Paste_Picture
If Not objPicture Is Nothing Then
Set UserForm2.Image1.Picture = objPicture
Else
MsgBox "Error - Sheet can't show in Userform", vbCritical, "Error"
End If
UserForm1.Show
End If
End Sub