forma otomatik resim getirme Hazır Excel Makroları (VBA) | Excel Programları

Makroyu Kopyala

'Excel Makro (VBA) online eğitimleri için: https://www.excelsizeyeter.com/excelsizeyeter.com/udemy_giris.php adresine tıklayınız. Bir eğitim alana bir eğitim bedavadır. İkinci eğitim olarak Excel, Excel pratik çözümler, finans eğitimleri vb. alabilirsiniz. 
 
Ö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	Makro Adı
1	forma otomatik resim getirme
2	sayfa ekle a1 hücresine otomatik olarak sayfanin adinin yazilmasi
3	"Otomatik Biçimlendir" Dialog Penceresi
4	"Grafik Otomatik formatı ekle" Dialog Penceresi
5	açıklamaya resim eklemek
6	hücrelerin açıklamasını otomatik daralt, rengini değiştir
7	dosya açıldığında tanimlama bilgisi
8	dosya açıldığında tanımlama bilgisi
9	ayı otomatik tanıyan kodlar
10	hücredeki otomatik tarih formati
11	TEXTBOX'A GİRİLEN RAKAMLARI ÜÇ HANEDE BİR NOKTA İLE OTOMATİK AYIRIR
12	alt alta kayıt işlemi
13	Aralığı Görüntü Olarak Dönüştürme: Seçilen aralığı bir görüntü olarak yapıştırın. Aralığı seçmeniz yeterlidir ve bu kodu çalıştırdıktan sonra o aralık için otomatik olarak bir resim ekler.
14	excel operatörleri hk
15	makrolar kutusu ve makrolar görünsün
16	listbox ve combobox'a veri girmek
17	En İyi 10 Değeri vurgulayın: Bir aralık seçin ve bu makroyu çalıştırın ve yeşil renk ile en iyi 10 değeri vurgulayın.
18	excel'de başka verileri sıralı veriler arasına otomatik ekle
19	resmin yarısını gizleme ve gösterme
20	istediğiniz sayfa hariç sayfadaki verileri temizler

Excel Hazır Makrolar (VBA)

Forma Otomatik Resim Getirme

Robotik Kodlama

Hizmetler

Size nasıl yardımcı olabiliriz?

Youtube Kanalımıza Abone Oldunuz mu?

Anahtar Kelimeler