I have been able to successfully write to a pdf, but now I am trying to save it. I know I need to use a pddoc in order to save, but I can't set it to match the avdoc that I use to write to the pdf. The real code has a lot of fields so I will just reduce that to one field and put what I have below:
Sub mysub()
'basic declarations and initializations
Dim myfullpath As String
Dim myField As String
myfullpath = "C:\mypdf.pdf"
myField = "Hello"
'pdf overhead declarations and initializations
Dim aApp As Acrobat.AcroApp
Dim av_doc As Acrobat.AcroAVDoc
Dim pdf_form As AFORMAUTLib.AFormApp
Set aApp = CreateObject("AcroExch.App")
Set av_doc = CreateObject("AcroExch.AVDoc")
Set pdf_form = CreateObject("AFORMAUT.App")
If av_doc.Open(myfullpath, "") = True Then
'declare and initialize pdf fields
Dim pdfField As AFORMAUTLib.Field
Set pdfField = pdf_form.Fields("pdfField")
'set value in pdf
pdfField = myField
'declare and initialize pddoc in order to save
Dim PdfDoc As Acrobat.CAcroPDDoc
Set PdfDoc = av_doc 'having trouble here
'“Run-time error ‘13’: Type mismatch”
PdfDoc.Save PDSaveFull, myfullpath
av_doc.Close False
Set pdfField = Nothing
End If
aApp.Exit
Set aApp = Nothing
Set av_doc = Nothing
Set PdfDoc = Nothing
End Sub
This worked for me:
Sub mysub()
Dim myfullpath As String, myfullpath_edited As String
Dim myField As String
Dim aApp As Acrobat.AcroApp
Dim av_doc As Acrobat.AcroAVDoc
Dim pdfField As Object 'AFORMAUTLib.Field
Dim PdfDoc As Acrobat.CAcroPDDoc
Dim pdf_form As Object 'AFORMAUTLib.AFormApp
myfullpath = "C:\Tester\mypdf.pdf"
myfullpath_edited = "C:\Tester\mypdf_edited.pdf"
myField = "Hello"
Set aApp = CreateObject("AcroExch.App")
Set av_doc = CreateObject("AcroExch.AVDoc")
Set pdf_form = CreateObject("AFORMAUT.App")
'aApp.Show
If av_doc.Open(myfullpath, "") Then
'av_doc.BringToFront
Set pdfField = pdf_form.Fields("pdfField")
pdfField.Value = myField 'set value in pdf
Set PdfDoc = av_doc.GetPDDoc '<<<<<<<<<<<<<<
PdfDoc.Save PDSaveFull, myfullpath_edited
av_doc.Close False
End If
aApp.Exit
Set aApp = Nothing
Set av_doc = Nothing
Set PdfDoc = Nothing
End Sub
Related
I simply need to open the drawing by using VBA of the active part. Drawing always has the exact same filename and location as the part. What I got is
Option Explicit
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swSelMgr As SldWorks.SelectionMgr
Dim swDocSpecification As SldWorks.DocumentSpecification
Dim sName As String
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swDocSpecification = swApp.GetOpenDocSpec("C:\Users\Public\Documents\SOLIDWORKS\SOLIDWORKS
2017\tutorial\AutoCAD\7550-021.slddrw")
sName = swDocSpecification.FileName
swDocSpecification.DocumentType = swDocDRAWING
swDocSpecification.ReadOnly = True
swDocSpecification.Silent = False
Set swModel = swApp.OpenDoc7(swDocSpecification)
longstatus = swDocSpecification.Error
longwarnings = swDocSpecification.Warning
End Sub
But it doesn't work probably because of the file location which may always be different depending on how the active part is named and where the active part is located.
Could someone please share a function to simply open the associated drawing of the part?
Try this:
Option Explicit
Sub main()
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.ModelDoc2
Dim swDocSpecification As SldWorks.DocumentSpecification
Dim FilePath As String
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then MsgBox "Open an assembly or part": Exit Sub
If swModel.GetType <> swDocumentTypes_e.swDocASSEMBLY And swModel.GetType <> swDocumentTypes_e.swDocPART Then MsgBox "Open an assembly or part": Exit Sub
Set swDocSpecification = swApp.GetOpenDocSpec(swModel.GetPathName)
FilePath = LCase(swModel.GetPathName)
FilePath = Replace(FilePath, ".sldprt", ".slddrw")
FilePath = Replace(FilePath, ".sldasm", ".slddrw")
swDocSpecification.FileName = FilePath
swDocSpecification.DocumentType = swDocumentTypes_e.swDocDRAWING
swDocSpecification.ReadOnly = True
swDocSpecification.Silent = True
Set swDraw = swApp.OpenDoc7(swDocSpecification)
swApp.ActivateDoc3 FilePath, False, swRebuildOnActivation_e.swRebuildActiveDoc, Empty
End Sub
i don't know why my code prints an error like "Object required" in line stpos = ARange.End
Public Function CreateNewWordDocument(TempPath)
Dim wd
Set App = CreateObject("Word.Application")
App.Visible = True
Set wd = App.Documents.Add(TempPath)
Set CreateNewWordDocument = wd
End Function
Public Function AddNewParagraphRange(ARange)
Dim NewParagraph
Dim NewRange
Dim I As Integer
I = ARange.Paragraphs.Count
ARange.InsertParagraphAfter
Set NewRange = ARange.Paragraphs(I).Range
NewRange.StartOf wdWord, wdMove
Set AddNewParagraphRange = NewRange
End Function
Public Sub RunForword(CurDBPath)
Dim R As Range
Set R = doc.Range
Dim aPart1
Dim aPart2
Dim aPart3
Set aPart1 = AddNewParagraphRange(R)
Set aPart2 = AddNewParagraphRange(R)
Set aPart3 = AddNewParagraphRange(R)
End Sub
Public Function WriteParagraphLn(ARange, text, StyleName) As Range
Dim stpos As Long
stpos = ARange.End
If Len(ARange) <= 2 Then
ARange.InsertAfter text
Else
ARange.InsertParagraphAfter
ARange.Document.Range(ARange.End, ARange.End + 1).Style = wdNormalStyleName
ARange.InsertAfter text
End If
If StyleName <> "" Then _
ARange.Document.Range(stpos, ARange.End).Style = StyleName
Set WriteParagraphLn = ARange.Document.Range(stpos, ARange.End)
End Function
Sub Creat_doc()
Dim TempPath As String
Dim doc
Set doc = CreateNewWordDocument(TempPath)
With doc
.PageSetup.TopMargin = CentimetersToPoints(2)
.PageSetup.BottomMargin = CentimetersToPoints(1.5)
End With
doc.Activate
Dim TextLine As String
TextLine = WriteParagraphLn("", "hello world", "Times New Roman")
doc.TypeText text:=TextLine
End Sub
I have a question regarding the following code. The code now works, but did not until I set the Variables to nothing (see the part with the *** in the code). I got all kinds of error-messages (e.g. "462 The remote server machine does not exist or is unavailable")
My question is: Why do I have to Set those Variables to nothing? I guess it has something to do with the fact that I use a loop right?
Thanks in advance!
Sub Saveas_PDF()
Dim PP As PowerPoint.Presentation
Dim prs As PowerPoint.Presentation
Dim Sl As PowerPoint.Slide
Dim sh As Variant
Dim company As String
Set Dropdown.ws_company = Tabelle2
company = Dropdown.ws_company.Range("C2").Value
Dim strPOTX As String
Dim strPfad As String
Dim pptApp As Object
Call filepicker
Dim Cell As Range
For Each Cell In Dropdown.ws_company.Range(Dropdown.ws_company.Cells(5, 3),
Dropdown.ws_company.Cells(Rows.Count,
3).End(xlUp)).SpecialCells(xlCellTypeVisible)
Dropdown.ws_company.Range("C2") = Cell
Set pptApp = New PowerPoint.Application
Dim pptVorlage As String
pptVorlage = myfilename
Set PP = pptApp.Presentations.Open(pptVorlage)
PP.UpdateLinks 'Datei --> Informationen --> Verknüpfungen --> Automatisch
aktualisieren Haken setzen
Dim newpath As String
newpath = Replace(myfilename, "AXO", "" & Cell & " AXO")
Dim newpathpdf As String
newpathpdf = Replace(newpath, "pptx", "pdf")
PP.ExportAsFixedFormat "" & newpathpdf & "", ppFixedFormatTypePDF,
ppFixedFormatIntentPrint
pptApp.Visible = True
Debug.Print (PP.Name)
AppActivate (PP.Name)
PP.Close
***Set pptApp = Nothing
Set PP = Nothing***
Next
Set pptApp = New PowerPoint.Application
If IsAppRunning("PowerPoint.Application") Then
If pptApp.Windows.Count = 0 Then
pptApp.Quit
End If
End If
End Sub
Maybe because you are calling the constructor "New" inside de loop in the line: Set pptApp = New PowerPoint.Application
Move the line "Set pptApp = New PowerPoint.Application" before de foreach and try it.
Im trying to download attachment from certain Lotus Notes e-mails. The code below works but it goes in infinite loop (code execution never ends after the procedure) after saving all required files. Something is wrong with Do until command I guess. Would appreaciate some help in fixing this issue.
Sub Test2Dobre()
Dim sess As Object
Dim db As Object
Dim view As Object
Dim doc As Object
Dim docNext As Object
Dim mailServer As String
Dim mailFile As String
Dim fld1 As String
Dim strSQL As String
Const stPath As String = "C:\Users\kuckam\Desktop\test notes\"
Const EMBED_ATTACHMENT As Long = 1454
Const RICHTEXT As Long = 1
Dim vaItem As Variant
Dim vaAttachment As Variant
Set sess = CreateObject("Notes.NotesSession")
'Call sess.Initialize(Password)
Dim objADOConnection As Object
Set objADOConnection = CreateObject("ADODB.Connection")
'to get your mail db:
mailServer = sess.GetEnvironmentString("MailServer", True)
mailFile = sess.GetEnvironmentString("MailFile", True)
Set db = sess.GetDatabase(mailServer, mailFile)
'Get Inbox folder:
Set view = db.GetView("($Inbox)")
'Loop through all documents in Inbox:
Set doc = view.GetFirstDocument
Do Until doc Is Nothing
Set docNext = view.GetNextDocument(doc)
If doc.HasEmbedded And doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
MsgBox doc.GetItemValue("subject")(0)
'MsgBox doc.GetItemValue("From")(0)
'Check if the document has an attachment or not.
Set vaItem = doc.GetFirstItem("Body")
If vaItem.Type = RICHTEXT Then
For Each vaAttachment In vaItem.EmbeddedObjects
If vaAttachment.Type = EMBED_ATTACHMENT Then
'Save the attached file into the new folder and remove it from the e-mail.
With vaAttachment
.ExtractFile stPath & vaAttachment.Name
' .Remove
End With
End If
Next vaAttachment
End If
End If
Set doc = docNext
Loop
End Sub
EDIT:
Posting working code:
Function ADOExecSQL(strSQL As String)
ADOExecSQL = 1
On Error GoTo ERROR_FUNCTION
If ADODbConnect() = 0 Then GoTo ERROR_FUNCTION
cnConn.Execute strSQL
EXIT_FUNCTION:
Exit Function
ERROR_FUNCTION:
ADOExecSQL = 0
GoTo EXIT_FUNCTION
End Function
Sub Test2Dobre()
Dim sess As Object
Dim db As Object
Dim view As Object
Dim doc As Object
Dim docNext As Object
Dim mailServer As String
Dim mailFile As String
Dim fld1 As String
Dim strSQL As String
Const stPath As String = "C:\Users\kuckam\Desktop\test notes\"
Const EMBED_ATTACHMENT As Long = 1454
Const RICHTEXT As Long = 1
Dim vaItem As Variant
Dim vaAttachment As Variant
Set sess = CreateObject("Notes.NotesSession")
'Call sess.Initialize(Password)
Dim objADOConnection As Object
Set objADOConnection = CreateObject("ADODB.Connection")
'to get your mail db:
mailServer = sess.GetEnvironmentString("MailServer", True)
mailFile = sess.GetEnvironmentString("MailFile", True)
Set db = sess.GetDatabase(mailServer, mailFile)
'Get Inbox folder:
Set view = db.GetView("($Inbox)")
view.AutoUpdate = False
'Loop through all documents in Inbox:
Set doc = view.GetFirstDocument
Do Until doc Is Nothing
Set docNext = view.GetNextDocument(doc)
'If doc.HasEmbedded And doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
'If doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
'MsgBox doc.GetItemValue("subject")(0)
'MsgBox doc.GetItemValue("From")(0)
'Check if the document has an attachment or not.
Set vaItem = doc.GetFirstItem("Body")
On Error GoTo Line1
If vaItem.Type = RICHTEXT And doc.GetItemValue("From")(0) = "<Protokoly.warszawa#linde-mh.pl>" Then
For Each vaAttachment In vaItem.EmbeddedObjects
If vaAttachment.Type = EMBED_ATTACHMENT Then
'Save the attached file into the new folder and remove it from the e-mail.
With vaAttachment
.ExtractFile stPath & vaAttachment.Name
' .Remove
End With
End If
'Save the e-mail in order to reflect the deleting of the attached file.
'(A more sophisticated approach may be considered if several e-mails have
'several attachments in order to avoid a repeately saving of one e-mail.)
doc.Save True, False
Next vaAttachment
End If
'End If
'Call Attachment.ExtractFile("C:\Users\kuckam\Desktop\test notes")
'Call doc.PutInFolder("C:\Users\kuckam\Desktop\test notes")
Set doc = docNext
Loop
'Release objects from memory.
Set docNext = Nothing
Set doc = Nothing
Set view = Nothing
Set sess = Nothing
Set db = Nothing
Set objADOConnection = Nothing
Set vaItem = Nothing
Line1:
End Sub
I started to write a code, but I don't know what I need to write in the variable objContact to select an item contact in the folder.
I tried:
sFilter = "[CompanyName= 'BEIS'"
Set objContact = objContactsFolder.Items.Find(sFilter)
objContact.Delete
Currently my code looks like that:
Sub ChangeCompanyName()
Dim objContactsFolder 'As Outlook.MAPIFolder
Dim objContacts 'As Outlook.Items
Dim strCo 'As String
Dim objContact 'As Object
Dim iCount 'As Integer
' Set
Set objOutlook = CreateObject("Outlook.Application")
Set objNameS = objOutlook.GetNamespace("MAPI")
Set objContactsFolder = objNameS.GetDefaultFolder(olContactItem)
Set objContacts = objContactsFolder.Items
' Delete Contact if company names = strCo
strCo = "BEIS"
Set objContact = ???
For Each objContact In objContacts
If TypeName(objContact) = "ContactItem" Then
If objContact.CompanyName = strCo Then
objContact.Delete
End If
End If
Next
' Clean up
Set objContact = Nothing
Set objContacts = Nothing
Set objContactsFolder = Nothing
End Sub
Your filter is wrong. You are missing "]":
sFilter = "[CompanyName] = 'BEIS'"