Excel'de ki Resim URL'ni Worde Aktarma

number25 · 22 Ağustos 2024

Arkadaşlar merhaba, konu başlığından da anlaşılacağı üzere ben bir site üzerinden katılımcılara form doldurtuyorum ve formda eser yüklemeleri gerekiyor. Bu formun çıktısı bana excel olarak geliyor fakat yüklenen resimler link olarak geliyor. Buraya kadar okey ama bu resimleri worde aktarmak istiyorum fakat resim olarak gitmesini istiyorum ben bunların. Böyle bir şey mümkün mü?

Eğer mümkünse birde boyutlayarak göndermekte olabilir mi?

necati · 22 Ağustos 2024

Merhaba,
Her iki dosyanızı (word ve excel) örnek olarak yükler misiniz? Word dosyasına olması gereken yere resmi manuel yükleyin.

number25 · 23 Ağustos 2024

necati' Alıntı:
Merhaba,
Her iki dosyanızı (word ve excel) örnek olarak yükler misiniz? Word dosyasına olması gereken yere resmi manuel yükleyin.

Hocam öncelikle ilginiz için teşekkürler. Asıl istediğim çıktı şu şekilde word'de Ekran görüntüsü
Excel bilgileri ise buradan indirebilirsiniz. En başta kişinin ismi ve eğer olabilirse yanına yaşını (doğum tarihinden hesaplayarak) benim için sıkıntı olan resim url yerleştirememekti. Excel'de ki eser sırası

Eser Adı

Eser Tekniği

1.Görsel

Eser Boyutu

Eser Fiyatı

Yukarıda ki şekilde eser fiyatından sonra 2.Eser bilgileri geliyor aynı şekilde.
Yardımınız ve ilginiz için teşekkür ederim.

necati · 23 Ağustos 2024

Referanslardan Microsoft Word xx.0 Object Library aktif edildikten sonra,

Kod:

Option Explicit
Sub MSWord_Yazi_veResim_Yolla()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim objWdRange As Word.Range, Image As String
Dim sonsat As Long, i As Long, j As Integer, l As Integer

sonsat = Cells(Rows.Count, "A").End(3).Row

Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True

For i = 2 To sonsat

Set wrdDoc = wrdApp.Documents.Add
Set objWdRange = wrdDoc.Content
   
    With objWdRange
        .PageSetup.Orientation = wdOrientLandscape
        .Text = Range("a" & i).Text & " - " & Year(Date) - Right(Range("e" & i), 4) & vbNewLine & _
        Range("b" & i).Text
        .Font.Name = "Arial Black"
        .Font.Size = 20
        .Font.ColorIndex = wdBlack
        .Bold = True
        .Paragraphs.Alignment = wdAlignParagraphCenter
        .Collapse Direction:=wdCollapseEnd
        wrdDoc.Characters.Last.InsertParagraphAfter
        wrdDoc.Characters.Last.InsertParagraphAfter
        .Tables.Add Range:=wrdDoc.Paragraphs(wrdDoc.Paragraphs.Count).Range, NumRows:=2, NumColumns:=3
        wrdDoc.Tables(1).Borders.OutsideLineStyle = wdLineStyleNone
    End With

For j = 8 To 18 Step 5
    Image = "" & Cells(i, j).Text & ""

    With wrdDoc
        l = l + 1
        wrdDoc.Tables(1).Cell(1, l).Range.InlineShapes.AddPicture Filename:=Image
        Application.Wait (Now + TimeValue("0:00:01"))
        .Tables(1).Cell(1, l).VerticalAlignment = wdCellAlignVerticalCenter
        .Tables(1).Cell(2, l).Range.Text = "Eser Adı " & (Cells(i, j - 2).Text) & vbNewLine & _
        "Teknik    " & (Cells(i, j - 1).Text) & vbNewLine & _
        "Boyut     " & (Cells(i, j + 1).Text) & vbNewLine & _
        "Fiyatı     " & (Cells(i, j + 2).Text)
        .Tables(1).Cell(2, l).Range.Font.Name = "Arial"
        .Tables(1).Cell(2, l).Range.Font.Size = 12
        .Tables(1).Cell(2, l).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
            With .InlineShapes(l)
                .Height = 150
                .Width = 250
            End With
    End With
