DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Benim genelde kullandığım bir form var onu ekliyorum.
Halit hocam sağolun,
Private Sub CommandButton1_Click()
ActiveSheet.Shapes("Resim 2").Select
ActiveSheet.Shapes("Resim 2").CopyPicture
Me.Image1.Picture = PastePicture
End Subbirde bu dosyaya bak
Private Sub CommandButton3_Click()
If TextBox8.Text <> "" Then
Son_Dolu_Satir = Sheets("liste").Range("A65536").End(3).Row
If WorksheetFunction.CountIf(Sheets("liste").Range("B1:B" & Son_Dolu_Satir), TextBox8.Text) > 0 Then
MsgBox "Bu resim adıyla bir resim atıldı", vbCritical
GoTo 20
End If
Bos_Satir = Son_Dolu_Satir + 1
Sheets("liste").Range("A" & Bos_Satir).Value = _
Application.WorksheetFunction.Max(Sheets("liste").Range("A:A")) + 1
Sheets("liste").Range("A" & Bos_Satir).Value = ComboBox2.Text
Sheets("liste").Range("B" & Bos_Satir).Value = TextBox8.Text
Sheets("liste").Range("C" & Bos_Satir).Value = TextBox9.Text
Sheets("liste").Range("D" & Bos_Satir).Value = TextBox10.Text
Sheets("liste").Range("E" & Bos_Satir).Value = TextBox11.Text
Sheets("liste").Range("F" & Bos_Satir).Value = TextBox12.Text
Sheets("liste").Range("G" & Bos_Satir).Value = TextBox13.Text
Sheets("liste").Range("H" & Bos_Satir).Value = TextBox14.Text
Sheets("liste").Pictures.Insert(resim_adi).Select
Selection.Top = Range("I" & Bos_Satir).Top: Selection.Left = Range("I" & Bos_Satir).Left
Selection.ShapeRange.LockAspectRatio = msoFalse: Selection.ShapeRange.Height = 200: Selection.ShapeRange.Width = 293
ActiveCell.Select
Sheets("liste").Select
MsgBox "Görsel havuza atıldı.", vbInformation, "Yeni bir soru ekleyebilirsiniz."
For i = 8 To 14
Controls("TextBox" & i).Value = ""
Next i
Else
GoTo 5
End If
Exit Sub
5
MsgBox "İstenen verileri eksiksiz girdiğinizden emin olduktan sonra tekrar deneyiniz.", vbExclamation, "Kontrol"
20:
End SubPrivate Sub CheckBox6_Click()
Dim k As Range, sonsat As Long
Sheets("liste").Select
sonsat = Cells(Rows.Count, "B").End(xlUp).Row
Set k = Range("B2:B" & sonsat).Find(ListBox1.Column(1), , xlValues, xlWhole)
If Not k Is Nothing Then
Range("A" & k.Row & ":I" & k.Row).Select
UserForm3.TextBox47.Text = Cells(ActiveCell.Row, "b")
UserForm3.TextBox48.Text = Cells(ActiveCell.Row, "c")
UserForm3.TextBox49.Text = Cells(ActiveCell.Row, "d")
UserForm3.TextBox50.Text = Cells(ActiveCell.Row, "e")
UserForm3.TextBox51.Text = Cells(ActiveCell.Row, "f")
UserForm3.TextBox52.Text = Cells(ActiveCell.Row, "g")
UserForm3.TextBox53.Text = Cells(ActiveCell.Row, "h")
End If
End Sub Sheets("liste").Pictures.Insert(resim_adi).Select
Selection.Top = Range("I" & Bos_Satir).Top: Selection.Left = Range("I" & Bos_Satir).Left
Selection.ShapeRange.LockAspectRatio = msoFalse: Selection.ShapeRange.Height = 200: Selection.ShapeRange.Width = 293
ActiveCell.SelectBu sorunuz doğrultusunda dosyanızın küçük bir örneğini ekleyin listbox ın nasıl çalıştığına bir bakalım
Cevapları çok geç yazıyorsunuz ben sizin sorunuzu baya geç hatırladım
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
Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture
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 FunctionPrivate Sub ListBox1_Click()
Set S1 = Worksheets("sayfa1")
a = ListBox1.ListIndex + 2
Adres = Worksheets("sayfa1").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
UserForm2.Image1.Picture = PastePicture
UserForm2.TextBox7.Text = Cells(sut, "h")
UserForm2.TextBox2.Text = Cells(sut, "c")
UserForm2.TextBox3.Text = Cells(sut, "d")
UserForm2.TextBox4.Text = Cells(sut, "e")
UserForm2.TextBox5.Text = Cells(sut, "f")
UserForm2.TextBox6.Text = Cells(sut, "g")
Exit For
End If
End If
Next Picture
UserForm2.Show
End Sub