Klasörden Resim Getirme

Bagcivan

Bagcivan

Altın Üye
Katılım
7 Ağustos 2008
Mesajlar
193
Excel Vers. ve Dili
office 2019 türkçe
Altın Üyelik Bitiş Tarihi
11-10-2027
Selamlar,
Hücredeki değere göre aynı dizindeki klasörden resimleri getirmeye çalışıyorum.
Kodlar çalışıyor ancak bir for döngüsünün içinde sütunlarda gezdiremedim.
Örnek dosya ek'tedir

İndir Örnek

Dosyayı indir Örnek
dosya.co

Herkese keyifli günler dilerim
 

Ekli dosyalar

Bagcivan

Bagcivan

Altın Üye
Katılım
7 Ağustos 2008
Mesajlar
193
Excel Vers. ve Dili
office 2019 türkçe
Altın Üyelik Bitiş Tarihi
11-10-2027
muygun' Alıntı:
Merhaba;
Eki deneyin.
İyi çalışmalar.
Genişletmek için tıkla ...
Sayın @muygun
Aşağıdaki kod ile ile "hücrelerle taşı ve boyutlandır" işlemini yapabildim ancak ilk eklendiğinde tam hücre boyutuna göre yerleştiremedim.

.Placement = xlMoveAndSize

Kod: 
Sub resim_getir()
Application.ScreenUpdating = False
On Error Resume Next

Dim resim As Object, i As Long, yol As String, dosya As String
Sheets("Sheet1").Select
yol = ThisWorkbook.Path & "\Resim\"
sonn = Cells(Rows.Count, 2).End(xlUp).Row
Set Alan = Range("a2:a" & sonn)
For Each resimm In ActiveSheet.Pictures
If Not Intersect(resimm.TopLeftCell, Alan) Is Nothing Then
resimm.Delete
End If
Next
Set Alan = Nothing

