• DİKKAT

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

Word Belgesi Aç, Adet kadar sayfa aç, PDF olarak kaydet hk.

  • Konbuyu başlatan Konbuyu başlatan chngrcn
  • Başlangıç tarihi Başlangıç tarihi
C

chngrcn

Katılım
5 Mart 2010
Mesajlar
295
Excel Vers. ve Dili
Microsoft Office 2010
forumun değerli üyeleri;

A1 hücresine başlangıç no
A2 hücresine bitiş no
A3 Hücresine dosya adı yazılacak..

bir butona atanacak ve butona basıldığında; sırasıyla şu işlemleri yapsın..

-word belgesi açsın
- başlangıç ve bitiş sayısı kadar sayfa açsın
- üst bilgi ile sayfa numaralasın
- word belgesini PDF olarak kaydetsin.
- word belgesini kapatsın ve işlem tamam uyarısı versin..

saygılar.

Kod: 
https://upterabit.com/1Kux/pdfyap.xlsx
 

Ekli dosyalar

Sevgili dostlar,

Uzun araştırmalarım neticesinde mezkür çalışma hakkında bişeyler yapabilmeyi başarabildim. Fakat takıldığım bir kaç nokta hususunda yardımlarınızı rica ediyorum. Şimdiden teşekkürler..

Kod: 
Sub WORDtoPDF()
 Dim WD
 Dim Doc

'bilgi = Application.InputBox("Altbilgi için veri girişi yapınız.", "ALTBİLGİ")
'If bilgi = False Then Exit Sub

basla = Cells(1, 1).Value
bitis = Cells(2, 1).Value
ust = Cells(3, 1).Value 'üstbilgi
alt = Cells(4, 1).Value 'altbilgi
Filename = Cells(5, 1) 'dosya adı

Set WD = CreateObject("word.Application")
Set Doc = WD.Documents.Add
WD.Visible = True
yol = ThisWorkbook.Path

'dosya = Dir(yol & "\*doc*")
'Do While dosya <> ""
'WD.Application.Documents.Open yol & "\" & dosya

For i = basla To bitis - 1 'döngü başlangıcı

With WD.Application.Selection
    .Collapse Direction:=1
    .InsertBreak Type:=1
End With

Next

WD.ActiveWindow.ActivePane.View.SeekView = 9 ' üst bilgi

        WD.ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
        WD.Selection.WholeStory
        WD.Selection.TypeText Text:=ust
        
WD.ActiveWindow.ActivePane.View.SeekView = 10 ' alt bilgi

        WD.ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
        WD.Selection.WholeStory
        WD.Selection.TypeText Text:=alt

'dosya = Dir
'Loop
        
WD.ActiveWindow.ActivePane.View.SeekView = 0
'say = CreateObject("Scripting.FileSystemObject").getfolder(yol).Files.Count + 1

WD.ActiveDocument.ExportAsFixedFormat OutputFileName:=yol & "\" & Filename & ".pdf", ExportFormat:= _
        wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
        Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _
        CreateBookmarks:=wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=False, UseISO19005_1:=False

