Grafik in Image, wenn Text in TextBox

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Dieter,
ich glaube, das funktioniert so gar nicht. Aber vielleicht weiß es ja einer besser....
Ansonsten kann ich Dir folgenden Code anbieten, der nach kurzer Anpassung auf Deine Verhältnisse die angegebene Grafik in Dein Userform-Image setzt. (Konnte leider nur die 64-Bit-Variante testen)
Probiere es einfach mal aus:

Option Explicit

#If VBA7 Then

Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _

        ByRef PicDesc As PIC_DESC, ByRef RefIID As GUID, _

        ByVal fPictureOwnsHandle As LongPtr, ByRef IPic As IPictureDisp) As Long

Private Declare PtrSafe Function CopyImage Lib "user32" ( _

        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" ( _

        ByVal wFormat As Long) As Long

Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _

        ByVal hMem As LongPtr) As LongPtr

Private Declare PtrSafe Function GetClipboardData Lib "user32" ( _

        ByVal wFormat As Long) As LongPtr

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long

Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long

Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" _

        Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long

Private Type PIC_DESC

   lSize As Long

   lType As Long

   hPic  As LongPtr

   hPal  As LongPtr

End Type

#Else

Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _

        ByRef PicDesc As PIC_DESC, ByRef RefIID As GUID, _

        ByVal fPictureOwnsHandle As Long, ByRef IPic As IPictureDisp) As Long

Private Declare Function CopyImage Lib "user32" ( _

        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" ( _

        ByVal wFormat As Long) As Long

Private Declare  Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _

        ByVal hMem As Long) As Long

Private Declare Function GetClipboardData Lib "user32" ( _

        ByVal wFormat As Long) As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function EmptyClipboard Lib "user32" () As Long

Private Declare Function RegisterClipboardFormat Lib "user32" _

        Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long

Private Type PIC_DESC

   lSize As Long

   lType As Long

   hPic  As Long

   hPal  As Long

End Type

#End If

Private Type GUID

   Data1 As Long

   Data2 As Integer

   Data3 As Integer

   Data4(0 To 7) As Byte

End Type

Private Const PICTYPE_BITMAP = 1

Private Const CF_BITMAP = 2

Private Const IMAGE_BITMAP = 0

Private Const LR_COPYRETURNORG = &H4

Sub KopiereBildinUserform()

 CopyPictureByName "Picture 16"

 Paste_Picture

 UserForm1.Show

End Sub

Function CopyPictureByName(sBild As String) As Boolean

'Kopiert das angegebne Bild in die Zwischenablage

 Dim oShape As Shape

 With ActiveSheet

   For Each oShape In .Shapes

     If oShape.Name = sBild Then

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

        CopyPictureByName = True

        DoEvents

        Exit For

     End If

   Next oShape

 End With

End Function

Sub Paste_Picture()

'Holt ein Bild aus der Zwischenablage und esfügt in das Control ein

 Dim oPict As IPictureDisp

 #If VBA7 Then

 Dim hPic  As LongPtr, hCopy As LongPtr

 #Else

 Dim hPic  As Long, hCopy As Long

 #End If

 If IsClipboardFormatAvailable(CF_BITMAP) &LT;&GT; 0 Then

    If OpenClipboard(0&) &LT;&GT; 0 Then

       hPic = GetClipboardData(CF_BITMAP)

       hCopy = CopyImage(hPic, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)

       CloseClipboard

       If hPic &LT;&GT; 0 Then Set oPict = Create_Picture(hCopy)

        If Not oPict Is Nothing Then

'######### Hier die Userform und Image-Angaben anpassen ########

           UserForm1.Image3.Picture = oPict

        Else

           MsgBox "Das Bild kann nicht angezeigt werden", vbCritical, "Bild einfügen"

        End If

    End If

 End If

End Sub

#If VBA7 Then

Private Function Create_Picture( _

        ByVal hPic As LongPtr) As IPictureDisp

#Else

Private Function Create_Picture( _

        ByVal hPic As Long) As IPictureDisp

#End If

 Dim tPicInfo As PIC_DESC, tID_IDispatch As GUID

 Dim oPict As IPictureDisp

 With tID_IDispatch

     .Data1 = &H20400

     .Data4(0) = &HC0

     .Data4(7) = &H46

 End With

 With tPicInfo

     .lSize = Len(tPicInfo)

     .lType = PICTYPE_BITMAP

     .hPic = hPic

     .hPal = 0

 End With

 OleCreatePictureIndirect tPicInfo, tID_IDispatch, 0&, oPict

 Set Create_Picture = oPict

End Function

viele Grüße
Karl-Heinz

If TextBox4.Text = "Wassermann" Then UserForm1.Grup1.Visible = True Else Grup1.Visible = False End If If TextBox4.Text = "Fische" Then UserForm1.Grup2.Visible = True Else Grup2.Visible = False End If If TextBox4.Text = "Widder" Then UserForm1.Grup3.Visible = True Else Grup3.Visible = False End If If TextBox4.Text = "Stier" Then UserForm1.Grup4.Visible = True Else Grup4.Visible = False End If If TextBox4.Text = "Zwilling" Then UserForm1.Grup5.Visible = True Else Grup5.Visible = False End If If TextBox4.Text = "Krebs" Then UserForm1.Grup6.Visible = True Else Grup6.Visible = False End If If TextBox4.Text = "Löwe" Then UserForm1.Grup7.Visible = True Else Grup7.Visible = False End If If TextBox4.Text = "Jungfrau" Then UserForm1.Grup8.Visible = True Else Grup8.Visible = False End If If TextBox4.Text = "Waage" Then UserForm1.Grup9.Visible = True Else Grup9.Visible = False End If If TextBox4.Text = "Skorpion" Then UserForm1.Grup10.Visible = True Else Grup10.Visible = False End If If TextBox4.Text = "Schütze" Then UserForm1.Grup11.Visible = True Else Grup11.Visible = False End If If TextBox4.Text = "Steinbock" Then UserForm1.Grup12.Visible = True Else Grup12.Visible = False End If

'Grafiken Tierkreiszeichen zeigen ja/nein Dim crt As Object If TextBox4 "" Then For Each crt In Me.Controls If crt.Name Like "imgTK_*" Then If crt.Name Like "*" & TextBox4.Text Then crt.Visible = True Else crt.Visible = False End If End If Next End If End Sub

Beliebteste Forumthreads (12 Monate)

Grafik in Image, wenn Text in TextBox

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Grafik in Image, wenn Text in TextBox

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread