AfraLISP - Learn AutoLISP for AutoCAD productivity

DWG to PowerPoint

by Kenny Ramage

Introduction

This application will take a selected directory of drawings, convert them to WMF format and insert them into Powerpoint as individual slide.

Usage

  1. Open the Powerpoint file dwg2slide.ppt.
  2. Run the macro ‘dwg2slide’.
  3. Choose any file in the directory you wish to process.
  4. Select ‘OK’ to proceed and sit back.
  5. After a couple of minutes (depending on how many drawing files are in the directory you choose), your slides will have been created.

Here is the coding for the entire application (remember, this is written in Powerpoint VBA) :

First create a module named Module1:

Public dirname As String
 
Sub Dwg2Slide()
Dim selname As String
Dim SelName1 As String
Dim InCounter As Integer
Dim InFoundpos As Integer
 
 
UserForm1.CommonDialog1.Filter = "dwg Files (*.dwg)|*.dwg"
'set default file type
 
UserForm1.CommonDialog1.Flags = cdlOFNHideReadOnly
'switch off read only
 
UserForm1.CommonDialog1.ShowOpen
'open dialog box
 
selname = UserForm1.CommonDialog1.filename
'retrieve the file name
 
InCounter = 1
'initilize counter
 
InFoundpos = InStr(InCounter, selname, "\")
'look for the \
While InFoundpos <> 0
'check for the last \
 
    SelName1 = Mid$(selname, InCounter, InFoundpos - InCounter)
    'extract the directory name
    
            InCounter = InFoundpos + 1
            'increase the counter
            
            InFoundpos = InStr(InCounter, selname, "\")
            'find the next \
            
    dirname = dirname & SelName1 & "\"
    'construct the path
    
Wend
 
UserForm1.Show
'show the dialog
 
End Sub

Next create a userform named Userform1. The following coding goes under the event procedures of the userforms controls :

Private Sub CommandButton1_Click()
 
Dim filename As String
Dim sl As Integer
Dim acadApp As Object
Dim acadDoc As Object
Dim sset As Object
Dim pViewport As Object
'declare variables
 
Set acadApp = CreateObject("Autocad.Application")
'open AutoCAD
 
   If Err Then
   'if there is an error
 
        MsgBox Err.Description
        'inform user
 
        Exit Sub
        'exit application
 
    End If
    'end if
 
acadApp.Visible = True
'Make Autocad Visible
 
Set acadDoc = acadApp.ActiveDocument
'set reference to active document
 
Me.Hide
'Hide the dialogue box
 
filename = Dir(dirname, vbNormal)
'retrieve the first entry
 
Do While filename <> ""
'start the loop
 
If UCase(Right$(filename, 4)) = ".DWG" Then
'ignore files that do not end with .DWG
 
If (GetAttr(dirname & filename) And vbNormal) = vbNormal Then
'use bitwise comparison to make sure filename is not a directory
 
acadDoc.Open dirname & filename
'open drawing to purge
 
mylen = Len(filename)
'get the length of the filename
 
mylen = mylen - 4
'subtract the .DWG Extension
 
filename1 = Left(filename, mylen)
'retrieve the drawing name
 
Set pViewport = acadDoc.ActiveViewport
'set reference to the viewports
 
pViewport.ZoomExtents
'zoom to extents
 
Set sset = acadDoc.SelectionSets.Add("NEWSS")
'set reference to election set
 
sset.Select acSelectionSetAll
'select the whole drawing
 
acadDoc.Export dirname & filename1, "WMF", sset
'export the drawing
 
acadDoc.Save
'save the drawing
 
End If

End If
 
filename = Dir
'get the next entry
 
Loop
'carry on looping
 
acadApp.Quit
'Close Autocad
 
filename = Dir(dirname, vbNormal)
'retrieve the first entry
 
sl = 1
 
Do While filename <> ""
'start the loop
 
If UCase(Right$(filename, 4)) = ".WMF" Then
'ignore files that do not end with .WMF
 
If (GetAttr(dirname & filename) And vbNormal) = vbNormal Then
'use bitwise comparison to make sure filename is not a directory
 
 
    ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Add _
    (Index:=sl, Layout:=ppLayoutBlank).SlideIndex
    'insert a new slide
    
    ActiveWindow.Selection.SlideRange.Shapes.AddPicture _
    (filename:=filename, LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, Left:=-2, Top:=58, Width:=727, _
    Height:=423).Select
    'import WMF File into slide
    
    sl = 1 + sl
    'increment the slide number
    
End If
 
End If
 
filename = Dir
'get the next entry
 
Loop
'carry on looping
 
MsgBox ("Process Complete.."), , "Drawings to Slide"
'inform user that we have finished
 
End
 
End Sub
 
Private Sub CommandButton2_Click()
End
 
End Sub

If you would like a copy of this module, just click here. Enjoy…