Arkadaşlar,
Aşağıdaki kod ile listbox aracılığı ile sayfadan userformlara seçime göre resim ve text veri aktarıyordum.
Ancak ne olduysa, şimdi il kodun kırmızı kısımda "Obje yok" hatası veriyor.
F8 ile hatayı adımladığımda Modüldeki şu kodlardaki yeşil kısma gidiyor:
Yardımcı olur musunuz?
Aşağıdaki kod ile listbox aracılığı ile sayfadan userformlara seçime göre resim ve text veri aktarıyordum.
Ancak ne olduysa, şimdi il kodun kırmızı kısımda "Obje yok" hatası veriyor.
Kod:
Private Sub ListBox1_Click()
If UserForm4.OptionButton1 = True Then
Forma = "UserForm7"
ElseIf UserForm4.OptionButton2 = True Then
Forma = "test20"
End If
Set s1 = Worksheets("sayfa1")
MsgBox "Resim eklendi.", vbInformation, " Bilgi"
A = ListBox1.ListIndex + 2
Adres = s1.Cells(A, 1).Address
Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column).Address
If yer = Adres Then
sut = Picture.BottomRightCell.Row
s1.Shapes(Picture.Name).Select
s1.Shapes(Picture.Name).CopyPicture
[COLOR="Red"]Forma.Image1.Picture = PastePicture[/COLOR]
Unload Me
Exit For
End If
End If
Next Picture
Unload Me
End SubF8 ile hatayı adımladığımda Modüldeki şu kodlardaki yeşil kısma gidiyor:
Kod:
Option Explicit
Option Compare Text
#If Win64 Then
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare PtrSafe 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
#Else
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) 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
#End If
#If VBA7 Then
#Else
#End If
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Const CF_BITMAP = 2
[COLOR="Green"]Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture[/COLOR]
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, 14)
hPicAvail = IsClipboardFormatAvailable(lPicType)
If hPicAvail <> 0 Then
h = OpenClipboard(0&)
If h > 0 Then
hPtr = GetClipboardData(lPicType)
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, 0, 0, 0, 4)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
h = CloseClipboard
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If
End Function
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
With IID_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 uPicInfo
.Size = Len(uPicInfo)
.Type = IIf(lPicType = CF_BITMAP, 1, 4)
.hPic = hPic
.hPal = IIf(lPicType = CF_BITMAP, hPal, 0)
End With
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
'If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
Set CreatePicture = IPic
End FunctionYardımcı olur musunuz?
Son düzenleme:
