automatic image fetch Free Excel Macros (VBA) | Excel Programs

Copy Macro

'For online Excel courses click: https://www.excelsizeyeter.com/excelwithkenan.com/udemy_giris.php 
 
Önce gösterilecek resimlerin isimleri  bilgisayardan (Resimlerim klasörü)seçilerek sayfaya kaydediliyor.
Daha sonra bu resimlerden gösterilmek istenen seçiliyor.
Gerekli malzeme:
1 adet İmage1
1 adet CmdButon
1 adet cmbobox
1 adet Label1
'BU KOD EN BAŞA YAZILACAK
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
'BU KOD SAYFADAKİ ADRESTE BULUNAN RESİMLERİ GÖSTERİR
Private Sub ComboBox1_Change()
Image1.PictureSizeMode = fmPictureSizeModeZoom
If ComboBox1.Value = "" Then
MsgBox "Resim Yok", vbCritical
Unload UserForm1
UserForm1.Show
Exit Sub
End If
Label1.Caption = Cells(ComboBox1.ListIndex + 1, 1).Value 'seçim kutusundaki isim etikete yazılıyor
Image1.Picture = LoadPicture(Label1.Caption) 'Etikette adresi gösterilen resim yükleniyor
End Sub
'BU KOD İSTENİLEN RESİMLERİ SAYFAYA KAYIT EDER
Private Sub CommandButton1_Click()
Dim son As Integer
Dim MyPic As Variant
On Error Resume Next
MyPic:
MyPic = Application.GetOpenFilename("JPEG,*.jpg,GIF,*.gif,Bitmap, *.bmp")
If MyPic  False Then
resim.PictureSizeMode = fmPictureSizeModeZoom
resim.Picture = LoadPicture(MyPic)
son = WorksheetFunction.CountA(Sheets("resimdata").Range("A:A")) + 1 'Resim adlarını sayfada depo ediyor.
Sheets("resimdata").Cells(son, 1) = MyPic
cevap = MsgBox(" " & MyPic & " kayıt edildi.Yeni resim eklemek istiyor musunuz?", vbExclamation + vbYesNo, "RESİM KAYIT")
If cevap = vbYes Then
GoTo MyPic
End If
End If
End Sub
'BU KOD USERFORMA YAZILACAK
Private Sub UserForm_Initialize()
ComboBox1.RowSource = "resimdata!A:A"
End Sub
KOMPLE UYGULAMALI ÖRNEK
'BU KOD EN BAŞA YAZILACAK
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
'BU KOD COMBOBOX1 İÇİN
Private Sub ComboBox1_Change()
Image1.PictureSizeMode = fmPictureSizeModeZoom
If ComboBox1.Value = "" Then
MsgBox "Resim Yok", vbCritical
Exit Sub
End If
Label1.Caption = Cells(ComboBox1.ListIndex + 1, 1).Value 'seçim kutusundaki isim etikete yazılıyor
Image1.Picture = LoadPicture(Label1.Caption) 'Etikette adresi gösterilen resim yükleniyor
End Sub
'BU KOD VERİLEN ADRESTEN RESİMİ SAYFAYA EKLER
Private Sub CommandButton1_Click()
   cevap = MsgBox("BU İŞLEMİ YANLIZCA YETKİLİ KİŞİ YAPABİLİR ? YETKİNİZ YOKSA LÜTFEN VAZGEÇİN ! ", vbYesNo + vbQuestion + vbDefaultcmdsil + vbApplicationModal, "FORMA RESİM EKLER")
     If cevap = vbNo Then
   End
End If
Dim son As Integer
Dim MyPic As Variant
On Error Resume Next
MyPic:
MyPic = Application.GetOpenFilename("JPEG,*.jpg,GIF,*.gif,Bitmap, *.bmp")
If MyPic  False Then
resim.PictureSizeMode = fmPictureSizeModeZoom
resim.Picture = LoadPicture(MyPic)
son = WorksheetFunction.CountA(Sheets("resimdata").Range("A:A")) + 1 'Resim adlarını sayfada depo ediyor.
Sheets("resimdata").Cells(son, 1) = MyPic
cevap = MsgBox(" " & MyPic & " kayıt edildi.Yeni resim eklemek istiyor musunuz?", vbExclamation + vbYesNo, "RESİM KAYIT")
If cevap = vbYes Then
GoTo MyPic
End If
End If
End Sub
'BU KOD TEXTBOX1'DE VERİ ARATMAK İÇİN
Private Sub CommandButton2_Click()
On Error Resume Next
    Dim bak As Range
    For Each bak In Range("B1:B" & WorksheetFunction.CountA(Range("B1:B65000")))
        If StrConv(bak.Value, vbUpperCase) = StrConv(TextBox1.Value, vbUpperCase) Then
            bak.Select
            ComboBox1.Value = ActiveCell.Offset(0, -1).Value
            ComboBox2.Value = ActiveCell.Offset(0, 1).Value
            TextBox3.Value = ActiveCell.Offset(0, 2).Value
            TextBox4.Value = ActiveCell.Offset(0, 3).Value
            TextBox5.Value = ActiveCell.Offset(0, 4).Value
            TextBox6.Value = ActiveCell.Offset(0, 5).Value
            TextBox7.Value = ActiveCell.Offset(0, 6).Value
            TextBox8.Value = ActiveCell.Offset(0, 7).Value
            Exit Sub
        End If
    Next bak
    MsgBox "Aradığınız isimde bir kayıt bulunamadı"
End Sub
'BU KOD EKRANI TEMİZLER
Private Sub CommandButton3_Click()
Unload UserForm1
UserForm1.Show
End Sub
'BU KOD VERİLERİNİZDE YAPILAN DEĞİŞİKLİKLERİ KAYIT EDER
Private Sub CommandButton4_Click()
Dim bak As Range
    For Each bak In Range("b1:b" & WorksheetFunction.CountA(Range("b1:b65000")))
        If StrConv(bak.Value, vbUpperCase) = StrConv(TextBox1.Value, vbUpperCase) Then
            bak.Select
    ActiveCell.Value = TextBox1.Value
    ActiveCell.Offset(0, 1).Value = ComboBox2.Value
    ActiveCell.Offset(0, 2).Value = TextBox3.Value
    ActiveCell.Offset(0, 3).Value = TextBox4.Value
    ActiveCell.Offset(0, 4).Value = TextBox5.Value
    ActiveCell.Offset(0, 5).Value = TextBox6.Value
    ActiveCell.Offset(0, 6).Value = TextBox7.Value
    ActiveCell.Offset(0, 7).Value = TextBox8.Value
     Workbooks("KADRO_.XLS").Save
    MsgBox "Verileriniz Başarıyla Değiştirildi", , "KAYIT"
    TextBox1.Value = WorksheetFunction.Count(Range("A1:A65000")) + 1
      Unload UserForm1
      UserForm1.Show
         Exit Sub
        End If
   Next bak
End Sub
'BU KOD COMBOBOX2'DE VERİ ARATMAK İÇİN
Private Sub CommandButton5_Click()
On Error Resume Next
Dim bak As Range
    For Each bak In Range("C1:C" & WorksheetFunction.CountA(Range("C1:C65000")))
        If StrConv(bak.Value, vbUpperCase) = StrConv(ComboBox2.Value, vbUpperCase) Then
            bak.Select
            ComboBox1.Value = ActiveCell.Offset(0, -2).Value
            TextBox1.Value = ActiveCell.Offset(0, -1).Value
            TextBox3.Value = ActiveCell.Offset(0, 1).Value
            TextBox4.Value = ActiveCell.Offset(0, 2).Value
            TextBox5.Value = ActiveCell.Offset(0, 3).Value
            TextBox6.Value = ActiveCell.Offset(0, 4).Value
            TextBox7.Value = ActiveCell.Offset(0, 5).Value
            TextBox8.Value = ActiveCell.Offset(0, 6).Value
            Exit Sub
        End If
    Next bak
    MsgBox "Aradığınız isimde bir kayıt bulunamadı"
End Sub
'BU KOD USERFORM İÇİN
Private Sub UserForm_Initialize()
ComboBox1.RowSource = "resimdata!A:A"
    Dim say As Integer
    Sheets("resimdata").Select
    If Range("c2") = "" Then
        say = WorksheetFunction.CountA(Range("B1:B65000"))
        ComboBox1.RowSource = "resimdata!c2:c" & say + 1
    Else
        say = WorksheetFunction.CountA(Range("c1:c65000"))
        ComboBox2.RowSource = "resimdata!c2:c" & say
    End If
    ComboBox1.SetFocus
End Sub

No	Macro Name
1	automatic image fetch
2	Convert Range as Image: Paste the selected range as an image. Just select the range, and after running this code, it automatically adds an image for that range.
3	excel operators hk
4	Width in column of data up to cell (automatic)
5	flashing
6	Data between cells a1: af12 flashes
7	Data between cells a1: af12 flashes
8	Automatically filter excel sheet via userform
9	Automatically insert other data between sequential data in excel
10	automatic filtering on active sheet / page
11	sheet / page protection automatic filter open
12	When 1 is entered in the cell on your sheet / page, the sentence corresponding to one is automatically written.
13	automatic custom footer and header information on sheet / pages
14	sheet / page address and set column width
15	copies active sheet / page email
16	perfectly deletes the menu to the right mouse and adds print print preview sheet / page structure
17	excellent menu insert file menu print print preview sheet / page structure remains
18	watermark printing (faded font on sheet / page background)
19	eg if column 4 is executed, macro will run automatically
20	automatic uppercase letter 3 in textbox (for Turkish character problem)

Excel Free Macros (VBA)

Automatic İmage Fetch

Online Excel Courses

Services

How can we help you?

Subscribe to our Youtube Channel?

Keywords