'WD.ActiveDocument.Close True
WD.ActiveDocument.SaveAs (yol & "\" & Filename)
WD.Application.Quit
'MsgBox "İşlem tamamlanmıştır.", vbInformation, "coded by CİHANGİR"
End Sub


Söz konusu yukarıdaki kod ile Word dosyası açıp, belirlenen aralıktaki adet kadar word sayfası açtırıp; üst ve alt bilgi ekletebiliyorum.

fakat word dosyasının 1.sayfasına ÜST BİLGİ ve ALT BİLGİ atamayı beceremedim.
ayrıca sayfasının SAĞ taraf ÜST BİLGİ Kısmına "SAYFA NUMARASI"
SAĞ taraf ALT BİLGİ kısmına da " TARİH" atamak istiyorum. bu konuda yardımlarınızı rica ederim..
 

Ekli dosyalar

değerli forum üyeleri;

yapılan araştırmalarıma binaen sorunu çözdüm..
Kodun son hali aşağıdadır..
Kırmızı renkle işaretlenen bölge eklenmiştir.
ÜST BİLGİ ( Sol, orta, Sağ )
ALT BİLGİ ( Sol, Orta, Sağ ) bölümlerde ilgili değerler verilebiliyor..

Saygılar, hayırlı günler..

Kod: 
Sub WORDtoPDF()
 Dim WD
 Dim Doc

'bilgi = Application.InputBox("Altbilgi için veri girişi yapınız.", "ALTBİLGİ")
'If bilgi = False Then Exit Sub

basla = Cells(1, 1).Value
bitis = Cells(2, 1).Value
ust = Cells(3, 1).Value 'üstbilgi
alt = Cells(4, 1).Value 'altbilgi
Filename = Cells(5, 1) 'dosya adı

Set WD = CreateObject("word.Application")
Set Doc = WD.Documents.Add
WD.Visible = True
yol = ThisWorkbook.Path

'dosya = Dir(yol & "\*doc*")
'Do While dosya <> ""
'WD.Application.Documents.Open yol & "\" & dosya

For i = basla To bitis - 1 'döngü başlangıcı

With WD.Application.Selection
    .Collapse Direction:=1
    .InsertBreak Type:=1
End With

Next

'WD.ActiveWindow.ActivePane.View.SeekView = 9 ' üst bilgi
'
'        WD.ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
'        WD.Selection.WholeStory
'        WD.Selection.TypeText Text:=ust
'
'WD.ActiveWindow.ActivePane.View.SeekView = 10 ' alt bilgi
'
'        WD.ActiveDocument.PageSetup.DifferentFirstPageHeaderFooter = True
'        WD.Selection.WholeStory
'        WD.Selection.TypeText Text:=alt

[COLOR="Red"]With WD.ActiveDocument.Sections(1)
    'üst bilgi ( headers )
    .Headers(wdHeaderFooterPrimary).Range.Text = "CİHANGİR" & vbTab & _
        "ÜST BİLGİ" & vbTab & ""
    .Headers(wdHeaderFooterPrimary).PageNumbers.Add FirstPage:=True

    'Alt Bilgi ( Footers )
    .Footers(wdHeaderFooterPrimary).Range.Text = "CİHANGİR" & vbTab & _
        "ALT BİLGİ" & vbTab & ""
    .Footers(wdHeaderFooterPrimary).PageNumbers.Add FirstPage:=True
            
End With[/COLOR]


'dosya = Dir
'Loop
        
WD.ActiveWindow.ActivePane.View.SeekView = 0
'say = CreateObject("Scripting.FileSystemObject").getfolder(yol).Files.Count + 1

'PDF farklı kaydet modülü
WD.ActiveDocument.ExportAsFixedFormat OutputFileName:=yol & "\" & Filename & ".pdf", ExportFormat:= _
        wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
        Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _
        CreateBookmarks:=wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=False, UseISO19005_1:=False

'WD.ActiveDocument.Close True
WD.ActiveDocument.SaveAs (yol & "\" & Filename)
WD.Application.Quit
'MsgBox "İşlem tamamlanmıştır.", vbInformation, "coded by CİHANGİR"
End Sub
 

Ekli dosyalar

Son düzenleme:
değerli forum üyeleri,

üst yada alt bilginin "start number" ( başlangıç numarası ) değerini istediğim değerden nasıl atayabilirim. Yukarıdaki koda bir türlü uyarlayamadım.. Yardımlarınızı rica ediyorum..
 
Yardımlarınızı rica ediyorum. Bi el atsak iş çözülecek..
 
silindi .....................
 
halit3' Alıntı:
Bunu nerede kullanacaksınız bilmiyorum inşallah işe yarar
Genişletmek için tıkla ...

@halit3 ün kodlarına sizin kodlarınıza göre ekleme yapıldı.

Kod: 
Sub WORDtoPDF7()
[COLOR=Red]basla = Cells(1, 1).Value
bitir = Cells(2, 1).Value
sayfasayisi = (bitir - basla)
ust = Cells(3, 1).Value 'üstbilgi
alt = Cells(4, 1).Value 'altbilgi
Filename = Cells(5, 1) 'dosya adı[/COLOR]


[COLOR=Red]pdfyol = ThisWorkbook.Path & "\" & Filename & ".pdf"
wordyol = ThisWorkbook.Path & "\" & Filename & ".docx"[/COLOR]

Dim WD, Doc

Set WD = CreateObject("word.Application")
Set Doc = WD.Documents.Add
WD.Visible = True

With WD.Selection
For j = 1 To [COLOR=Red]sayfasayisi[/COLOR]
.TypeParagraph
.InsertBreak
.TypeParagraph
Next j

End With


With WD.ActiveDocument.Sections(1) _
.Headers(wdHeaderFooterPrimary).PageNumbers
.NumberStyle = wdPageNumberStyleArabic
.IncludeChapterNumber = False
.RestartNumberingAtSection = True
.StartingNumber = [COLOR=Red]basla[/COLOR] ' sayfanın başlangıç numarası
.Add PageNumberAlignment:=wdAlignPageNumberRight, _
FirstPage:=True
End With

WD.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
WD.ActiveWindow.Selection.TypeText Text:=[COLOR=Red]ust[/COLOR]

'On Error Resume Next

WD.ActiveWindow.ActivePane.View.SeekView = wdSeekPrimaryFooter

WD.ActiveWindow.Selection.TypeText Text:=[COLOR=Red]alt[/COLOR] & vbTab
WD.ActiveWindow.Selection.TypeText Text:=vbTab
WD.ActiveWindow.Selection.TypeText Text:=Format(Now, "dd.mm.yyyy")
WD.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

[COLOR=Red]WD.ActiveDocument.ExportAsFixedFormat OutputFileName:=pdfyol, ExportFormat:= _
        wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
        Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=False, _
        CreateBookmarks:=wdExportCreateHeadingBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=False, UseISO19005_1:=False[/COLOR]
        
WD.ActiveDocument.SaveAs ([COLOR=Red]wordyol[/COLOR])
WD.ActiveDocument.Close True
WD.Application.Quit
MsgBox "İşlem tamamlanmıştır.", vbInformation, ""
End Sub
 
silindi.............................
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst