email ti pdf script feiler

[Zafar Iqbal]

Jeg har brukt dette scriptet og laget en macro som jeg bruker i outlook.

 

Outlook kan ikke lagre denne filen fori den er åpen et annet sted.

(c:\\user\xxxx\....\Temp\email_temp.mht)

 

Men scriptet feiler med dialogboks:
Run-time-error -2147352567 880020009)
Datatabellen er utenfor grensen

 

Med vanlgene end, debug, help

 

Velger jeg debug får jeg merket følgende linje gult.

MySelectedItem.SaveAs tmpFileName, 10

 

 

Noen som vet hva som feiler?
 

 

Fant følgende om lagring:

Årsak

 

 

Dette problemet kan oppstå hvis én av følgende betingelser er oppfylt:

• Et dokument som har samme filnavn som du prøver å lagre dokumentet er åpnet av en annen bruker.
  
  Obs! Denne betingelsen kan være sant når du lagrer et dokument til et nettverk eller en delt mappe.
• Det er en midlertidig eier-fil som har samme filnavn som du prøver å lagre dokumentet på samme sted.
  
  Obs! Hvis et dokument ikke er lukket på riktig måte, fjernes ikke eierfilen for dokumentet. Derfor forblir eierfilen på samme sted. Dette kan for eksempel skje hvis Word 2007 lukkes uventet. Når du prøver å lagre et dokument som har samme filnavn som eierfilen til samme plassering, får du feilmeldingen som er nevnt i delen "Symptomer".

 

Endret 9. januar 2018 av Zafar Iqbal

[Dan-Levi]

Du må dele skriptet om vi skal hjelpe deg å feilsøke det.

[Zafar Iqbal]

Se nedenfor

 

Sub SaveAsPDFfile()

Dim MyOlNamespace As NameSpace

Dim MySelectedItem As MailItem

Dim Response As String

Dim FSO As Object, TmpFolder As Object

Dim tmpFileName As String

Dim wrdApp As Object

Dim wrdDoc As Object

Dim bStarted As Boolean

Dim dlgSaveAs As FileDialog

Dim fdfs As FileDialogFilters

Dim fdf As FileDialogFilter

Dim i As Integer

Dim WshShell As Object

Dim SpecialPath As String

Dim msgFileName As String

Dim strCurrentFile As String

Dim strName As String

Dim oRegEx As Object

Dim intPos As Long

Set MyOlNamespace = Application.GetNamespace("MAPI")

Set MySelectedItem = ActiveExplorer.Selection.Item(1)

Set FSO = CreateObject("Scripting.FileSystemObject")

tmpFileName = FSO.GetSpecialFolder(2)

strName = "email_temp.mht"

tmpFileName = tmpFileName & "\" & strName

MySelectedItem.SaveAs tmpFileName, 10

On Error Resume Next

Set wrdApp = GetObject(, "Word.Application")

If Err Then

Set wrdApp = CreateObject("Word.Application")

bStarted = True

End If

On Error GoTo 0

Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False, Format:=7)

Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)

Set fdfs = dlgSaveAs.Filters

i = 0

For Each fdf In fdfs

i = i + 1

If InStr(1, fdf.Extensions, "pdf", vbTextCompare) > 0 Then

Exit For

End If

Next fdf

dlgSaveAs.FilterIndex = i

Set WshShell = CreateObject("WScript.Shell")

SpecialPath = WshShell.SpecialFolders(16)

msgFileName = MySelectedItem.Subject

Set oRegEx = CreateObject("vbscript.regexp")

oRegEx.Global = True

oRegEx.Pattern = "[\/:*?""<>|]"

msgFileName = Trim(oRegEx.Replace(msgFileName, ""))

dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName

If dlgSaveAs.Show = -1 Then

strCurrentFile = dlgSaveAs.SelectedItems(1)

If Right(strCurrentFile, 4) <> ".pdf" Then

Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _

vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel)

If Response = vbCancel Then

wrdDoc.Close 0

If bStarted Then wrdApp.Quit

Exit Sub

ElseIf Response = vbOK Then

intPos = InStrRev(strCurrentFile, ".")

If intPos > 0 Then

strCurrentFile = Left(strCurrentFile, intPos - 1)

End If

strCurrentFile = strCurrentFile & ".pdf"

End If

End If

wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _

strCurrentFile, _

ExportFormat:=17, _

OpenAfterExport:=False, _

OptimizeFor:=0, _

Range:=0, _

From:=0, _

To:=0, _

Item:=0, _

IncludeDocProps:=True, _

KeepIRM:=True, _

CreateBookmarks:=0, _

DocStructureTags:=True, _

BitmapMissingFonts:=True, _

UseISO19005_1:=False

End If

Set dlgSaveAs = Nothing

wrdDoc.Close

If bStarted Then wrdApp.Quit

Set MyOlNamespace = Nothing

Set MySelectedItem = Nothing

Set wrdDoc = Nothing

Set wrdApp = Nothing

Set oRegEx = Nothing

End Sub