Next
    l = 0
    wrdDoc.SaveAs ThisWorkbook.Path & "\" & Range("a" & i).Text & ".docx"
    wrdDoc.Close False
    Set wrdDoc = Nothing
Next

    wrdApp.Quit
    Set wrdApp = Nothing
    MsgBox "Belgeler oluşturuldu", vbInformation
End Sub

number25 · 26 Ağustos 2024

necati' Alıntı:

Referanslardan Microsoft Word xx.0 Object Library aktif edildikten sonra,

Kod:

Option Explicit
Sub MSWord_Yazi_veResim_Yolla()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim objWdRange As Word.Range, Image As String
Dim sonsat As Long, i As Long, j As Integer, l As Integer

sonsat = Cells(Rows.Count, "A").End(3).Row

Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True

For i = 2 To sonsat

Set wrdDoc = wrdApp.Documents.Add
Set objWdRange = wrdDoc.Content
  
    With objWdRange
        .PageSetup.Orientation = wdOrientLandscape
        .Text = Range("a" & i).Text & " - " & Year(Date) - Right(Range("e" & i), 4) & vbNewLine & _
        Range("b" & i).Text
        .Font.Name = "Arial Black"
        .Font.Size = 20
        .Font.ColorIndex = wdBlack
        .Bold = True
        .Paragraphs.Alignment = wdAlignParagraphCenter
        .Collapse Direction:=wdCollapseEnd
        wrdDoc.Characters.Last.InsertParagraphAfter
        wrdDoc.Characters.Last.InsertParagraphAfter
        .Tables.Add Range:=wrdDoc.Paragraphs(wrdDoc.Paragraphs.Count).Range, NumRows:=2, NumColumns:=3
        wrdDoc.Tables(1).Borders.OutsideLineStyle = wdLineStyleNone
    End With

For j = 8 To 18 Step 5
    Image = "" & Cells(i, j).Text & ""

    With wrdDoc
        l = l + 1
        wrdDoc.Tables(1).Cell(1, l).Range.InlineShapes.AddPicture Filename:=Image
        Application.Wait (Now + TimeValue("0:00:01"))
        .Tables(1).Cell(1, l).VerticalAlignment = wdCellAlignVerticalCenter
        .Tables(1).Cell(2, l).Range.Text = "Eser Adı " & (Cells(i, j - 2).Text) & vbNewLine & _
        "Teknik    " & (Cells(i, j - 1).Text) & vbNewLine & _
        "Boyut     " & (Cells(i, j + 1).Text) & vbNewLine & _
        "Fiyatı     " & (Cells(i, j + 2).Text)
        .Tables(1).Cell(2, l).Range.Font.Name = "Arial"
        .Tables(1).Cell(2, l).Range.Font.Size = 12
        .Tables(1).Cell(2, l).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
            With .InlineShapes(l)
                .Height = 150
                .Width = 250
            End With
    End With
Next
    l = 0
    wrdDoc.SaveAs ThisWorkbook.Path & "\" & Range("a" & i).Text & ".docx"
    wrdDoc.Close False
    Set wrdDoc = Nothing
Next

    wrdApp.Quit
    Set wrdApp = Nothing
    MsgBox "Belgeler oluşturuldu", vbInformation
End Sub

Necati bey ellerinize sağlık çok teşekkür ederim. Bunların sayfaların belli yerlerine vektör görsel ekleyeceğim tam olarak kod yapısını nereye nasıl yazabilirim. (1 logo, 2 vektör şekil)

necati · 26 Ağustos 2024

Örnek olarak yapılmış halini paylaşabilir misiniz.

number25 · 26 Ağustos 2024

Buradan indirebilirsiniz. Bu dosyada bulunan kenarlarda ki vector ve logoların her sayfada olmasını, olabilirse eğer yine isim kısmını'da aynı renk ile yapabilir miyiz?

İlginiz için çok teşekkür ederim.

necati · 26 Ağustos 2024

Sabit şekiller için bir şablon oluşturdum ve arka plan resimleri ekleyip kaydettim.
Daha sonra bu şablon üzerinde makromuzu çalıştırdım. esas = "D:\DENEME\esas.docx" yolunu kendinize göre ayarlayın.
Şablonu ekliyorum. Örnek
Siz kendinize göre daha özelleştirmek isteyebilirsiniz. Önceki kodda da bazı ilaveler yapıldı.
Referanslardan Microsoft Word xx.0 Object Library aktif edildikten sonra,

Kod:

Option Explicit
Sub MSWord_Yazi_veResim_Yolla2()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim objWdRange As Word.Range, Image As String
Dim sonsat As Long, i As Long, j As Integer, l As Integer
Dim esas As String, r, rnk

sonsat = Cells(Rows.Count, "A").End(3).Row

Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True

esas = "D:\DENEME\esas.docx"

For i = 2 To sonsat
    Set wrdDoc = wrdApp.Documents.Open(esas)
    With wrdDoc.PageSetup
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
    End With
    Set objWdRange = wrdDoc.Content
  
    With objWdRange
        .PageSetup.Orientation = wdOrientLandscape
        .Text = Range("a" & i).Text & " - " & Year(Date) - Right(Range("e" & i), 4) & vbNewLine & _
        Range("b" & i).Text
        .Font.Name = "Arial Black"
        .Font.Size = 20
        .Font.ColorIndex = wdBlack
        .Bold = True
        .Paragraphs.Alignment = wdAlignParagraphCenter
        .Collapse Direction:=wdCollapseEnd
        wrdDoc.Characters.Last.InsertParagraphAfter
        wrdDoc.Characters.Last.InsertParagraphAfter
        .Tables.Add Range:=wrdDoc.Paragraphs(wrdDoc.Paragraphs.Count).Range, NumRows:=2, NumColumns:=3
        wrdDoc.Tables(1).Borders.OutsideLineStyle = wdLineStyleNone
    End With

For j = 8 To 18 Step 5
    Image = "" & Cells(i, j).Text & ""

    With wrdDoc
        l = l + 1
        .Tables(1).Cell(1, l).Range.InlineShapes.AddPicture Filename:=Image
        Application.Wait (Now + TimeValue("0:00:01"))
        .Tables(1).Cell(1, l).VerticalAlignment = wdCellAlignVerticalCenter
        .Tables(1).Cell(2, l).Range.Text = "Eser Adı " & (Cells(i, j - 2).Text) & vbNewLine & _
        "Teknik   " & Split((Replace(Cells(i, j - 1).Text, ",", ";")), ";")(0) & vbNewLine & _
        "Boyut     " & (Cells(i, j + 1).Text) & vbNewLine & _
        "Fiyatı      " & (Cells(i, j + 2).Text) & " TL"
        .Tables(1).Cell(2, l).Range.Font.Name = "Arial"
        .Tables(1).Cell(2, l).Range.Font.Size = 11
        .Tables(1).Cell(2, l).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft

            With .InlineShapes(l)
                .Height = 150
                .Width = 245
            End With
      
        rnk = Array(Cells(i, j - 2).Text, Split((Replace(Cells(i, j - 1).Text, ",", ";")), ";")(0), Cells(i, j + 1).Text, Cells(i, j + 2).Text & " TL")

        For Each r In rnk
             With objWdRange.Find
                .ClearFormatting
                .Text = r
                .MatchCase = True
                .MatchWholeWord = True
                .Replacement.Text = "^&"
                .Replacement.Font.Color = wdColorRed
                .Replacement.Font.Allcaps = True
                .Execute Replace:=wdReplaceAll
            End With
        Next r

    End With
Next j
      
    l = 0
    wrdDoc.SaveAs ThisWorkbook.Path & "\" & Range("a" & i).Text & ".docx"
    wrdDoc.Close False
    Set wrdDoc = Nothing
Next i

    wrdApp.Quit
    Set wrdApp = Nothing
    MsgBox "Belgeler oluşturuldu", vbInformation
End Sub

number25 · 26 Ağustos 2024

necati' Alıntı:

Sabit şekiller için bir şablon oluşturdum ve arka plan resimleri ekleyip kaydettim.
Daha sonra bu şablon üzerinde makromuzu çalıştırdım. esas = "D:\DENEME\esas.docx" yolunu kendinize göre ayarlayın.
Şablonu ekliyorum. Örnek
Siz kendinize göre daha özelleştirmek isteyebilirsiniz. Önceki kodda da bazı ilaveler yapıldı.
Referanslardan Microsoft Word xx.0 Object Library aktif edildikten sonra,

Kod:

Option Explicit
Sub MSWord_Yazi_veResim_Yolla2()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim objWdRange As Word.Range, Image As String
Dim sonsat As Long, i As Long, j As Integer, l As Integer
Dim esas As String, r, rnk

sonsat = Cells(Rows.Count, "A").End(3).Row

Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True

esas = "D:\DENEME\esas.docx"

For i = 2 To sonsat
    Set wrdDoc = wrdApp.Documents.Open(esas)
    With wrdDoc.PageSetup
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
    End With
    Set objWdRange = wrdDoc.Content
 
    With objWdRange
        .PageSetup.Orientation = wdOrientLandscape
        .Text = Range("a" & i).Text & " - " & Year(Date) - Right(Range("e" & i), 4) & vbNewLine & _
        Range("b" & i).Text
        .Font.Name = "Arial Black"
        .Font.Size = 20
        .Font.ColorIndex = wdBlack
        .Bold = True
        .Paragraphs.Alignment = wdAlignParagraphCenter
        .Collapse Direction:=wdCollapseEnd
        wrdDoc.Characters.Last.InsertParagraphAfter
        wrdDoc.Characters.Last.InsertParagraphAfter
        .Tables.Add Range:=wrdDoc.Paragraphs(wrdDoc.Paragraphs.Count).Range, NumRows:=2, NumColumns:=3
        wrdDoc.Tables(1).Borders.OutsideLineStyle = wdLineStyleNone
    End With

For j = 8 To 18 Step 5
    Image = "" & Cells(i, j).Text & ""

    With wrdDoc
        l = l + 1
        .Tables(1).Cell(1, l).Range.InlineShapes.AddPicture Filename:=Image
        Application.Wait (Now + TimeValue("0:00:01"))
        .Tables(1).Cell(1, l).VerticalAlignment = wdCellAlignVerticalCenter
        .Tables(1).Cell(2, l).Range.Text = "Eser Adı " & (Cells(i, j - 2).Text) & vbNewLine & _
        "Teknik   " & Split((Replace(Cells(i, j - 1).Text, ",", ";")), ";")(0) & vbNewLine & _
        "Boyut     " & (Cells(i, j + 1).Text) & vbNewLine & _
        "Fiyatı      " & (Cells(i, j + 2).Text) & " TL"
        .Tables(1).Cell(2, l).Range.Font.Name = "Arial"
        .Tables(1).Cell(2, l).Range.Font.Size = 11
        .Tables(1).Cell(2, l).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft

            With .InlineShapes(l)
                .Height = 150
                .Width = 245
            End With
     
        rnk = Array(Cells(i, j - 2).Text, Split((Replace(Cells(i, j - 1).Text, ",", ";")), ";")(0), Cells(i, j + 1).Text, Cells(i, j + 2).Text & " TL")

        For Each r In rnk
             With objWdRange.Find
                .ClearFormatting
                .Text = r
                .MatchCase = True
                .MatchWholeWord = True
                .Replacement.Text = "^&"
                .Replacement.Font.Color = wdColorRed
                .Replacement.Font.Allcaps = True
                .Execute Replace:=wdReplaceAll
            End With
        Next r

    End With
Next j
     
    l = 0
    wrdDoc.SaveAs ThisWorkbook.Path & "\" & Range("a" & i).Text & ".docx"
    wrdDoc.Close False
    Set wrdDoc = Nothing
Next i

    wrdApp.Quit
    Set wrdApp = Nothing
    MsgBox "Belgeler oluşturuldu", vbInformation
End Sub

Teşekkür ederim şablonu oluşturdum ama her başlangıçta açıyor son çıktıda logo ve vektörler bulunmuyor?

necati · 26 Ağustos 2024

Her başlangıç derken biraz daha açar mısınız. İlk çıktılarda logo ve vektörler var değil mi. sadece son çıktıda mı olmuyor.

number25 · 26 Ağustos 2024

İlk çıktıda da yok sadece şablonu açıp kapatıyor, yani şablonun üstüne giydirme yapmıyor.

necati · 26 Ağustos 2024

Gönderdiğim şablonda Logo ve vektörleri eklerken sağ tıklayıp Metin kaydırma yaptım. Siz de bu özelliği "metnin arkasına" diye ayarlayın.

necati · 26 Ağustos 2024

Logo ve vektörleri üst/alt bilgi menüsü aktifken ekleyin.

number25 · 26 Ağustos 2024

Tamamdır çok teşekkür ederim Necati bey

necati · 26 Ağustos 2024

Rica ederim, kolay gelsin.