• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excel den word' e resim ve metin aktarma...

  • Konbuyu başlatan Konbuyu başlatan pNouma
  • Başlangıç tarihi Başlangıç tarihi
Katılım
29 Ocak 2024
Mesajlar
277
Excel Vers. ve Dili
Office 2016
Merhaba,
Excel sayfasının A sütununda resimler, "B:F" sütun aralığında bu resime ait bilgiler bulunmakta;

Ekli 1.. nolu görselde "A" sütunda bulunan görseli; önce word dosyasına aktarmak istiyorum,

Resim word dosyasına aktarıldıktan sonra, resmin altına "B:F" sütun aralığında bulunan verileri, 2 nolu görselde olduğu gibi alt-alta yazdırması için nasıl bir kod yazılabilir,

https://dosya.co/gulmcip9cwai/123.jpg.html
https://dosya.co/ig0agv846xai/1234.jpg.html

https://dosya.co/d36vwh9yh8ad/Kitap1.xlsx.html
https://dosya.co/2oruyels7l9x/00472254.docx.html

Aşağıdaki kod ile resimi kopyalayabiliyorum, yalnız altına yazıları nasıl yazdırabiliriz?


Kod:
Sub ExportToWord_Example2()
Dim WS As Worksheet
Dim WordApp As Object
Dim doc As Object
Dim rng As Range


Set WS = Worksheets("Sheet1")

Set WordApp = CreateObject("Word.Application")
With WordApp
.Visible = True
Set doc = .Documents.Add
End With

With WordApp
    WS.Shapes("Picture 1").Copy
    .Selection.Paste
 
End With

   doc.Paragraphs(doc.Paragraphs.Count).Range.InsertParagraphAfter
   
For i = 2 To 6
WS.Cells(2, i).Copy
        doc.Paragraphs(doc.Paragraphs.Count).Range.Paste
        Application.CutCopyMode = False
 ''
Next i

End Sub

yardımlarınız için şimdiden teşekkür ederim.
iyi Çalışmalar.
 
Son düzenleme:
kod

Kod:
'referanslarda bu olmalı
'microsoft word xx.0 object library

Sub resimkayıtet()

Kaynak = ThisWorkbook.Path

sat = 1
sut = 1
say2 = 1
say = 0
say3 = 1
sayi = 2


Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")


Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document

Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True
With wrdDoc
.Content.InsertParagraphAfter
With wrdApp.ActiveDocument

With wrdApp.ActiveDocument.PageSetup
.LeftMargin = 15 '50 'sol
.RightMargin = 10 '50 'sağ
.TopMargin = 15 'üst
.BottomMargin = 10 '20 ' alt

.Orientation = wdOrientPortrait
yükseylik = 176

End With
End With


Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then

say = say + 1

If say Mod sayi = 2 Then
sut = sut + 1
End If



If say = 2 Then
sut = sut + 1
say3 = say3 + 1
End If



If say = 1 Then
wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.Selection.Range, NumRows:=6, NumColumns:=sayi

With wrdApp.ActiveDocument.Tables(1)
If .Style <> "Tablo Kılavuzu" Then
'.Style = "Tablo Kılavuzu"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With
End If

sat2 = Picture.BottomRightCell.Row
ActiveSheet.Shapes(Picture.Name).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat, sut).Range.Paragraphs.WordWrap = True
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat, sut).Range.Paste

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat, sut)
'.Range.Paragraphs.WordWrap = True
'.Range.Paste
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = 230
.Range.InlineShapes(1).Width = 100
End With


wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 1, sut).Range = Cells(sat2, 2)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 2, sut).Range = Cells(sat2, 3)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 3, sut).Range = Cells(sat2, 4)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 4, sut).Range = Cells(sat2, 5)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 5, sut).Range = Cells(sat2, 6)

If sut = sayi Then
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 5, sut).Select
wrdApp.Selection.MoveDown Unit:=wdLine, Count:=1
'wrdApp.Selection.TypeParagraph
End If

If sut = 2 Then
sut = 1
say = 0
sat = sat + 6
End If


End If

Next Picture
son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi

End With


wrdDoc.Close
wrdApp.Quit

MsgBox "işlem tamam"

End Sub
 
kod

Kod:
'referanslarda bu olmalı
'microsoft word xx.0 object library

Sub resimkayıtet()

Kaynak = ThisWorkbook.Path

sat = 1
sut = 1
say2 = 1
say = 0
say3 = 1
sayi = 2


Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")


Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document

Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = True
With wrdDoc
.Content.InsertParagraphAfter
With wrdApp.ActiveDocument

With wrdApp.ActiveDocument.PageSetup
.LeftMargin = 15 '50 'sol
.RightMargin = 10 '50 'sağ
.TopMargin = 15 'üst
.BottomMargin = 10 '20 ' alt

.Orientation = wdOrientPortrait
yükseylik = 176

End With
End With


Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then

say = say + 1

If say Mod sayi = 2 Then
sut = sut + 1
End If



If say = 2 Then
sut = sut + 1
say3 = say3 + 1
End If



If say = 1 Then
wrdApp.ActiveDocument.Tables.Add Range:=wrdApp.Selection.Range, NumRows:=6, NumColumns:=sayi

With wrdApp.ActiveDocument.Tables(1)
If .Style <> "Tablo Kılavuzu" Then
'.Style = "Tablo Kılavuzu"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With
End If

sat2 = Picture.BottomRightCell.Row
ActiveSheet.Shapes(Picture.Name).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat, sut).Range.Paragraphs.WordWrap = True
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat, sut).Range.Paste

With wrdApp.ActiveDocument.Tables.Item(1).Cell(sat, sut)
'.Range.Paragraphs.WordWrap = True
'.Range.Paste
.Range.InlineShapes(1).Fill.Visible = msoFalse
.Range.InlineShapes(1).Fill.Solid
.Range.InlineShapes(1).Line.Visible = msoFalse
.Range.InlineShapes(1).Height = 230
.Range.InlineShapes(1).Width = 100
End With


wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 1, sut).Range = Cells(sat2, 2)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 2, sut).Range = Cells(sat2, 3)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 3, sut).Range = Cells(sat2, 4)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 4, sut).Range = Cells(sat2, 5)
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 5, sut).Range = Cells(sat2, 6)

If sut = sayi Then
wrdApp.ActiveDocument.Tables.Item(say2).Cell(sat + 5, sut).Select
wrdApp.Selection.MoveDown Unit:=wdLine, Count:=1
'wrdApp.Selection.TypeParagraph
End If

If sut = 2 Then
sut = 1
say = 0
sat = sat + 6
End If


End If

Next Picture
son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".doc"
wrdApp.ActiveDocument.SaveAs dosya_adi

End With


wrdDoc.Close
wrdApp.Quit

MsgBox "işlem tamam"

End Sub
çok Teşekkür ederim Hailt Hocam,
iyiki varsınız !
bir şey daha istesem çok olur mu acaba?
Burada Word Dosyası yerine Power point ' e veri göndermek istesek bu yapılabilir mi acaba?
Aynı şekilde word sayfaları yerine power point sunularına atmak

tekrar teşekkürler,
iyi çalışmalar.
 
kod:

Kod:
'referanslarda bu olmalı Microsoft PowerPoint xx.x Object Library.

Sub kaydetPowerPoint()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer

Kaynak = ThisWorkbook.Path
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
say = 0

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then
say = say + 1
sat2 = ActiveSheet.Shapes(Picture.Name).BottomRightCell.Row
ActiveSheet.Shapes(Picture.Name).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)

pptSlide.Shapes.PasteSpecial
pptSlide.Select

With pptSlide.Shapes(1)
If .Type = msoPicture Then
.Top = 87
.Left = 33
.Height = 222
.Width = 290
End If

bas = 90
For k = 1 To 5

pptApp.ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 340, bas, 340, 22).Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
With pptApp.ActiveWindow.Selection.TextRange
.Text = Cells(1, k + 1) & " = " & Cells(sat2, k + 1)
With .Font
.Name = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
pptApp.ActiveWindow.Selection.ShapeRange.Fill.Visible = msoFalse
pptApp.ActiveWindow.Selection.TextRange.ParagraphFormat.Alignment = ppAlignLeft

End With
End With

pptApp.ActiveWindow.Selection.Unselect
bas = bas + 40
Next k
End With

End If

Next Picture

pptApp.Visible = True
son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".ppt"


pptPres.SaveAs dosya_adi
pptApp.Quit

Set pptPres = Nothing
Set pptApp = Nothing

MsgBox "işlem tamam"

End Sub
 
bu kod da metin nesnesiyle yapılmıştır çerçeve yok

Kod:
'referanslarda bu olmalı Microsoft PowerPoint xx.x Object Library.

Sub kaydetPowerPoint()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer

Kaynak = ThisWorkbook.Path
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
say = 0

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then
say = say + 1
sat2 = ActiveSheet.Shapes(Picture.Name).BottomRightCell.Row
ActiveSheet.Shapes(Picture.Name).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

pptSlideCount = pptPres.Slides.Count
Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)

pptSlide.Shapes.PasteSpecial
pptSlide.Select

With pptSlide.Shapes(1)
If .Type = msoPicture Then
.Top = 87
.Left = 33
.Height = 222
.Width = 290
End If

bas = 90
For k = 1 To 5

pptApp.ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, 340, bas, 340, 22).Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoTrue

Set sayf = Workbooks(dosya_adı).Sheets(Sayfa_Adı) '.Cells(sat2, 2).Value

With pptApp.ActiveWindow.Selection.TextRange
.Text = sayf.Cells(1, k + 1) & " = " & sayf.Cells(sat2, k + 1)
With .Font
.Name = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
End With
End With

pptApp.ActiveWindow.Selection.Unselect
bas = bas + 40
Next k
End With

End If

Next Picture

son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".ppt"

pptPres.SaveAs dosya_adi
pptApp.Quit

Set pptPres = Nothing
Set pptApp = Nothing

Windows(dosya_adı).Activate
MsgBox "işlem tamam"

End Sub
 
Halit Hocam çok teşekkürler,
Burada power point dosyasında her bir sayfaya tek bir görsel geliyor,
word dosyasında olduğu gibi 1 sayfada yana 5 görsel getirilmesi sağlanamaz mı?

yeniden rahatsız ettiğim için lütfen kusura bakmayın.
iyi akşamlar.
 
Tamamdır bundan sonra değişiklik yok

Kod:
'referanslarda bu olmalı Microsoft PowerPoint xx.x Object Library.

Sub kaydetPowerPoint2()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptSlideCount As Integer

Kaynak = ThisWorkbook.Path
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add
say = 0

ReDim ara1(50000): ReDim ara2(50000)

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then
say = say + 1
sat2 = ActiveSheet.Shapes(Picture.Name).BottomRightCell.Row

ara1(say) = Picture.Name
ara2(say) = sat2

End If
Next Picture

ekle = 0
j = 0
m = 0
top1 = 20

For i = 1 To say
j = j + 1
ActiveSheet.Shapes(ara1(i)).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

If j = 1 Then

pptApp.ActiveWindow.View.GotoSlide Index:=pptApp.ActivePresentation.Slides.Add(Index:=1, Layout:=ppLayoutTitle).SlideIndex
pptApp.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Cut
pptApp.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Cut

End If

ActiveSheet.Shapes(ara1(i)).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
pptApp.ActiveWindow.View.Paste
ad = pptApp.ActiveWindow.Selection.SlideRange.Shapes.Count
pptApp.ActiveWindow.Selection.SlideRange.Shapes(ad).Select

With pptApp.ActiveWindow.Selection.SlideRange.Shapes(ad)
If .Type = msoPicture Then
.Top = 30 + ekle
.Left = 33
.Height = 90
.Width = 90
End If
End With

pptApp.ActiveWindow.Selection.Unselect

For k = 1 To 1
pptApp.ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, 140, top1, 440, 100).Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoTrue

Set sayf = Workbooks(dosya_adı).Sheets(Sayfa_Adı)

With pptApp.ActiveWindow.Selection.TextRange
.Text = sayf.Cells(1, 2) & " = " & sayf.Cells(ara2(i), 2) & Chr(11) & sayf.Cells(1, 3) & " = " & sayf.Cells(ara2(i), 3) & Chr(11) & sayf.Cells(1, 4) & " = " & sayf.Cells(ara2(i), 4) & Chr(11) & sayf.Cells(1, 5) & " = " & sayf.Cells(ara2(i), 5) & Chr(11) & sayf.Cells(1, 6) & " = " & sayf.Cells(ara2(i), 6)

With .Font
.Name = "Arial"
.Size = 16
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
'.Color.SchemeColor = ppForeground
End With
End With

pptApp.ActiveWindow.Selection.Unselect
top1 = top1 + 100
Next k

ekle = ekle + 100
m = m + 5
If j = 5 Then j = 0: ekle = 0: top1 = 20

Next i

son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".ppt"

pptPres.SaveAs dosya_adi
pptApp.Quit

Set pptPres = Nothing
Set pptApp = Nothing

Windows(dosya_adı).Activate
MsgBox "işlem tamam"

End Sub
 
farklı kod
Kod:
'referanslarda bu olmalı Microsoft PowerPoint xx.x Object Library.

Sub kaydetPowerPoint2()

Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Add

Kaynak = ThisWorkbook.Path
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name

ReDim ara1(50000): ReDim ara2(50000)

son = 0
ekle1 = 0
ekle2 = 1
j = 0

top1 = 20


Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
'burası resimleri kopyalıyor bende 13 olarak gözüküyor sizde 8 olarak gözükebilir
If Picture.Type = 13 Then
son = son + 1
sat2 = ActiveSheet.Shapes(Picture.Name).BottomRightCell.Row
ara1(son) = Picture.Name
ara2(son) = sat2
End If
Next Picture



For i = 1 To son
j = j + 1
ActiveSheet.Shapes(ara1(i)).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

If j = 1 Then
pptApp.ActiveWindow.View.GotoSlide Index:=pptApp.ActivePresentation.Slides.Add(Index:=ekle2, Layout:=ppLayoutBlank).SlideIndex
End If


ActiveSheet.Shapes(ara1(i)).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
pptApp.ActiveWindow.View.Paste
ad = pptApp.ActiveWindow.Selection.SlideRange.Shapes.Count
pptApp.ActiveWindow.Selection.SlideRange.Shapes(ad).Select

With pptApp.ActiveWindow.Selection.SlideRange.Shapes(ad)
pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse

If .Type = msoPicture Then
.Top = 26 + ekle1
.Left = 33
.Width = 100
.Height = 90

End If
End With

pptApp.ActiveWindow.Selection.Unselect

Set sayf = Workbooks(dosya_adı).Sheets(Sayfa_Adı)

For k = 1 To 1
pptApp.ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, 140, top1, 160, 100).Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoTrue
With pptApp.ActiveWindow.Selection.TextRange
.Text = sayf.Cells(1, 2) & Chr(11) & sayf.Cells(1, 3) & Chr(11) & sayf.Cells(1, 4) & Chr(11) & sayf.Cells(1, 5) & Chr(11) & sayf.Cells(1, 6)
With .Font
.Name = "Arial"
.Size = 16
.Color.RGB = RGB(255, 0, 0)
End With
End With
pptApp.ActiveWindow.Selection.Unselect
Next k

For k = 1 To 1
pptApp.ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, 300, top1, 200, 100).Select
pptApp.ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoTrue
With pptApp.ActiveWindow.Selection.TextRange
.Text = sayf.Cells(ara2(i), 2) & Chr(11) & sayf.Cells(ara2(i), 3) & Chr(11) & sayf.Cells(ara2(i), 4) & Chr(11) & sayf.Cells(ara2(i), 5) & Chr(11) & sayf.Cells(ara2(i), 6)
With .Font
.Name = "Arial"
.Size = 16
End With
End With
pptApp.ActiveWindow.Selection.Unselect
top1 = top1 + 100
Next k


ekle1 = ekle1 + 100

If j = 5 Then j = 0: ekle1 = 0: top1 = 20: ekle2 = ekle2 + 1

Next i

son1 = CreateObject("Scripting.FileSystemObject").getfolder(Kaynak).Files.Count + 1
dosya_adi = Kaynak & "\" & "word dosya" & son1 & ".ppt"

pptPres.SaveAs dosya_adi
pptApp.Quit

Set pptPres = Nothing
Set pptApp = Nothing

Windows(dosya_adı).Activate
MsgBox "işlem tamam"

End Sub
 
Son düzenleme:
Çok teşekkür ederim Halit Hocam
 
Geri
Üst