Activedotasıcument Ha

[hlojan]

Word Açmak için kullandığım kod

Private Sub aktar_Click()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Data")
' WORD AÇILIŞ
Application.ScreenUpdating = False
Set wd = CreateObject("Word.Application")
Set objDOC = wd.Documents.Open(ThisWorkbook.Path & "\Sertifika.doc")
wd.Visible = True
' BİTİŞ

' ************** VERİ GİRİŞİ ******************

' CİHAZ KODU
objDOC.Bookmarks("box1").Range.Text = ws.Range("U48").Value
objDOC.Bookmarks("box2").Range.Text = ws.Range("U48").Value


objDOC.Bookmarks("ser").Range.Text = ws.Range("o16").Value
'TEKLİF



'************************* BİTTİ *****************************



 ' **************************** VERİLER ********************************

wd.Selection.Goto What:=wdGoToBookmark, Name:="a1"
ws.Range("A5:d10").Copy
wd.Selection.Paste

  
        
 

'BİTTİ
MsgBox "WORD BELGESİ AZIRLANDI", vbInformation, "Metro"
MsgBox "WORD BELGESİ AZIRLANDI", vbInformation, "Metro"
ActiveSheet.kaydet.Enabled = True
ActiveSheet.kaydet.BackColor = RGB(0, 100, 0)
ActiveSheet.kaydet.Caption = "KAYDET"
ActiveSheet.kaydet.Font.Size = 16
End Sub

Word Farklı kaydetk için kullandığım kod

' DOSYA AÇMA KODLARI
ad1 = "C:\ARŞİV\" & AV1
If CreateObject("Scripting.FileSystemObject").FolderExists(ad1) = False Then
MkDir ad1
End If
ad2 = "C:\ARŞİV\" & AV1 & "\" & SV3
If CreateObject("Scripting.FileSystemObject").FolderExists(ad2) = False Then
MkDir ad2
End If
ad3 = "C:\ARŞİV\" & AV1 & "\" & SV3 & "\" & dv2
If CreateObject("Scripting.FileSystemObject").FolderExists(ad3) = False Then
MkDir ad3
End If
ad4 = "O:\" & SV1
If CreateObject("Scripting.FileSystemObject").FolderExists(ad4) = False Then
MkDir ad4
End If
ad5 = "O:\" & SV1 & "\" & SV2
If CreateObject("Scripting.FileSystemObject").FolderExists(ad5) = False Then
MkDir ad5
End If
ad6 = "O:\" & SV1 & "\" & SV2 & "\" & SV3
If CreateObject("Scripting.FileSystemObject").FolderExists(ad6) = False Then
MkDir ad6
End If
ad7 = "O:\" & SV1 & "\" & SV2 & "\" & SV3 & "\" & SV4
If CreateObject("Scripting.FileSystemObject").FolderExists(ad7) = False Then
MkDir ad7
End If
ad8 = "O:\" & SV1 & "\" & SV2 & "\" & SV3 & "\" & SV4 & "\" & dv2
If CreateObject("Scripting.FileSystemObject").FolderExists(ad8) = False Then
MkDir ad8
End If

[COLOR="Red"][B]With ActiveDocument[/B][/COLOR]
.SaveAs "C:\ARŞİV\" & AV1 & "\" & SV3 & "\" & dv2 & "\" & DV1 & ".doc"
.SaveAs "O:\" & SV1 & "\" & SV2 & "\" & SV3 & "\" & SV4 & "\" & dv2 & "\" & DV1 & ".doc"
End With
MsgBox "WORD KAYDEDİLDİ", vbInformation, "Metro"

Dim objWord As Object
    
    Set objWord = GetObject(, "Word.Application")
    
    objWord.Quit False
' FARKLI KAYDETME
With ActiveWorkbook
.SaveCopyAs "C:\ARŞİV\" & AV1 & "\" & SV3 & "\" & dv2 & "\" & DV1 & ".xls"
.SaveCopyAs "O:\" & SV1 & "\" & SV2 & "\" & SV3 & "\" & SV4 & "\" & dv2 & "\" & DV1 & ".xls"

End With

Normalde çalışıyordu.

Format attım. Offise 2007 yi tekrar yükledim.

Active document algılamıyor

yardımlarınızı um