Merhaba. Bir Word belgesinde yer alan A'den Z'ye kadar olan harfler haricindeki karakterleri metin biçiminden resim biçimine dönüştüren bir makro programını sizlerden rica etmiştim. Sağolsun Mustafa Altun bey bu isteğimi yazdığı makro programıyla yerine getirmeye çalıştı. Ancak bu makro programı
http://s7.dosya.tc/server2/dpt3s5/ORNEK.docx.html URL adresinde yer alan Word dosyasında düzgün netice vermedi. Bu sebeple, bu makro programını düzeltmenizi sizlerden istirham ediyorum.
Makro programının kodları:
Sub Osmanlica_Metin()
Set wd = CreateObject("word.Application")
wd.Visible = True
yol = ThisWorkbook.Path & "\ORNEK.docx"
wd.Application.Documents.Open yol
fnt = "Times New Roman"
knt = False
If ActiveWindow.DisplayGridlines = True Then
ActiveWindow.DisplayGridlines = False
End If
On Error GoTo bitir
For x = 1 To wd.ActiveDocument.Characters.Count
If wd.ActiveDocument.Characters(x).Font.Name = fnt And knt = False Then
knt = True
ilk = x - 1
End If
If ilk > 0 And knt = True Then
If wd.ActiveDocument.Characters(x).Font.Name <> fnt Then
son = x - 1
wd.ActiveDocument.Range(Start:=ilk, End:=son).Copy
Range("h1").Select
Columns("H:H").ColumnWidth = 180
ActiveSheet.PasteSpecial Format:="HTML"
Columns("H:H").EntireColumn.AutoFit
Rows("1:1").EntireRow.AutoFit
Range("h1").Font.Bold = True
Range("h1").CopyPicture
wd.ActiveDocument.Range(Start:=ilk, End:=son).Paste
Application.CutCopyMode = False
son = 0: ilk = 0: knt = False
End If
End If
Next
bitir:
MsgBox "İşlem tamam.", vbInformation, "leumruk"
End Sub
http://s7.dosya.tc/server2/dpt3s5/ORNEK.docx.html URL adresinde yer alan Word dosyasında düzgün netice vermedi. Bu sebeple, bu makro programını düzeltmenizi sizlerden istirham ediyorum.
Makro programının kodları:
Sub Osmanlica_Metin()
Set wd = CreateObject("word.Application")
wd.Visible = True
yol = ThisWorkbook.Path & "\ORNEK.docx"
wd.Application.Documents.Open yol
fnt = "Times New Roman"
knt = False
If ActiveWindow.DisplayGridlines = True Then
ActiveWindow.DisplayGridlines = False
End If
On Error GoTo bitir
For x = 1 To wd.ActiveDocument.Characters.Count
If wd.ActiveDocument.Characters(x).Font.Name = fnt And knt = False Then
knt = True
ilk = x - 1
End If
If ilk > 0 And knt = True Then
If wd.ActiveDocument.Characters(x).Font.Name <> fnt Then
son = x - 1
wd.ActiveDocument.Range(Start:=ilk, End:=son).Copy
Range("h1").Select
Columns("H:H").ColumnWidth = 180
ActiveSheet.PasteSpecial Format:="HTML"
Columns("H:H").EntireColumn.AutoFit
Rows("1:1").EntireRow.AutoFit
Range("h1").Font.Bold = True
Range("h1").CopyPicture
wd.ActiveDocument.Range(Start:=ilk, End:=son).Paste
Application.CutCopyMode = False
son = 0: ilk = 0: knt = False
End If
End If
Next
bitir:
MsgBox "İşlem tamam.", vbInformation, "leumruk"
End Sub