For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
If Dir(yol & "\" & Cells(i, "d").Value & ".jpg") <> "" Then dosya = "\" & Cells(i, "d").Value & ".jpg"
If Dir(yol & "\" & Cells(i, "d").Value & ".jpg") = "" Then dosya = "\" & "yok" & ".jpg"

If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
Set P = ActiveSheet.Pictures.Insert(yol & dosya)
With Cells(i, "a")
t = .Top
l = .Left
w = .Offset(50, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 50).Top - .Top
End With
With P
.Top = t + 1
.Left = l + 1
.Width = w - 1
.Height = h - 1
.Placement = xlMoveAndSize
End With
Set P = Nothing
Next i
Application.ScreenUpdating = False
End Sub
 
muygun

muygun

Özel Üye
Katılım
6 Temmuz 2004
Mesajlar
9,182
Excel Vers. ve Dili
Excel-2003 Türkçe
Eklediğim 2 nolu mesaj eki dosyada kodlar gelen resmi hücre boyutlarına göre düzenler.
A sütununda sütun genişliği yada satır yüksekliğini değiştirerek deneyin.
Ekteki gibi...
 

Ekli dosyalar

E

excelokyanus500

Katılım
20 Şubat 2012
Mesajlar
242
Excel Vers. ve Dili
office2007 Türkçe
Excele alternatif olsun..
Daha önce bir ihtiyaca binaen yapmış olduğum bir programı burada eklemek istiyorum.
Program başlangıçta arama yapmak istediğiniz dosyanın uzantısını size soruyor(jpg,jpeg,docx vs...birini seçin ve yazın). Onu belirttikten sonra arama yapılacak klasörü seçmenizi isteyecek.
Bu programla ,istediğiniz türde dosya araması yapabilirsiniz. Ayrıca resimler için resmi sağ tarafta gösteriyor. Açabilir, silebilir, kopyalayabilirsiniz.
Kodları bir txt dosyasına kaydettikten sonra uzantısını vbs olarak değiştirin.
Kod: 
If Not WScript.Arguments.Named.Exists("elevate") Then
  CreateObject("Shell.Application").ShellExecute WScript.FullName _
    , """" & WScript.ScriptFullName & """ /elevate", "", "runas", 1
  WScript.Quit
End If

On error resume next
sInput = InputBox("Dosya uzantisi nedir ?")
uzanti = sInput
Dim objFSO

 folderPath = BrowseForFolder()

If IsEmpty(folderPath) Then
  MsgBox "İşlem iptal edildi."
wscript.quit
Else
 '' MsgBox folderPath
End If
Set objShell = Wscript.CreateObject("Wscript.Shell")
strPath = objShell.SpecialFolders("Desktop") & "\"
FolderName="Dosyalar"            'Masa üstünde oluşturulacak klasörün adı
DestDir = strPath & FolderName

Msgbox   "Dosyaniz burada oalacak ---" & DestDir &"------"

Set oFso = CreateObject("Scripting.FileSystemObject")
If NOT oFso.FolderExists(DestDir) Then
 ' Create New Folder
 set NewFolder=oFso.CreateFolder(FolderName)
End If




Set FSO = CreateObject("Scripting.FileSystemObject")
Say = 1

Set objFile = FSO.CreateTextFile(DestDir &"\" & "dosyalar.hta",2,True)
 Call sag
wscript.sleep 2000





Set objDir = FSO.GetFolder(folderPath)
getInfo(objDir)











Sub getInfo(pCurrentDir)
 
For Each aItem In pCurrentDir.Files

 '' objFile.WriteLine("<td width=""33%"">")
   'wscript.Echo aItem.Name
    If LCase(FSO.GetExtensionName(aItem.Name)) = uzanti Then

   objFile.WriteLine("<tr>" & "<td width=""33%"">" & Say & "-" & " O. Tarihi :  "& aItem.DateCreated  & "  Dosyanin  Yeri: " & aItem.ParentFolder & "</td>" & "</tr>")

    '''''''''''''''''''Dosya yolu'

              objFile.WriteLine("<td width=""33%"">")
               'oobjFile.WriteLine( objfile.Path)
                'objTS.WriteLine(objFolder.Path)
               objFile.WriteLine( "<a href="& qq("file:///" &  pCurrentDir.Path &"\"& aItem.Name ) &">" & aItem.Name & "</a><font color=red></font><B> <br>  <hr>")
               objFile.WriteLine("<button onclick=kopyala" & Say & ">Kopyala</button>")
               objFile.WriteLine("<button onclick=ac" & Say & ">Dosya Yolu</button>")
               objFile.WriteLine("<button onclick=DeleteAFile" & Say & ">Dosyi Sil</button>")
              objFile.WriteLine("  </td>")

'    %%%    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


                objFile.WriteLine("<SCRIPT LANGUAGE=""VBScript"">")
                  'objTS.WriteLine("kopyala" & Say)
                objFile.WriteLine("Sub kopyala" & Say)
               objFile.WriteLine("Dim fso")
                   objFile.WriteLine("Set fso = CreateObject(""Scripting.FileSystemObject"")")
               objFile.WriteLine(" fso.CopyFile " & qq(aItem.Path ) & "," & qq( DestDir & "\") )
                  objFile.WriteLine("End Sub")
'''''''''^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
                 objFile.WriteLine("Sub ac" & Say )
                   objFile.WriteLine("sPath =" & qq(pCurrentDir.Path))
                  'objFile.WriteLine("sPath =" & qq(aItem.Path))
                  objFile.WriteLine("Set oShell = CreateObject(""WScript.Shell"")")
                  objFile.WriteLine("oShell.Run ""explorer /n,"" & sPath, 1, False")
                  objFile.WriteLine("End Sub")

                    objFile.WriteLine("Sub DeleteAFile" & Say)


                   objFile.WriteLine(" intAnswer =  Msgbox(""Bu dosyayı gerçekten silmek istiyor musunuz?"", vbYesNo, ""Siliniyor!!!!!!!"")")
                    objFile.WriteLine("If intAnswer = vbYes Then")
                  objFile.WriteLine("Msgbox ""Dosyanızı siliyorum""")

                  objFile.WriteLine("Call vFn_File_Recycle (" & qq(aItem.Path) & ")")


                objFile.WriteLine("Else")
                 objFile.WriteLine(" Msgbox ""Dosya silme işlemi iptal edildi""")
                objFile.WriteLine("  Exit sub")
                    objFile.WriteLine("End If")
                  objFile.WriteLine("End Sub")







               objFile.WriteLine("</SCRIPT>")
               '''''''''''''''''''Dosya Klasörü'

              objFile.WriteLine("<td width=""33%"">")
               'objTS.WriteLine( objfile.ShortPath)
              objFile.WriteLine(  "<img src="& qq( aItem.Path)  &  "width=250 height=180" & ">")

               'objTS.WriteLine(pCurrentDir.Path)
              objFile.WriteLine("  </td>")


         objFile.WriteLine("</tr>")


         '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%




Say = Say +1
 If Say = 200 then
 Bul = 1
objFile.Close()

'TO CLEAR
'ClipBoard("")

'TO SET
ClipBoard(Bul)

Call diger()
End If


 If Say = 400 then
Bul = 2

objFile.Close()

'TO CLEAR
'ClipBoard("")

'TO SET
ClipBoard(Bul)

Call diger()
End If


 If Say = 600 then
Bul = 3

objFile.Close()

'TO CLEAR
'ClipBoard("")

'TO SET
ClipBoard(Bul)

Call diger()
End If


If Say = 800 then
Bul = 4

objFile.Close()

'TO CLEAR
'ClipBoard("")

'TO SET
ClipBoard(Bul)

Call diger()
End If

If Say = 1000 then
Bul = 5

objFile.Close()

'TO CLEAR
'ClipBoard("")

'TO SET
ClipBoard(Bul)

Call diger()
End If

If Say = 1200 then
Bul = 6

objFile.Close()

'TO CLEAR
'ClipBoard("")

'TO SET
ClipBoard(Bul)

Call diger()
End If

If Say = 1400 then
Bul = 7

objFile.Close()

'TO CLEAR
'ClipBoard("")

'TO SET
ClipBoard(Bul)

Call diger()
End If

If Say = 1600 then
Bul = 8

objFile.Close()

'TO CLEAR
'ClipBoard("")

'TO SET
ClipBoard(Bul)

Call diger()
End If

If Say = 1800 then
Bul = 9

objFile.Close()

'TO CLEAR
'ClipBoard("")

'TO SET
ClipBoard(Bul)

Call diger()
End If

If Say = 2000 then
Bul = 10

objFile.Close()

'TO CLEAR
'ClipBoard("")

'TO SET
ClipBoard(Bul)

Call diger()
End If










End If

Next

For Each aItem In pCurrentDir.SubFolders
   'wscript.Echo aItem.Name & " passing recursively"
   getInfo(aItem)

Next





End Sub
objFile.Close()
Msgbox Say & " adet dosya bulundu."

Sub diger()

Set objShell = Wscript.CreateObject("Wscript.Shell")
strPath = objShell.SpecialFolders("Desktop") & "\"
FolderName="Dosyalar"
DestDir = strPath & FolderName

Result = ClipBoard(Null)
wscript.Sleep 3000
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFile DestDir &"\" & "dosyalar.hta", DestDir &"\" & "dosyalar" & Result & ".hta"
wscript.Sleep 3000
Set objFile = FSO.CreateTextFile(DestDir &"\" & "dosyalar.hta",8,True)
Call  sag
End Sub


Function ClipBoard(input)
'@description: A quick way to set and get your clipboard.
'@author: Jeremy England (SimplyCoded)
  If IsNull(input) Then
    ClipBoard = CreateObject("HTMLFile").parentWindow.clipboardData.getData("Text")
    If IsNull(ClipBoard) Then ClipBoard = ""
  Else
    CreateObject("WScript.Shell").Run _
      "mshta.exe javascript:eval(""document.parentWindow.clipboardData.setData('text','" _
      & Replace(Replace(Replace(input, "'", "\\u0027"), """","\\u0022"),Chr(13),"\\r\\n") & "');window.close()"")", _
      0,True
  End If
End Function

Function BrowseForFolder()
'@description: Browse for folder dialog.
'@author: Jeremy England (SimplyCoded)
  Dim oFolder
  Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0,"Klasor Seciniz",0,0)
  If (oFolder Is Nothing) Then
    BrowseForFolder = Empty
  Else
    BrowseForFolder = oFolder.Self.Path
  End If
End Function         

  Sub sag()

  objFile.WriteLine("<!doctype html>")
 objFile.WriteLine("<html>")
 objFile.WriteLine("<head>")

 objFile.WriteLine("<meta http-equiv=""Content-Type"" content=""text/html; charset=iso-8859-9"" />")

   objFile.WriteLine("</head>")

 objFile.WriteLine("<body>")
 objFile.WriteLine("</body>")
 objFile.WriteLine("</html>")


objFile.WriteLine("<hta:application icon=""magnify.exe"" />")
objFile.WriteLine("<!DOCTYPE html>")
objFile.WriteLine("<html>")
objFile.WriteLine("<body>")
objFile.WriteLine(" <table border>")

'''''''''''''''''''''''''''''''


 ''''''''''''''Kopyala


objFile.WriteLine("<SCRIPT LANGUAGE=""VBScript"">")
 objFile.WriteLine("Function CopyFiles(FiletoCopy,DestinationFolder)")
    objFile.WriteLine("Dim fso")
                 objFile.WriteLine("Dim Filepath,WarFileLocation")
                 objFile.WriteLine("Set fso = CreateObject(""Scripting.FileSystemObject"")")
                 objFile.WriteLine("If  Right(DestinationFolder,1) <>""\""Then")
                     objFile.WriteLine("DestinationFolder=DestinationFolder&""\""" )
                 objFile.WriteLine("End If")
     objFile.WriteLine("fso.CopyFile FiletoCopy,DestinationFolder,True ")
                 objFile.WriteLine("FiletoCopy = Split(FiletoCopy,""\"")" )

 objFile.WriteLine("End Function")





 objFile.WriteLine("</SCRIPT>")



 objFile.WriteLine("<thead>")
 objFile.WriteLine("<tr>" & "<td width=""33%"">")
 'objFile.WriteLine("<th scope=""col"" >Dosya ismi</th>")
' objFile.WriteLine("<th scope=""col"">Dosya Kopyalama </th>")
  objFile.WriteLine("<th scope=""col"">Bulunan Dosyalar</th>")
 objFile.WriteLine("</tr>" & "</td>" )
 objFile.WriteLine("</thead>")




objFile.WriteLine("</table>")
 objFile.WriteLine("</body>")
objFile.WriteLine("</html>")



 objFile.WriteLine("<SCRIPT>")

''''''''''''''''''''''Silme

                  objFile.WriteLine("Function vFn_File_Recycle (vFilePath)")
                 objFile.WriteLine("'Sends the file 'vFilePath' to the recycle bin without any delete confirmation. Returns 0 for no")
                  objFile.WriteLine("'error, else returns the Err.Number.")
                    objFile.WriteLine("'---------------------------------------------------------------------------------------------------")

                   objFile.WriteLine("  On Error Resume Next")
                    objFile.WriteLine("  'VERIFY FILE EXISTS")
                    objFile.WriteLine("    Set f_ObjFSO = CreateObject(""Scripting.FileSystemObject"")")
                    objFile.WriteLine("      If Not f_ObjFSO.FileExists(vFilePath) Then vExists = 0 Else vExists = 1")
                      objFile.WriteLine("  'CONTINUE IF FILE EXISTS")
                           objFile.WriteLine("    If vExists = 1 Then")
                        objFile.WriteLine("    'BACKUP CURRENT USER RECYCLE BIN SETTINGS")
                        objFile.WriteLine("      Set f_ObjReg=GetObject(""winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv"") ")
                    objFile.WriteLine("        f_ObjReg.GetBinaryValue &H80000001, ""Software\Microsoft\Windows\CurrentVersion\Explorer"", ""ShellState"", vStateArr")
                     objFile.WriteLine("        vBackupState = vStateArr")
                      objFile.WriteLine("        vStateArr(4) = 39")
                     objFile.WriteLine("        f_ObjReg.SetBinaryValue &H80000001, ""Software\Microsoft\Windows\CurrentVersion\Explorer"", ""ShellState"", vStateArr")
                       objFile.WriteLine("    'INVOTE SHELL APPLICATION DELETE COMMAND")
                       objFile.WriteLine("      Set f_ObjShell = CreateObject(""Shell.Application"").NameSpace(0).ParseName(vFilePath).InvokeVerb(""delete"")")
                       objFile.WriteLine("    'RESTORE USER RECYCLE BIN SETTINGS")
                        objFile.WriteLine("        f_ObjReg.SetBinaryValue &H80000001, ""Software\Microsoft\Windows\CurrentVersion\Explorer"", ""ShellState"", vBackupState")
                                objFile.WriteLine("      End If")
                            objFile.WriteLine("  'CHECK FOR ERRORS AND CLOSE THE FUNCTION")
                                 objFile.WriteLine("    If Err.Number <> 0 Then vFn_File_Recycle = 0 Else vFn_File_Recycle = Err.Number")
                              objFile.WriteLine("    On Error Goto 0")
                              objFile.WriteLine("   End Function")


  objFile.WriteLine("</SCRIPT>")

    '%%%    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  objFile.WriteLine("<SCRIPT LANGUAGE=""javascript"">")

  objFile.WriteLine("function Window_onLoad(){  // resize to quarter of screen area, centered")
     objFile.WriteLine("window.resizeTo(screen.availWidth/2,screen.availHeight/2);")
     objFile.WriteLine("window.moveTo(screen.availWidth/3,screen.availHeight/3);")
  objFile.WriteLine("}")

  objFile.WriteLine("window.onload=Window_onLoad;")

  objFile.WriteLine("</SCRIPT>")

    '%%%    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%



   objFile.WriteLine("<table border>")
 End Sub


Function qq(strIn)
    qq = Chr(34) & strIn & Chr(34)
End Function



Function BrowseForFolder()
'@description: Browse for folder dialog.
'@author: Jeremy England (SimplyCoded)
  Dim oFolder
  Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0,"Klasor Seciniz",0,0)
  If (oFolder Is Nothing) Then
    BrowseForFolder = Empty
  Else
    BrowseForFolder = oFolder.Self.Path
  End If
End Function

Function StripAccent(thestring)
Dim A
Dim B
Dim i
Const AccChars = "ÅŸ"
Const RegChars = "ş"
For i = 1 To Len(AccChars)
A = Mid(AccChars, i, 1)
B = Mid(RegChars, i, 1)
thestring = Replace(thestring, A, B)
Next
StripAccent = thestring
End Function
 
M

mars2

Altın Üye
Katılım
2 Eylül 2004
Mesajlar
564
Excel Vers. ve Dili
2016 - Türkçe
2019 - Türkçe
Altın Üyelik Bitiş Tarihi
26-03-2026
İyi Akşamlar;
Konu hakkında farklı bir sorunumda yardımlarınızla,
aynı klasörün içinde olması halinde
yol = ThisWorkbook.Path & "\Resim\"
ancak, farklı bir klasörde olması halinde kodda ne gibi değişiklik yapabiliriz.
yol = ThisWorkbook.Path & "\\D:Resimler\Resim\"
 
U

usubaykan

Destek Ekibi
Destek Ekibi
Katılım
16 Mayıs 2008
Mesajlar
561
Excel Vers. ve Dili
Ev : Office Excel 2003
İş : Office Excel 2003
mars2' Alıntı:
İyi Akşamlar;
Konu hakkında farklı bir sorunumda yardımlarınızla,
aynı klasörün içinde olması halinde
yol = ThisWorkbook.Path & "\Resim\"
ancak, farklı bir klasörde olması halinde kodda ne gibi değişiklik yapabiliriz.
yol = ThisWorkbook.Path & "\\D:Resimler\Resim\"
Genişletmek için tıkla ...
Yerine
"C:\ &dosya adınız& "
şeklinde deneyin
 
Bagcivan

Bagcivan

Altın Üye
Katılım
7 Ağustos 2008
Mesajlar
193
Excel Vers. ve Dili
office 2019 türkçe
Altın Üyelik Bitiş Tarihi
11-10-2027
muygun' Alıntı:
Eklediğim 2 nolu mesaj eki dosyada kodlar gelen resmi hücre boyutlarına göre düzenler.
A sütununda sütun genişliği yada satır yüksekliğini değiştirerek deneyin.
Ekteki gibi...
Genişletmek için tıkla ...
Resim eklendikten sonra satır ve sütun boyutlarını değiştirdiğimde de boyutun değişmesinden bahsediyordum.

Teşekkür ederim
 
Y

yusuf1284

Altın Üye
Katılım
17 Ocak 2015
Mesajlar
225
Excel Vers. ve Dili
Office Pro 2016 TR
Altın Üyelik Bitiş Tarihi
09-02-2028
Hocam kodlara hücre doluysa satır yüksekliği ve sütun genişliği ayarlamasını ekleyebilir miyiz?
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst