Word dosyasındaki nesneyi renklendirme

[excellkurdu]

Merhaba Arkadaşlar,
Aynı dizin içindeki açık Excel dosyasından word dosya içindeki Şeklin/Nesnenin dolgusunu kırmızı yapabilir miyiz? Bu mümkün müdür?
Eğer mümkünse Numaraya karşılık gelen şekillerden "sorunlu" olanlar kırmızı, diğerleri Mavi olabilir mi?
Örnek: (C1, C2, C3 word deki nesnelerin isimleridir, hücre değil)
C1 = sorunlu
C2 = aktivite yok
C3 = sorunlu
word deki C1 ve C3 nesne dolguları kırmızı, diğerleri mavi olmalı.

Düzeltme: Konu güncel. Hocalarım Eğer bu mümkün değilse konuyu kapatabiliriz.

Saygılarımla

Alternatif Link: http://s3.dosya.tc/server9/7jal03/wordSekil.rar.html

 

[excellkurdu]

Hocalarım. Konu mümkün değil gibi herhalde. Excel içinde çalışan daha önceden sizlerinde yardımlarıyla bir kodum var. Bu kodun aynısını word e uyarlayamazmıyız?

Sub ŞEKİL_BOYA_FARE()
Dim v As Worksheet: Set v = Sheets("Veri")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For Each sayfa In Worksheets
        If sayfa.Name = "Veri" Then
            GoTo 20
        End If
        sayfa.Activate
            sayı = sayfa.DrawingObjects.Count
                For sekil = 1 To sayı
                    sayfa.Shapes.Range(Array(sekil)).Select
                        metin = Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text
                            If metin = "" Or _
                                WorksheetFunction.CountIf(v.Range("B6:B" & v.[B65536].End(3).Row), metin) = 0 Then
                                GoTo 10
                            Else
                            Selection.ShapeRange.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent1
                            satır = WorksheetFunction.Match(metin, v.Range("B1:B" & v.[B65536].End(3).Row), 0)
                                If v.Cells(satır, 4) = "sorunlu" Then
                                    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
                                Else: GoTo 10
                                End If
                            End If
10:             Next
sayfa.Cells(1, 1).Activate
20:  Next
v.Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

 

[alicimri]

1- Aşağıdaki kodlar Excelde çalışacaktır.
2- VBE ekranında Tools/References de "Microsoft Word 14 Object Library" tıklayarak dahil edin sizde kırmızı ile yazılı sayı farklı olabilir.
3- Excel ve Word dosyaları aynı klasörde olduğu varsayılmıştır.

Sub Makro1()
Dim doc As Word.Application
Set doc = CreateObject("word.Application.14")
doc.Documents.Open Filename:=ThisWorkbook.Path & "/Şekiller.docx"
For i = 1 To doc.ActiveDocument.Shapes.Count
doc.ActiveDocument.Shapes(i).Select
If doc.Selection.Range.Text <> "" Then
doc.ActiveDocument.Shapes(i).Name = Replace(doc.Selection.Range.Text, Chr(13), "")
end if
Next
For E = 9 To Range("B" & 65536).End(3).Row
doc.ActiveDocument.Shapes(Range("B" & E)).Select
If Range("D" & E) = "sorunlu" Then
  doc.Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
    doc.Selection.ShapeRange.Fill.Visible = msoTrue
 Else
  doc.Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 112, 192)
    doc.Selection.ShapeRange.Fill.Visible = msoTrue
End If
Next
For x = 9 To Range("I" & 65536).End(3).Row
doc.ActiveDocument.Shapes(Range("I" & x)).Select
If Range("K" & x) = "sorunlu" Then
  doc.Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
    doc.Selection.ShapeRange.Fill.Visible = msoTrue
 Else
  doc.Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 112, 192)
    doc.Selection.ShapeRange.Fill.Visible = msoTrue
End If
Next
doc.ActiveDocument.Save
doc.Quit
Set doc = Nothing
End Sub

 

[excellkurdu]

Ali hocam şehir dışındaydım. Hemen bakamadım özür dilerim.
Şuan denedim. Dediğiniz gibi 14 ü 12 yaptım sorunsuz çalıştı.
Hata bende dosyada belirtmedim. Bu şekiller bir binanın krokisi. Bu kroki yine şekillerle çizilmiş. yani çizgi, kare, daire gibi şekillerden oluşuyor. Bu kroki içinde de belirli yerlerde ben kontrol noktaları oluşturdum. Bu kontrol noktaları Kare ya da silindir şekillerden oluşuyor ve bunlar numaralandırılmıştır. Kod sadece excel dosyasındaki B ve I sütunundaki numaralı şekillerde çalışmalı.
Böyle olursa muhteşem olacak. Verdiğiniz kodlarla bunu deniyorum bakalım becerebilirmiyim.
Allah razı olsun. İlginize çok teşekkür ederim.

 

[alicimri]

Yukardaki kodlarda, sadece içinde C1, F1 gibi metinler bulunan "Shape"lerde çalışması için değişiklik yaptım.

 

[excellkurdu]

Hocam şuan denediğim iki dosyamda da çalıştı. Diğer dosyalarımda da deneyeceğim. Umarım bir sorun olmaz.
Çok teşekkürler, yordum sizi hakkınızı helal edin. Çok sağolun.