Compile Assembly Drawings

emanuel.c · ‎05-30-2024

Here is some code to compile All Drawings of an assembly if it is useful to anyone else.

Our drawings are split into 2 folders:

- Assembly / Weldment Drawings which include .dwg and .pdf files

- Parts Drawings which include .dwg and .pdf files

What I needed was to tag along all SubAssemblies, Weldments and Parts to the main Assembly or Weldment Drawing. The code also compiles All loose components based on Stock Size, Machining Details, etc. If this is your Drawings layout, this may be useful to Compile Drawings.

I'm using the itextsharp.dll which works very well but is limited to compiling every PDF it finds in one folder into a new PDF. So everything has to be placed in respective folders, compiled, copied out and the folders deleted. In the end the result is great. You must have the itextsharp.dll copied somewhere and the first line of the code pointing to it! I attached the .zip with itextsharp.dll here. Most of the kudos goes to these posts: https://forums.autodesk.com/t5/inventor-programming-ilogic/merging-pdfs-using-ilogic/m-p/10645561#M1...

You can comment out options you don't need, like Compiling ALL drawings into one massive one etc. The parts are picked on the basis of part number (7 or 8 thousands) or iProperty "Product". This could be edited out.

Thanks!

emanuel.c · ‎06-18-2024

AddReference "M:\Autodesk Inventor\Ilogic\itextsharp\itextsharp.dll"
AddReference "System.IO"
AddReference "System.Private.Uri"
Option Explicit Off

Public Class CompileVariables
	Dim DrawingsFolder As String = ""
	
Sub Main()
		
	If ThisApplication.ActiveDocumentType <> DocumentTypeEnum.kAssemblyDocumentObject Then
		MessageBox.Show("Run this rule from an Assembly document!", "Error!")
		Exit Sub
	End If
		
	Dim oDoc As Inventor.AssemblyDocument = ThisApplication.ActiveDocument	
	
	' Define CompiledFolder and Subfolders. Call Functions	
	
	If GetWorkFolder = True Then
		
		RUsure = MessageBox.Show (DrawingsFolder _
		& vbLf & "" _
		& vbLf & "" _
		& vbLf & "Continue to Compile?", "Here is your Drawings folder:", MessageBoxButtons.OKCancel, MessageBoxIcon.Stop)
		
		If RUsure = vbCancel Then Exit Sub		
			
		CreateCompiled	
		C_F
		
		' Compile_All_LOOSE_PARTS Together
		Compile_All_Parts_Drawings
		
		' Compile ALL ASSEMBLIES AND WELDMENTS Together
		Compile_All_Asm_Drawings
		
		' Call Sub to Compile Individual Parts, like Burned, Sawed, Machined etc.
		WorkOnParts(oDoc)
		
		' Call Sub to Compile Assemblies / Weldments
		WorkOnAssemblies(oDoc)
		
		' Call function to compile subfolders etc.
		Run_Compiler
		
		MessageBox.Show("Yaaaaay!! Compiling Completed!", "", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)		
	
	End If
	
End Sub

' Define additional project description
Public Function ProjectName As String
	Dim Year As Double = Now.Year
	Dim Month As Double = Now.Month
	Dim Day As Double = Now.Day
	Dim oMonth As String
	Dim oDay As String
	
	If Month < 10 Then
		oMonth = "0" & Month
	Else
		oMonth = Month
	End If	
	
	If Day < 10 Then
		oDay = "0" & Day
	Else
		oDay = Day
	End If		
		
	Dim oDate As String = Year & "." & oMonth & "." & oDay	
	Dim oProject As String = "Drawing's Name - " & oDate
	Return oProject
	
End Function

#Region "Define Folders"

Public Function GetWorkFolder As Boolean
		
	DrawingsFolder = "Insert Folder with Drawings HERE"
	Return True
	'MessageBox.Show(FolderPath)	
	
End Function

' Define Parts Folder
Public Function P_Folder As String
	Dim oFolder As String = DrawingsFolder & "\Individual Components"
	If Not System.IO.Directory.Exists(oFolder) Then
		MessageBox.Show("Can't find an Individual Parts folder", "Error!")		
	End If
	Return oFolder
End Function

' Define Assembly Folder
Public Function A_Folder As String
	Dim oFolder As String = DrawingsFolder & "\Assemblies - Weldments"
	If Not System.IO.Directory.Exists(oFolder) Then
		MessageBox.Show("Can't find an Assemblies - Weldments folder", "Error!")		
	End If
	Return oFolder
End Function

' Define Compiled Folder
Public Function C_F As String
	' Define Location of Compiled folder
	' Must NOT be a subfolder of DrawingsFolder since code reads DrawingsFolder's subfolders too
	Dim oFolder As String = DrawingsFolder & "\Compiled"
	Return oFolder
End Function

' Delete / Create Compiled folder - so as to overwrite it
Public Sub CreateCompiled
	Dim oBrowserPane As BrowserPane = Nothing
	If System.IO.Directory.Exists(C_F) Then
		IO.Directory.Delete(C_F, True)		
		System.IO.Directory.CreateDirectory(C_F)
	Else
		System.IO.Directory.CreateDirectory(C_F)
	End If
End Sub

' Define ALL Individual Components Folder
Public Function C_All_Parts As String
	Dim oFolder As String = C_F & "\Compiled - " & ProjectName & " - ALL Individual Components"
	If Not System.IO.Directory.Exists(oFolder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(oFolder)
	End If
	Return oFolder
End Function

' Define ALL Assemblies and Weldments Folder
Public Function C_All_Asm As String
	Dim oFolder As String = C_F & "\Compiled - " & ProjectName & " - ALL Assemblies and Weldments"
	If Not System.IO.Directory.Exists(oFolder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(oFolder)
	End If
	Return oFolder
End Function

' Define ALL Burned Folder
Public Function C_B As String
	Dim oFolder As String = C_F & "\Compiled - " & ProjectName & " - Burned"
	If Not System.IO.Directory.Exists(oFolder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(oFolder)
	End If
	Return oFolder
End Function

' Define ALL Burned and Bent Folder
Public Function C_BB As String
	Dim oFolder As String = C_F & "\Compiled - " & ProjectName & " - Burned and Bent - ALL"
	If Not System.IO.Directory.Exists(oFolder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(oFolder)
	End If
	Return oFolder
End Function

' Define ALL Burned and Handworked Folder
Public Function C_BH As String
	Dim oFolder As String = C_F & "\Compiled - " & ProjectName & " - Burned and Handworked - ALL"
	If Not System.IO.Directory.Exists(oFolder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(oFolder)
	End If
	Return oFolder
End Function

' Define Burned and Machined Folder
Public Function C_BM As String
	Dim oFolder As String = C_F & "\Compiled - " & ProjectName & " - Burned and Machined"
	If Not System.IO.Directory.Exists(oFolder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(oFolder)
	End If
	Return oFolder
End Function

' Define Sawed Parts Folder
Public Function C_S As String
	Dim oFolder As String = C_F & "\Compiled - " & ProjectName & " - Sawed"
	If Not System.IO.Directory.Exists(oFolder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(oFolder)
	End If
	Return oFolder
End Function

' Define Sawed and Handworked Folder
Public Function C_SH As String
	Dim oFolder As String = C_F & "\Compiled - " & ProjectName & " - Sawed and Handworked"
	If Not System.IO.Directory.Exists(oFolder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(oFolder)
	End If
	Return oFolder
End Function

' Define Sawed and Machined Folder
Public Function C_SM As String
	Dim oFolder As String = C_F & "\Compiled - " & ProjectName & " - Sawed and Machined"
	If Not System.IO.Directory.Exists(oFolder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(oFolder)
	End If
	Return oFolder
End Function

' Define Round and DOM Folder
Public Function C_R As String
	Dim oFolder As String = C_F & "\Compiled - " & ProjectName & " - Round and DOM"
	If Not System.IO.Directory.Exists(oFolder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(oFolder)
	End If
	Return oFolder
End Function

#End Region

' Copy ALL assemblies and weldments Drawings together
Public Sub Compile_All_Asm_Drawings
	
	' COMPILE ASSEMBLY DRAWINGS
	Dim Afiles() As String = System.IO.Directory.GetFiles(A_Folder, "*.pdf", System.IO.SearchOption.AllDirectories) 'AllDirectiories = Subfolders too
	
	For Each oFile In Afiles
		oPDFname = Right(oFile, Len(oFile) - InStrRev(oFile, "\"))
		oCopyPath_all_asm = C_All_Asm & "\" & oPDFname
		FileCopy(oFile, oCopyPath_all_asm)
	Next
End Sub

' Copy ALL loose parts Drawings together
Public Sub Compile_All_Parts_Drawings
	
	Dim Pfiles() As String = System.IO.Directory.GetFiles(P_Folder, "*.pdf", System.IO.SearchOption.AllDirectories) 'AllDirectiories = Subfolders too

	Dim i As Integer = Pfiles.count
	Dim max_files As Integer = 300
	Dim oCopyPath_Parts As String
	
	If i < max_files Then
	
		For Each oFile In Pfiles
			oPDFname = Right(oFile, Len(oFile) - InStrRev(oFile, "\"))
			oCopyPath_Parts = C_All_Parts & "\" & oPDFname
			FileCopy(oFile, oCopyPath_Parts)
		Next
	Else
		
		' SPLIT drawings into 2 folders to make it accessible to Compiler
		Dim destFolder1, destFolder2 As String
		destFolder1 = C_F & "\" & "1P"
		destFolder2 = C_F & "\" & "2P"		
		System.IO.Directory.CreateDirectory(destFolder1)
		System.IO.Directory.CreateDirectory(destFolder2)
		Dim j As Integer = 0
		
		For Each oFile In Pfiles
			j = j + 1
			If j < max_files     
				oPDFname = Right(oFile, Len(oFile) - InStrRev(oFile, "\"))
				oCopyPath_Parts = destFolder1 & "\" & oPDFname
				FileCopy(oFile, oCopyPath_Parts)
			End If
		Next
		
		j = 1
		For Each oFile In Pfiles
			j = j + 1
			If j > max_files     
				oPDFname = Right(oFile, Len(oFile) - InStrRev(oFile, "\"))
				oCopyPath_Parts = destFolder2 & "\" & oPDFname
				FileCopy(oFile, oCopyPath_Parts)
			End If
		Next		
	
		Call Run_Compiler
		
		' Copy these 2 PDFs in C_All_Asm to Compile
		Dim oPDF1 As String = C_F & "\1P.pdf"
		Dim oPDF2 As String = C_F & "\2P.pdf"
		
		System.IO.Directory.CreateDirectory(C_All_Parts)
		oCopy_1 = C_All_Parts & "\1P.pdf"
		oCopy_2 = C_All_Parts & "\2P.pdf"
		System.IO.File.Move(oPDF1, oCopy_1)
		System.IO.File.Move(oPDF2, oCopy_2)
		
	End If

End Sub
	

Public Sub WorkOnParts(ByVal oDoc)
		
	C_All_Parts
	C_All_Asm
	C_B
	C_BB
	C_BM
	C_S
	C_SM
	C_SH
	C_R
	
	If oDoc.AllReferencedDocuments.Count = 0 Then Exit Sub
		
	' Iterate through all parts in assembly
	' Copy pdf drawings into various folders
	' Here working on individual components only
	For Each oRefDoc As Inventor.Document In oDoc.AllReferencedDocuments
		'Avoid parts with following properties
		If oRefDoc.ComponentDefinition.Document.IsModifiable = False Then Continue For			
		'If oRefDoc.ComponentDefinition.Suppressed Then Continue For
		If TypeOf oRefDoc.ComponentDefinition Is VirtualComponentDefinition Then Continue For
		If oRefDoc.DocumentType = kAssemblyDocumentObject Then Continue For
		If oRefDoc.ComponentDefinition.BOMStructure <> BOMStructureEnum.kNormalBOMStructure Then Continue For
	
		CopyPartDrawings(oRefDoc)

	Next

End Sub

' Copy Individual Parts Drawings
Public Sub CopyPartDrawings(oRefDoc)
				
	' Get the PropertySets object.
	Dim oPropSets As PropertySets = oRefDoc.PropertySets
	' Get the design tracking property set.
	Dim oPropSet As PropertySet = oPropSets.Item("Design Tracking Properties")
	' Get the part number iProperty		
	Dim oPartName As String = oRefDoc.PropertySets("Design Tracking Properties").Item("Part Number").Value
	' Get the description iProperty
	Dim odescr As String = oRefDoc.PropertySets("Design Tracking Properties").Item("Description").Value
	'MessageBox.Show(oPartName)
	
	' Search PDFs for only part numbers 7000 and 8000
	Dim noshow As String
	
	If Left(oPartName, 1) = "7" Or Left(oPartName, 1) = "8" Then
	
			' get Product Number
		Try
			oProdNum = oRefDoc.PropertySets("Inventor User Defined Properties").Item("Product").Value
		Catch
			oProdNum = "x"
			'MessageBox.Show(oProdNum, "Product Number")
		End Try
		
		' get Machine Detail
		Try
			oMachine = oRefDoc.PropertySets("Inventor User Defined Properties").Item("Machined").Value
		Catch
			oMachine = ""
		End Try
		
		' get HandWork Detail
		Try
			oHandwork = oRefDoc.PropertySets("Inventor User Defined Properties").Item("Handwork").Value
		Catch
			oHandwork = ""
		End Try
		
		Dim files() As String = System.IO.Directory.GetFiles(P_Folder, "*.pdf", System.IO.SearchOption.AllDirectories) 'AllDirectiories = Subfolders too
		For Each oFile In files
			Dim oFileName As String = oFile
			If oFileName.Contains(oPartName) Then
				'get the PDF name				
				oPartPDFname = Right(oFileName, Len(oFileName) - InStrRev(oFileName, "\"))					
				OriginalPath = oFileName
				Exit For
			Else
				noshow = "none"
			End If
		Next
	
	Else
		
		If noshow = "none" Then
			MessageBox.Show("No drawing found for part: " & oPartName)
			Exit Sub
		End If
		
	End If
	
	Select Case oProdNum
		Case "01"
			' Copy all Sheet Metal and Plate parts
			Dim oCopyPath1 As String = C_B & "\" & oPartPDFname
			If Not IO.File.Exists(oCopyPath1) Then
				'Messagebox.show(oPartName & vbLf & vbLf & OriginalPath & vblf & vblf & oCopyPath1, "Working on Part:")
				FileCopy(OriginalPath, oCopyPath1)
			End If
			
			' Copy all Sheet Metal to be Machined
			If oMachine = "" Then 'do nothing
			Else
				Dim oCopyPath2 As String = C_BM & "\" & oPartPDFname
				If Not IO.File.Exists(oCopyPath2) Then
					FileCopy(OriginalPath, oCopyPath2)
				End If
			End If
			
			' Copy all Sheet Metal to be Handworked
			If oHandwork  = "" Then 'do nothing
			Else
				Dim oCopyPath2 As String = C_BH & "\" & oPartPDFname
				If Not IO.File.Exists(oCopyPath2) Then
					FileCopy(OriginalPath, oCopyPath2)
				End If
			End If			
			
			' Copy all Sheet Metal to be Bent				
			Dim oSMCD As SheetMetalComponentDefinition = oRefDoc.ComponentDefinition
			If oSMCD.Bends.Count > 0 Then
				
				Dim oCopyPath3 As String = C_BB & "\" & oPartPDFname
				If Not IO.File.Exists(oCopyPath3) Then
					FileCopy(OriginalPath, oCopyPath3)
				End If
				
				Dim oThk As Double = FormatNumber(CDbl(oSMCD.Thickness.Value / 2.54), 4)
				'MessageBox.Show(oThk)
				Dim Thk_folder As String = C_F & "\Compiled - " & ProjectName & " - Burned and Bent - " & oThk & " Thk"
				If Not System.IO.Directory.Exists(Thk_folder) Then
					Dim oBrowserPane As BrowserPane = Nothing
					System.IO.Directory.CreateDirectory(Thk_folder)
				End If
				Dim oCopyPath4 As String = Thk_folder & "\" & oPartPDFname
				If Not IO.File.Exists(oCopyPath4) Then
					FileCopy(OriginalPath, oCopyPath4)
				End If				
				
			End If		
		
		Case "02", "03", "04", "05", "06", "07", "08", "09"
			' Copy all Sawed Parts
			Dim oCopyPath1 As String = C_S & "\" & oPartPDFname
			If Not IO.File.Exists(oCopyPath1) Then
				FileCopy(OriginalPath, oCopyPath1)
			End If
			
			' Copy all Sheet Metal to be Machined
			If oMachine = "" Then 'do nothing
			Else
				Dim oCopyPath2 As String = C_SM & "\" & oPartPDFname
				If Not IO.File.Exists(oCopyPath2) Then
					FileCopy(OriginalPath, oCopyPath2)
				End If
			End If
			
			' Copy all Sheet Metal to be Machined
			If oHandwork = "" Then 'do nothing
			Else
				Dim oCopyPath3 As String = C_SH & "\" & oPartPDFname
				If Not IO.File.Exists(oCopyPath3) Then
					FileCopy(OriginalPath, oCopyPath3)
				End If
			End If				
			
	End Select
	
	Select Case oProdNum
		Case "02", "08"
			' Copy all Round and DOM / Bushing Parts
			Dim oCopyPath1 As String = C_R & "\" & oPartPDFname
			If Not IO.File.Exists(oCopyPath1) Then
				FileCopy(OriginalPath, oCopyPath1)
			End If
	End Select

End Sub

Public Sub WorkOnAssemblies(ByVal oDoc)
	
	If oDoc.AllReferencedDocuments.Count = 0 Then Exit Sub
		
	' Iterate through all parts in assembly
	' Copy pdf drawings into various folders
	' Here working on Compiling ASSEMBLIES
	
	Dim oSubAsmName, oDocName As String
	
	For Each oRefDoc As Inventor.Document In oDoc.AllReferencedDocuments
		'Avoid parts with following properties
		If oRefDoc.ComponentDefinition.BOMStructure <> BOMStructureEnum.kNormalBOMStructure Then Continue For
		If oRefDoc.ComponentDefinition.Document.IsModifiable = False Then Continue For			
		'If oRefDoc.ComponentDefinition.Suppressed Then Continue For
		If TypeOf oRefDoc.ComponentDefinition Is VirtualComponentDefinition Then Continue For
		If oRefDoc.DocumentType = kPartDocumentObject Then Continue For
		
		oThisDocName = iProperties.Value(oDoc, "Project", "Part Number")		
		oSubAsmName = oRefDoc.PropertySets.Item("Design Tracking Properties").Item("Part Number").Value
		
		'MessageBox.Show(oSubAsmName & " of: " & oThisDocName, "Sub-Assembly:")		
				
		If CheckSubfolderName(oSubAsmName) = "" Then
			Call PrepareDrawings(oRefDoc, oSubAsmName)
		End If

	Next

End Sub

Private Sub PrepareDrawings(ByVal oRefDoc As Document, ByVal oAsmPN As String)
	
	If oAsmPN = "" Then Exit Sub
	'MessageBox.Show(oAsmPN, "Processing Drawings for Assembly:")	
	
	Dim oAfiles() As String = System.IO.Directory.GetFiles(A_Folder, "*.pdf", System.IO.SearchOption.TopDirectoryOnly)
	Dim oPfiles() As String = System.IO.Directory.GetFiles(P_Folder, "*.pdf", System.IO.SearchOption.TopDirectoryOnly)
	
	Dim oAsmPDFname As String
	Dim OriginalPath_A As String
	Dim OriginalPath_P As String
	
	Dim oFound As Boolean = False
	For Each oFile In oAfiles			
		If oFile.Contains(oAsmPN) Then
			oFound = True
			OriginalPath_A = oFile
			oAsmPDFext = Right(oFile, Len(oFile) - InStrRev(oFile, "\"))
			oAsmPDFname = Left(oAsmPDFext, Len(oAsmPDFext)-4) 'remove .pdf extension
			Exit For
		End If
	Next	
	
	If oFound = False Then		
		MessageBox.Show("Part Number:  " & oAsmPN & vbLf & vbLf & "Continuing", "Assembly Missing Drawings", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
		Exit Sub
	End If
	
	' See if Assembly has already been compiled
	
	Dim Asm_folder As String = C_F & "\Compiled - " & oAsmPDFname
	
	If Not System.IO.Directory.Exists(Asm_folder) Then
		Dim oBrowserPane As BrowserPane = Nothing
		System.IO.Directory.CreateDirectory(Asm_folder)
	Else
		' No need to create, it already was created
		Exit Sub
	End If
	
	' Copy this file's PDF
	' Rename it such that it compiles first in PDF
	Dim oCopyPath1 As String = Asm_folder & "\" & "0000.pdf"
	If Not IO.File.Exists(oCopyPath1) Then
		FileCopy(OriginalPath_A, oCopyPath1)
	End If	
	
	For Each oSubRefDoc As Inventor.Document In oRefDoc.AllReferencedDocuments
		' Get subcomponent Part Number
		Dim oPN As String
		oPN = oSubRefDoc.PropertySets.Item("Design Tracking Properties").Item("Part Number").Value		
		'MessageBox.Show(oPN & " of: " & oAsmPN, "Sub-Assembly:")
	
		'Avoid parts with following properties
		If oRefDoc.ComponentDefinition.BOMStructure <> BOMStructureEnum.kNormalBOMStructure Then Continue For
		If oRefDoc.ComponentDefinition.Document.IsModifiable = False Then Continue For			
		'If oRefDoc.ComponentDefinition.Suppressed Then Continue For
		If TypeOf oRefDoc.ComponentDefinition Is VirtualComponentDefinition Then Continue For
		
		Dim oPartPDFname As String
		
		If oSubRefDoc.DocumentType = kPartDocumentObject Then
		' for parts
			If Left(oPN, 1) = "7" Or Left(oPN, 1) = "8" Then 'get only part numbers 7000 and 8000		
				For Each pFile In oPfiles
					If pFile.Contains(oPN) Then
						'MessageBox.Show(pFile, "Component Path:")	
						OriginalPath_P = pFile
						oPartPDFext = Right(pFile, Len(pFile) -InStrRev(pFile, "\"))
						Dim oCopyPath2 As String = Asm_folder & "\" & oPartPDFext
						If Not IO.File.Exists(oCopyPath2) Then
							FileCopy(OriginalPath_P, oCopyPath2)
						End If	
						Exit For
					End If
				Next
			Else
			End If
		Else
			' for assemblies / weldments
			For Each pFile In oAfiles
				If pFile.Contains(oPN) Then
					'MessageBox.Show(pFile, "Component Path:")	
					OriginalPath_P = pFile					
					oPartPDFext = Right(pFile, Len(pFile) - InStrRev(pFile, "\"))
					Dim oCopyPath2 As String = Asm_folder & "\" & oPartPDFext
						If Not IO.File.Exists(oCopyPath2) Then
							FileCopy(OriginalPath_P, oCopyPath2)
						End If	
						Exit For
				End If
			Next
		End If
	Next		
	
End Sub

' Check to see if Compiled Sub Folder already exists
' In this case, no need to recreate it / add another one
' For cases in which a Sub Assembly occurs in other Assemblies
Private Function CheckSubfolderName(oSubAsmName) As String
	Dim FSO As Object
	Dim ParentFolder As Object
	Dim Subfolder As Object
	Dim CharToFind As String
	Dim Found As Boolean
	
	' Specify the character to find in the subfolder name
	CharToFind = oSubAsmName
	Found = False
	
	' Create a FileSystemObject
	FSO = CreateObject("Scripting.FileSystemObject")
	
	' Get the parent folder
	ParentFolder = FSO.GetFolder(C_F)
	
	' Loop through each subfolder in the parent folder
	For Each Subfolder In ParentFolder.subfolders
		' Check if the subfolder name contains the specified characters
		If InStr(1, Subfolder.Name, CharToFind, vbTextCompare) > 0 Then
			Found = True
			Exit For
		End If
	Next Subfolder
		
	If Found Then
		Return Subfolder.Name
	Else
		Return ""
	End If    

End Function
		
Sub Run_Compiler
    Dim MyFSO As Object
    Dim ParentFolder As Object
    Dim Subfolder As Object
	Dim FolderPath As String
	Dim EmptyFlag As Boolean
    
    ' Create a FileSystemObject instance
    MyFSO = CreateObject("Scripting.FileSystemObject")
    
    ' Specify the path of the parent folder you want to iterate through
    ParentFolder = MyFSO.GetFolder(C_F)
    
    ' Loop through each subfolder in the parent folder
    For Each Subfolder In ParentFolder.SubFolders
		EmptyFlag = True
		For Each File In Subfolder.Files
			EmptyFlag = False
			Exit For
		Next File
		
		' Delete the subfolder if it is empty
        If EmptyFlag = True Then
            SubFolderName = Subfolder.Path
            MyFSO.DeleteFolder(SubFolderName)
            
        End If
        'MessageBox.Show(Subfolder.Name)
    Next Subfolder
	
	' Loop through each subfolder in the parent folder
    For Each Subfolder In ParentFolder.SubFolders
		'MessageBox.Show(Subfolder.Path)
		Dim oFolderPath As String = Subfolder.Path
		Dim oFolderName As String = Subfolder.Name
		' Call Compiler
		CreatePDF(oFolderPath, oFolderName)
    Next Subfolder
	
	' Delete all Temp Folder
	For Each Subfolder In ParentFolder.SubFolders
		SubFolderName = Subfolder.Path
		MyFSO.DeleteFolder(SubFolderName)
    Next Subfolder
	
End Sub

Sub CreatePDF(oFolderPath, oFolderName)

	' set the path of the folder contaiing all of the pdfs
	Dim _Path As String = oFolderPath

	' set the name of the new pdf you want to create without the extension
	Dim _Name As String = oFolderName

	' get the result, it will be either the path of the PDF or FALSE
	Dim MakePDF As New MergePDF(_Path, _Name)
	
	' copy file to parent folder
	Dim CompiledPath As String = oFolderPath & "\" & oFolderName & ".pdf"
	Dim CopyPath As String = C_F & "\" & oFolderName & ".pdf"
	FileCopy(CompiledPath, CopyPath)	

End Sub

Public Class MergePDF


#Region "PRIVATE PROPERTIES"
    Private Property _Folder_Path As String = String.Empty
    Private Property _PDF_Name As String = Nothing
    Private Property _GetPDF As String = String.Empty
#End Region

#Region "FRIEND PROPERTIES THAT YOU CALL BACK"
    Friend Property GetPDF As String
        Set(value As String)
            _GetPDF = value
        End Set
        Get
            Return _GetPDF
        End Get
    End Property

#End Region

#Region "CONSTRUCTORS"
    Public Sub New(ByVal _folderpath As String, ByVal _pdfname As String)

        ' set the pdf Folder path
        _Folder_Path = _folderpath

        ' set the pdf name
        _PDF_Name = _pdfname

        ' create the PDF and set the path
        _GetPDF = CreatePDF(_Folder_Path)
    End Sub

#End Region

#Region "HELPERS"
    Private Function CreatePDF(ByVal sFolderPath) As String

        Dim bOutputfileAlreadyExists As Boolean = False
        Dim sOutFilePath As String = IO.Path.Combine(sFolderPath, _PDF_Name & ".pdf")

        ' set up return for a successful pdf. ret changes to FALSE if any errors occur for qualifying purposes
        Dim ret As String = sOutFilePath

        If IO.File.Exists(sOutFilePath) Then
            Try
                IO.File.Delete(sOutFilePath)
            Catch ex As Exception
                bOutputfileAlreadyExists = True
            End Try
        End If

        Dim iPageCount As Integer = GetPageCount(sFolderPath)
        If iPageCount > 0 And bOutputfileAlreadyExists = False Then

            Dim oFiles As String() = IO.Directory.GetFiles(sFolderPath)
            Dim oPdfDoc As New iTextSharp.text.Document()
            Dim oPdfWriter As iTextSharp.text.pdf.PdfWriter = iTextSharp.text.pdf.PdfWriter.GetInstance(oPdfDoc, New IO.FileStream(sOutFilePath, IO.FileMode.Create))

            oPdfDoc.Open()

            System.Array.Sort(Of String)(oFiles)

            For i As Integer = 0 To oFiles.Length - 1
                Dim sFromFilePath As String = oFiles(i)
                Dim oFileInfo As New IO.FileInfo(sFromFilePath)
                Dim sFileType As String = "PDF"
                Dim sExt As String = PadExt(oFileInfo.Extension)

                Try
                    AddPdf(sFromFilePath, oPdfDoc, oPdfWriter)
                Catch ex As Exception
                    ret = "FALSE"
                End Try
            Next

            Try
                oPdfDoc.Close()
                oPdfWriter.Close()
            Catch ex As Exception

                Try
                    IO.File.Delete(sOutFilePath)
                Catch ex2 As Exception
                End Try
            End Try
        End If

        Dim oFolders As String() = IO.Directory.GetDirectories(sFolderPath)
        For i As Integer = 0 To oFolders.Length - 1
            Dim sChildFolder As String = oFolders(i)
            Dim iPos As Integer = sChildFolder.LastIndexOf("\")
            Dim sFolderName As String = sChildFolder.Substring(iPos + 1)
            CreatePDF(sChildFolder)
        Next

        Return ret

    End Function

    Private Sub AddPdf(ByVal sInFilePath As String, ByRef oPdfDoc As iTextSharp.text.Document, ByRef oPdfWriter As iTextSharp.text.pdf.PdfWriter)

        Dim oDirectContent As iTextSharp.text.pdf.PdfContentByte = oPdfWriter.DirectContent
        Dim oPdfReader As iTextSharp.text.pdf.PdfReader = New iTextSharp.text.pdf.PdfReader(sInFilePath)
        Dim iNumberOfPages As Integer = oPdfReader.NumberOfPages
        Dim iPage As Integer = 0

        Do While (iPage < iNumberOfPages)
            iPage += 1
            oPdfDoc.SetPageSize(oPdfReader.GetPageSizeWithRotation(iPage))
            oPdfDoc.NewPage()

            Dim oPdfImportedPage As iTextSharp.text.pdf.PdfImportedPage = oPdfWriter.GetImportedPage(oPdfReader, iPage)
            Dim iRotation As Integer = oPdfReader.GetPageRotation(iPage)
            If (iRotation = 90) Or (iRotation = 270) Then
                oDirectContent.AddTemplate(oPdfImportedPage, 0, -1.0F, 1.0F, 0, 0, oPdfReader.GetPageSizeWithRotation(iPage).Height)
            Else
                oDirectContent.AddTemplate(oPdfImportedPage, 1.0F, 0, 0, 1.0F, 0, 0)
            End If
        Loop

    End Sub

    Private Function PadExt(ByVal s As String) As String
        s = UCase(s)
        If s.Length > 3 Then
            s = s.Substring(1, 3)
        End If
        Return s
    End Function

   Private Function GetPageCount(ByVal sFolderPath As String) As Integer
        Dim iRet As Integer = 0
        Dim oFiles As String() = IO.Directory.GetFiles(sFolderPath)

        For i As Integer = 0 To oFiles.Length - 1
            Dim sFromFilePath As String = oFiles(i)
            Dim oFileInfo As New IO.FileInfo(sFromFilePath)
            Dim sFileType As String = "PDF"
            Dim sExt As String = PadExt(oFileInfo.Extension)

            iRet += 1
        Next

        Return iRet
    End Function
#End Region

End Class
End Class

Community

Compile Assembly Drawings

Compile Assembly Drawings

Compile Assembly Drawings