Makro ile resim ekleme

07ahm07 · 21 Haziran 2014

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.DrawingObjects.Delete
For x = 7 To 19
Range("a" & x).Select
resimadi = LoadPicture("")
resimadi = Range("b" & x).Text & ".jpg"
On Error Resume Next
ActiveSheet.Pictures.Insert("Z:\ÜRÜN RESİMLERİ\" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = ActiveCell.Top
Selection.Left = ActiveCell.Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = ActiveCell.Height
Selection.ShapeRange.Width = ActiveCell.Width
Selection.ShapeRange.Rotation = 0#
Range("b7").Select
Next
End Sub

yukarıda yazılı kod ile yapmak istediğim işlemi gerçekleştirebiliyorum fakat sayfadaki logomda siliniyor sadece eklediklerini silmek için nasıl bir değişiklik yapılabilir ?

halit3 · 21 Haziran 2014

07ahm07' Alıntı:
Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.DrawingObjects.Delete
For x = 7 To 19
Range("a" & x).Select
resimadi = LoadPicture("")
resimadi = Range("b" & x).Text & ".jpg"
On Error Resume Next
ActiveSheet.Pictures.Insert("Z:\ÜRÜN RESİMLERİ\" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = ActiveCell.Top
Selection.Left = ActiveCell.Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = ActiveCell.Height
Selection.ShapeRange.Width = ActiveCell.Width
Selection.ShapeRange.Rotation = 0#
Range("b7").Select
Next
End Sub

yukarıda yazılı kod ile yapmak istediğim işlemi gerçekleştirebiliyorum fakat sayfadaki logomda siliniyor sadece eklediklerini silmek için nasıl bir değişiklik yapılabilir ?

Örnek dosyanızı ekleseydiniz daha kolay anlaşılacaktı sorunuz.

kod:

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B7:B19]) Is Nothing Then Exit Sub

yatay = -1 ' bu kadar hücre sağa kayacak
dikey = 0  ' bu kadar hücre aşağıya kayacak

Dim s1
Set s1 = Sheets(ActiveSheet.Name)

If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") = 0 Then
Set Adres = s1.Cells(Target.Row + dikey, Target.Column + yatay)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

Set yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column)
If yer.Address = Adres.Address Then

Picture.Delete
Exit For
End If

End If
Next Picture

ReDim uzanti(11)
uzanti(1) = "jpg":        uzanti(2) = "JPG"
uzanti(3) = "bmp":        uzanti(4) = "BMP"
uzanti(5) = "gif":        uzanti(6) = "GİF"



For j = 1 To 6

Dosya = "Z:\ÜRÜN RESİMLERİ\" & Target.Value & "." & uzanti(Val(j))
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
ad = s1.Pictures.Insert(Dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 2
s1.Cells(Target.Row + 1, Target.Column).Select

Exit For
End If
Next


End If
End Sub

BedriA · 14 Haziran 2017

halit3' Alıntı:

Örnek dosyanızı ekleseydiniz daha kolay anlaşılacaktı sorunuz.

kod:

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B7:B19]) Is Nothing Then Exit Sub

yatay = -1 ' bu kadar hücre sağa kayacak
dikey = 0  ' bu kadar hücre aşağıya kayacak

Dim s1
Set s1 = Sheets(ActiveSheet.Name)

If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") = 0 Then
Set Adres = s1.Cells(Target.Row + dikey, Target.Column + yatay)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

Set yer = s1.Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column)
If yer.Address = Adres.Address Then

Picture.Delete
Exit For
End If

End If
Next Picture

ReDim uzanti(11)
uzanti(1) = "jpg":        uzanti(2) = "JPG"
uzanti(3) = "bmp":        uzanti(4) = "BMP"
uzanti(5) = "gif":        uzanti(6) = "GİF"



For j = 1 To 6

Dosya = "Z:\ÜRÜN RESİMLERİ\" & Target.Value & "." & uzanti(Val(j))
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
ad = s1.Pictures.Insert(Dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 2
s1.Cells(Target.Row + 1, Target.Column).Select

Exit For
End If
Next


End If
End Sub

Halit Bey,

Aşağıdaki kodda resim dışındaki veriler sayfaya geliyor ama resim gelmiyor. Kodda nasıl bir değişiklik yapmak gerekiyor acaba?
Resmin "veri" isimli sayfanın, satır genişliği 200, sütun genişliği 55 olan I hücrelerine sırayla gelmesini istiyorum. Yardımcı olabilirseniz çok sevinirim.

Selam ve saygılarımla.

Kod:

rivate Sub CommandButton3_Click()

        If TextBox8.Text <> "" Then
            If ComboBox2.Text <> "" Then
                        Son_Dolu_Satir = Sheets("resim").Range("A65536").End(3).Row
                        If WorksheetFunction.CountIf(Sheets("resim").Range("B1:B" & Son_Dolu_Satir), TextBox8.Text) > 0 Then
MsgBox "Mükerrer kayıt.", vbCritical
GoTo 20
End If
                        Bos_Satir = Son_Dolu_Satir + 1
                        Sheets("resim").Range("A" & Bos_Satir).Value = _
                                             Application.WorksheetFunction.Max(Sheets("resim").Range("A:A")) + 1
                                             
                       
                        Sheets("resim").Range("A" & Bos_Satir).Value = ComboBox2.Text
                        Sheets("resim").Range("B" & Bos_Satir).Value = TextBox8.Text
                        Sheets("resim").Range("C" & Bos_Satir).Value = TextBox9.Text
                        Sheets("resim").Range("D" & Bos_Satir).Value = TextBox10.Text
                        Sheets("resim").Range("E" & Bos_Satir).Value = TextBox11.Text
                        Sheets("resim").Range("F" & Bos_Satir).Value = TextBox12.Text
                        Sheets("resim").Range("G" & Bos_Satir).Value = TextBox13.Text
                        Sheets("resim").Range("H" & Bos_Satir).Value = TextBox14.Text
                       [B] Sheets("resim").Range("I" & Bos_Satir).Value = Image1.Picture[/B]
                        Sheets("resim").Select
                        MsgBox "Soru havuza atıldı.", vbInformation, "Yeni bir soru ekleyin."
                        Workbooks("Örnek").Save
                        For i = 8 To 14
Controls("TextBox" & i).Value = ""
ComboBox2.Value = ""

Next i

                Else
                    GoTo 5
                End If
            Else
                    GoTo 5
                End If
    Exit Sub
5
    MsgBox "İstenen verileri eksiksiz girdiğinizden emin olduktan sonra tekrar deneyiniz.", vbExclamation, "Kontrol"
20:
Workbooks("Örnek").Save
End Sub

BedriA · 14 Haziran 2017

Örnek dosya ektedir.

İlgilenecek arkadaşlara şimdiden teşekkür ederim.

askm · 14 Haziran 2017

Kodları aşağıdaki şekilde revize edin. Resim boyutunu siz ayarlayabilirsiniz. Ya da hücre boyutunu sabitleyip örnek ekleyin bakalım.

Kod:

Public resimadresi, resim_adi As String

Private Sub CommandButton2_Click()
Dim fPath  As String
'Dim fdgPicker As FileDialog

fPath = ThisWorkbook.Path & "\Pics"

ChDrive fPath

Set fdgPicker = Application.FileDialog(msoFileDialogFilePicker)
With fdgPicker
.InitialView = msoFileDialogViewThumbnail
.Filters.Add "Graphics Files (*.bmp; *.gif; *.jpg; *.jpeg)", "*.bmp;*.gif;*.jpg;*.jpeg"
.FilterIndex = 1
If .Show = -1 Then
Image1.Picture = LoadPicture(.SelectedItems(1))
'resimadresi = fdgPicker.InitialFileName
resim_adi = fdgPicker.SelectedItems(1)
MsgBox resim_adi
Else
MsgBox "Seçili Resim Yok"
End If
End With
End Sub
Private Sub CommandButton1_Click()


        If TextBox1.Text <> "" Then
           
                        Son_Dolu_Satir = Sheets("resim").Range("A65536").End(3).Row
                        If WorksheetFunction.CountIf(Sheets("resim").Range("B1:B" & Son_Dolu_Satir), TextBox1.Text) > 0 Then
MsgBox "Bu resim adıyla bir resim atıldı", vbCritical
GoTo 20
End If
                        Bos_Satir = Son_Dolu_Satir + 1
                        Sheets("resim").Range("A" & Bos_Satir).Value = _
                                             Application.WorksheetFunction.Max(Sheets("resim").Range("A:A")) + 1
                                             
                       
                        
                        Sheets("resim").Range("A" & Bos_Satir).Value = TextBox1.Text
                        
                        Sheets("resim").Pictures.Insert(resim_adi).Select
                        Selection.Top = Range("B" & ActiveCell.Row + 2).Top: Selection.Left = Range("B" & ActiveCell.Row + 2).Left
                        Selection.ShapeRange.LockAspectRatio = msoFalse: Selection.ShapeRange.Height = 122: Selection.ShapeRange.Width = 120
                        ActiveCell.Select
                        
                        
                        
                        Sheets("resim").Select
                        MsgBox "Resim aktarıldı", vbInformation, "Yeni bir soru ekleyin."
                        
                        For i = 1 To 1
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 Sub

BedriA · 14 Haziran 2017

askm' Alıntı:

Kodları aşağıdaki şekilde revize edin. Resim boyutunu siz ayarlayabilirsiniz. Ya da hücre boyutunu sabitleyip örnek ekleyin bakalım.

Kod:

Public resimadresi, resim_adi As String

Private Sub CommandButton2_Click()
Dim fPath  As String
'Dim fdgPicker As FileDialog

fPath = ThisWorkbook.Path & "\Pics"

ChDrive fPath

Set fdgPicker = Application.FileDialog(msoFileDialogFilePicker)
With fdgPicker
.InitialView = msoFileDialogViewThumbnail
.Filters.Add "Graphics Files (*.bmp; *.gif; *.jpg; *.jpeg)", "*.bmp;*.gif;*.jpg;*.jpeg"
.FilterIndex = 1
If .Show = -1 Then
Image1.Picture = LoadPicture(.SelectedItems(1))
'resimadresi = fdgPicker.InitialFileName
resim_adi = fdgPicker.SelectedItems(1)
MsgBox resim_adi
Else
MsgBox "Seçili Resim Yok"
End If
End With
End Sub
Private Sub CommandButton1_Click()


        If TextBox1.Text <> "" Then
           
                        Son_Dolu_Satir = Sheets("resim").Range("A65536").End(3).Row
                        If WorksheetFunction.CountIf(Sheets("resim").Range("B1:B" & Son_Dolu_Satir), TextBox1.Text) > 0 Then
MsgBox "Bu resim adıyla bir resim atıldı", vbCritical
GoTo 20
End If
                        Bos_Satir = Son_Dolu_Satir + 1
                        Sheets("resim").Range("A" & Bos_Satir).Value = _
                                             Application.WorksheetFunction.Max(Sheets("resim").Range("A:A")) + 1
                                             
                       
                        
                        Sheets("resim").Range("A" & Bos_Satir).Value = TextBox1.Text
                        
                        Sheets("resim").Pictures.Insert(resim_adi).Select
                        Selection.Top = Range("B" & ActiveCell.Row + 2).Top: Selection.Left = Range("B" & ActiveCell.Row + 2).Left
                        Selection.ShapeRange.LockAspectRatio = msoFalse: Selection.ShapeRange.Height = 122: Selection.ShapeRange.Width = 120
                        ActiveCell.Select
                        
                        
                        
                        Sheets("resim").Select
                        MsgBox "Resim aktarıldı", vbInformation, "Yeni bir soru ekleyin."
                        
                        For i = 1 To 1
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 Sub

Aşağıdaki kodda hata verdi. Siz örnek dosyada denediniz mi?

Kod:

Sheets("resim").Pictures.Insert(resim_adi).Select

halit3 · 14 Haziran 2017

Userformdaki kodları sil bunu oraya kopyala

Kod:

'Option Explicit
Option Compare Text
Dim Kaynak As String
Dim deg8

#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



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 = 2 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 Function


Private Sub CommandButton1_Click()

Dim Resim As OLEObject
Dim Adres As Range

yer = ThisWorkbook.Path & "\denemmmm.jpg"

SavePicture Image1.Picture, yer

sat1 = 7
sat2 = 17
sut1 = "C"
sut2 = "P"

Set Adres = Range(Cells(sat1, sut1).Address, Cells(sat2, sut2).Address)

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
End If

Next Picture

ad = ActiveSheet.Pictures.Insert(yer).Name

ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width
Kill yer

End Sub

Private Sub CommandButton2_Click()
Dim fPath  As String
Dim fdgPicker As FileDialog

fPath = ThisWorkbook.Path & "\Pics"

ChDrive fPath

Set fdgPicker = Application.FileDialog(msoFileDialogFilePicker)
With fdgPicker
.InitialView = msoFileDialogViewThumbnail
.Filters.Add "Graphics Files (*.bmp; *.gif; *.jpg; *.jpeg)", "*.bmp;*.gif;*.jpg;*.jpeg"
.FilterIndex = 1
If .Show = -1 Then
Image1.Picture = LoadPicture(.SelectedItems(1))
Else
MsgBox "Seçili Resim Yok"
End If
End With
End Sub

halit3 · 14 Haziran 2017

Bu kodda farklı

Kod:

Dim resim_dosyasi


Private Sub CommandButton1_Click()

Dim Resim As OLEObject
Dim Adres As Range

yer = resim_dosyasi

sat1 = 7
sat2 = 17
sut1 = "C"
sut2 = "P"

Set Adres = Range(Cells(sat1, sut1).Address, Cells(sat2, sut2).Address)

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
End If

Next Picture

ad = ActiveSheet.Pictures.Insert(yer).Name

ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width

End Sub

Private Sub CommandButton2_Click()
Dim fPath  As String
Dim fdgPicker As FileDialog

fPath = ThisWorkbook.Path & "\Pics"

ChDrive fPath

Set fdgPicker = Application.FileDialog(msoFileDialogFilePicker)
With fdgPicker
.InitialView = msoFileDialogViewThumbnail
.Filters.Add "Graphics Files (*.bmp; *.gif; *.jpg; *.jpeg)", "*.bmp;*.gif;*.jpg;*.jpeg"
.FilterIndex = 1
If .Show = -1 Then
resim_dosyasi = .SelectedItems(1)
Image1.Picture = LoadPicture(.SelectedItems(1))


Else
MsgBox "Seçili Resim Yok"
End If
End With
End Sub

BedriA · 14 Haziran 2017

halit3' Alıntı:

Bu kodda farklı

Kod:

Dim resim_dosyasi


Private Sub CommandButton1_Click()

Dim Resim As OLEObject
Dim Adres As Range

yer = resim_dosyasi

sat1 = 7
sat2 = 17
sut1 = "C"
sut2 = "P"

Set Adres = Range(Cells(sat1, sut1).Address, Cells(sat2, sut2).Address)

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
End If

Next Picture

ad = ActiveSheet.Pictures.Insert(yer).Name

ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width

End Sub

Private Sub CommandButton2_Click()
Dim fPath  As String
Dim fdgPicker As FileDialog

fPath = ThisWorkbook.Path & "\Pics"

ChDrive fPath

Set fdgPicker = Application.FileDialog(msoFileDialogFilePicker)
With fdgPicker
.InitialView = msoFileDialogViewThumbnail
.Filters.Add "Graphics Files (*.bmp; *.gif; *.jpg; *.jpeg)", "*.bmp;*.gif;*.jpg;*.jpeg"
.FilterIndex = 1
If .Show = -1 Then
resim_dosyasi = .SelectedItems(1)
Image1.Picture = LoadPicture(.SelectedItems(1))


Else
MsgBox "Seçili Resim Yok"
End If
End With
End Sub

Halit Bey çok teşekkürler.
Ancak bu şekilde resmi sürekli aynı yere atıyor. Resim eklendikçe alt alt sıralansın. Ve daha sonra tekrar sayfadan userforma Listbox'tan seçilerek çağrılabilsin. Örnek dosyada Resim Adı butonu var. A sütununda resim adı, sonraki sütuna da resim gelsin istiyorum.

Selam ve saygılarımla.

halit3 · 14 Haziran 2017

CommandButton1_Click aşağıdakiyle değiştir.

kod:

Kod:

Private Sub CommandButton3_Click()

Dim Adres As Range
Dim sat1, sat2
yer = resim_dosyasi

sat1 = 7
sat2 = 17
sut1 = "C"
sut2 = "P"

Dim s1
Set s1 = Sheets(ActiveSheet.Name)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
sat1 = Picture.BottomRightCell.Row + 1
sat2 = sat1 + 10
End If
Next Picture

Set Adres = Range(Cells(sat1, sut1).Address, Cells(sat2, sut2).Address)

ad = ActiveSheet.Pictures.Insert(yer).Name
ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width

MsgBox "İŞLEM TAMAM"""

End Sub

BedriA · 14 Haziran 2017

Çok ama çok sağolun Halit Bey.

Elinize, zihninize sağlık.

halit3 · 14 Haziran 2017

Teşekkürler iyi çalışmalar

halit3 · 15 Haziran 2017

10 nolu mesajdaki koda aşağıdaki kırmızı yeri ekledim.

Kod:

Private Sub CommandButton3_Click()

Dim Adres As Range
Dim sat1, sat2
yer = resim_dosyasi

sat1 = 7
sat2 = 17
sut1 = "C"
sut2 = "P"
[COLOR="Red"]Say = 1[/COLOR]
Dim s1
Set s1 = Sheets(ActiveSheet.Name)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
sat1 = Picture.BottomRightCell.Row + 1
sat2 = sat1 + 10
[COLOR="red"]Say = Say + 1[/COLOR]
End If
Next Picture

Set Adres = Range(Cells(sat1, sut1).Address, Cells(sat2, sut2).Address)

ad = ActiveSheet.Pictures.Insert(yer).Name
ActiveSheet.Shapes(ad).OLEFormat.Object.Select
ActiveSheet.Shapes(ad).OLEFormat.Object.Top = Adres.Top
ActiveSheet.Shapes(ad).OLEFormat.Object.Left = Adres.Left
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height
ActiveSheet.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width
[COLOR="Red"]ActiveSheet.Shapes(ad).OLEFormat.Object.Name = Say[/COLOR]
[COLOR="Red"]ActiveSheet.Shapes(ad).OLEFormat.Object.OnAction = "resimsec"[/COLOR]
MsgBox "İŞLEM TAMAM"""

End Sub

bu kodu bir modülün içine koyun

Kod:

Sub resimsec()
Cells(1, 1).Value = Application.Caller

yer = ActiveWindow.RangeSelection.Address

Set Sh = Sheets(ActiveSheet.Name)

ad = Cells(1, 1).Value

Dim Adres As Range
Dim Picture As Object
For Each Picture In Sh.Shapes 'ActiveSheet.Shapes

Set Adres = Range(Picture.TopLeftCell.Address, Picture.BottomRightCell.Address)
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then

If Trim(Picture.Name) = Trim(ad) Then
'MsgBox Picture.Name & Chr(10) & ad
Sh.Shapes(Picture.Name).Select
Sh.Shapes(Picture.Name).CopyPicture

Dim myClp As Object
Set myClp = CreateObject("clipbrd.clipboard")
myClp.Clear
myClp.setData Sh.Shapes(Picture.Name).CopyPicture, 2 '‘The 2 is for bitmaps
UserForm1.Image1.Picture = myClp.GetData 'PastePicture
myClp.Clear

Exit For
End If
End If

Next Picture

Range(yer).Select

End Sub

bundan sonra resimlerin üstüne geldiğinizde tıklayınca userformun içindeki image nesnesine ekleme yapıyor.

ayrıca userforma da bu kodu ekleyin

Kod:

Private Sub CommandButton4_Click()
yer = ActiveWindow.RangeSelection.Address

Set Sh = Sheets(ActiveSheet.Name)
'Image1.Picture = LoadPicture(ListBox1.List(ListBox1.ListIndex, 1))
ad = Cells(1, 1).Value

Dim Adres As Range
Dim Picture As Object
For Each Picture In Sh.Shapes 'ActiveSheet.Shapes

'sat3 = Picture.BottomRightCell.Row
'sut3 = Picture.BottomRightCell.Column
Set Adres = Range(Picture.TopLeftCell.Address, Picture.BottomRightCell.Address)
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then


If Trim(Picture.Name) = Trim(ad) Then
MsgBox Picture.Name & Chr(10) & ad
Sh.Shapes(Picture.Name).Select
Sh.Shapes(Picture.Name).CopyPicture

Dim myClp As Object
Set myClp = CreateObject("clipbrd.clipboard")
myClp.Clear
myClp.setData Sh.Shapes(Picture.Name).CopyPicture, 2 '‘The 2 is for bitmaps
UserForm1.Image1.Picture = myClp.GetData 'PastePicture
myClp.Clear

Exit For
End If
End If

Next Picture

Range(yer).Select
End Sub

kodların çalışması için aşağıdaki dll dosyasını reg yapmanız gerekiyor.
ayrıca userformun show modal durumunu false yapın

Makro ile resim ekleme

07ahm07

halit3

Uzman

BedriA

BedriA

Ekli dosyalar

askm

Destek Ekibi

BedriA

halit3

Uzman

halit3

Uzman

BedriA

halit3

Uzman

BedriA

halit3

Uzman

halit3

Uzman

Ekli dosyalar