ilogic rule to export all sheets as images in idw file

[kamal.issa]

Hi. Does anyone know a rule that can go through every sheet in an idw file and export them as high resolution images?

Just like in the attached pictures. without changing the sheet's names. the picture's name has to be saved as the same name of its corresponding sheet. pixels (x=5000,y=5000)

It can be done without ilogic if i export them as pdf then export them as image but i lose resolution even if i set it as maximum.

Thanks

[lmc.engineering · Accepted solution]

Hi,
You can use the below code. It has a few extra bits in there to catch any duplicate scenarios. It also files it in a folder named "Auto Imager" in the root folder the drawing document resides in.

Code Snippet

Sub Main()
	Dim oDrawDoc As DrawingDocument = ThisApplication.ActiveDocument
	Dim oSheet As Sheet
	
	Dim sExt As String = ".png"
	Dim pImageX As Integer = 5000
	Dim pImageY As Integer = 5000
	Dim FilePath As String = ThisDoc.Path
	Dim sDocName As String = ThisDoc.FileName(False)
	Dim sImageLocation As String = "\Auto Imager" '''CHANGE STORAGE FOLDER HERE
	Dim sWritePath As String = FilePath & sImageLocation
	Dim IncVal As Integer = 1
	Dim SFile As System.IO.File
	Dim SDir As System.IO.Directory
	'''Check the directory exists
	If Not SDir.Exists(sWritePath) Then SDir.CreateDirectory(sWritePath)
			
	'''Set the active view
ThisApplication.CommandManager.ControlDefinitions.Item("AppIsometricViewCmd").Execute
	oView = ThisApplication.ActiveView
	
	'''Iterate through and capture image
    For Each oSheet In oDrawDoc.Sheets
		oSheet.Activate
        sSheetName = oSheet.Name
		sSheetName = sSheetName.Substring(0,sSheetName.Length-2)
		'sImageName = sDocName & "_" & sSheetName
		sImageName = sSheetName ''' SAVED AS SHEET NAME ONLY
		sImageNameandPath = sWritePath & "\" & sImageName & sExt	
	'''Check if File exsists already. If So, increase incremental value
		If Not SFile.Exists(sImageNameandPath) Then
			oView.SaveAsBitmap(sImageNameandPath, pImageX, pImageY)
		Else		
      		Do
          		IncVal += 1
           	sImageNameandPath = sWritePath & "\" & sImageName & "_" & IncVal & sExt
        	Loop While SFile.Exists(sImageNameandPath)
			oView.SaveAsBitmap(sImageNameandPath, pImageX, pImageY)
		End If
    Next
End Sub

[kamal.issa]

Hi @lmc.engineering. Thanks a lot. It worked. This will save me a lot of time at work.

[kamal.issa]

Hi @lmc.engineering. Is it possible to add something to the code that crops the exported image at the sheet's boarder ?

Thanks

[lmc.engineering]

@kamal.issa, Apologies for the late reply.

To trim at the drawing borders, I would adjust the Y coordinates to suit. An A3 sheet has an aspect ratio of 1.41:1, so if X is 5000px, then Y will be approx 3535px.

Regards

[kamal.issa]

@lmc.engineering But changing the X and Y changes the resolution of the image. Not the dimensions. If you put X=Y=0 it will give you an image with the same dimensions but very low resolution.

[lmc.engineering]

@kamal.issa. The resolution is a measure of pixels per inch. As the width is 5000px, and the sheet size is 16.5", that gives me 303DPI. So long as you retain the 5000px width, whether you have the images square or rectangular, I still have 303DPI.

Put it another way, if I have a 300DPI square image and chop off the top and the bottom, my image is still 300DPI, but now its a rectangular image.

Regards

[kamal.issa]

@lmc.engineering you're right. it worked. The ratio of X and Y has to be correct according to the sheet size. But there's one thing missing in the code. before you run the code you have to go through every sheet and use the "zoom all" command (same command if you double click the middle button of the mouse) then run the code. if you don't use this command in every sheet it doesn't work. Does this command have a code?

Thanks

[lmc.engineering]

This should do the trick

Version:1.0 StartHTML:00000145 EndHTML:00007926 StartFragment:00000294 EndFragment:00007894 StartSelection:00000294 EndSelection:00000294SyntaxEditor Code Snippet

Sub Main()
	Dim oDrawDoc As DrawingDocument = ThisApplication.ActiveDocument
	Dim oSheet As Sheet
	
	Dim sExt As String = ".png"
	Dim pImageX As Integer = 5000
	Dim pImageY As Integer = 3535
	Dim FilePath As String = ThisDoc.Path
	Dim sDocName As String = ThisDoc.FileName(False)
	Dim sImageLocation As String = "\Auto Imager" '''CHANGE STORAGE FOLDER HERE
	Dim sWritePath As String = FilePath & sImageLocation
	Dim IncVal As Integer = 1
	Dim SFile As System.IO.File
	Dim SDir As System.IO.Directory
	'''Check the directory exists
	If Not SDir.Exists(sWritePath) Then SDir.CreateDirectory(sWritePath)

	'''Iterate through and capture image
    For Each oSheet In oDrawDoc.Sheets
		oSheet.Activate
		'''Zoom all as active view
	ThisApplication.CommandManager.ControlDefinitions.Item("AppZoomallCmd").Execute
		oView = ThisApplication.ActiveView
        sSheetName = oSheet.Name
		sSheetName = sSheetName.Substring(0,sSheetName.Length-2)
		'sImageName = sDocName & "_" & sSheetName
		sImageName = sSheetName ''' SAVED AS SHEET NAME ONLY
		sImageNameandPath = sWritePath & "\" & sImageName & sExt	
	'''Check if File exsists already. If So, increase incremental value
		If Not SFile.Exists(sImageNameandPath) Then
			oView.SaveAsBitmap(sImageNameandPath, pImageX, pImageY)
		Else		
      		Do
          		IncVal += 1
           	ImageNameandPath = sWritePath & "\" & sImageName & "_" & IncVal & sExt
        	Loop While SFile.Exists(sImageNameandPath)
			oView.SaveAsBitmap(sImageNameandPath, pImageX, pImageY)
		End If
    Next
End Sub

[kamal.issa]

Thanks a lot

[Anonymous]

@lmc.engineering Hi, its working fine unless you have more than 10 sheets in the drawing. I suppose it's because of this line: 

sSheetName = sSheetName.Substring(0,sSheetName.Length-2)

[lmc.engineering]

Hi @Anonymous , yes that's correct. I should have written it like this:

sSheetName = sSheetName.Substring(0, sSheetName.LastIndexOf(":"))

Regards