Choose a printer

Discussion in 'AutoCAD' started by josh.dylewski, Nov 29, 2007.

  1. josh.dylewski

    josh.dylewski Guest

    Hello,

    I'm trying to create a vba macro in autocad 2005 that will print
    multiple files...a set number of times...to which ever printer. And
    that is were I am getting stuck.

    I was able to get everything to work but the printer. I can print to
    the defined printer in the dwg file, but I can choose a printer to
    print from. What I would like it a drop down menu for selection of the
    printer to use.

    Is that possible, I've searched and searched but I can't find anything
    and the stuff that I find doesn't seem to work...

    Thanks in advance.
     
    josh.dylewski, Nov 29, 2007
    #1
  2. josh.dylewski

    Figmint Guest

    if your printing layouts and are using page setups to quickly switch
    from one printer setup to another then try then the following can be
    easily adapted.
    Code:
    Sub main1()
a = 2
b = 2
Worksheets("list1").Visible = True
mpath = ThisWorkbook.Path
If (Worksheets("inputs").Range("A" & a) = "") Then
If (Right(mpath, 3) <> "CAD") Then
Call list1(mpath & "\CAD\Elec", list1(mpath & "\CAD\Mech", 2))
Else
Call list1(mpath & "\Elec", list1(mpath & "\Mech", 2))
End If
Else
While Worksheets("inputs").Range("A" & a) <> ""
b = list1(mpath & Worksheets("inputs").Range("A" & a), b)
a = a + 1
Wend
End If
Worksheets("inputs").Visible = False
Worksheets("list1").Activate
Columns("A:A").Sort Key1:=Range("A2"), Order1:=xlAscending,
header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select
End Sub
Sub clear_progress()
a = 2
While Worksheets("Sheetlist").Range("B" & a) <> ""
a = a + 1
Wend
Worksheets("Sheetlist").Range("B2:B" & a).Clear
End Sub

Sub ploting()
Dim e As New AcadApplication
Dim adoc As AcadDocument, pconf As AcadPlotConfiguration, lay As
Variant, alay As AcadLayout
Dim addlayouts() As String, plot As AcadPlot, laytplot As Variant,
laytp(1 To 1) As String
Call clear_progress
'Close #2
'Open ThisWorkbook.Path & "\plotconfigs.txt" For Output As #2
On Error Resume Next
c = 1
While c <= Worksheets("Sheetlist").Range("H2") 'number of copys
a = 2
While Worksheets("Sheetlist").Range("A" & a) <> "" 'to end of list
If Worksheets("Sheetlist").Range("C" & a) <>
Worksheets("Sheetlist").Range("C" & a - 1) Then
Set adoc =
e.Documents.Open(Worksheets("Sheetlist").Range("C" & a))
Worksheets("Sheetlist").Range("B" & a) = 1
For b = 0 To adoc.PlotConfigurations.Count - 1
If adoc.PlotConfigurations.Item(b).name =
Worksheets("Sheetlist").Range("G1") Then
Set pconf = adoc.PlotConfigurations.Item(b)
b = adoc.PlotConfigurations.Count
End If
Next
End If
If b = adoc.PlotConfigurations.Count + 1 Or
Worksheets("Sheetlist").Range("G1") =
Worksheets("Sheetlist").Range("A" & a) Then

For b = 0 To adoc.Layouts.Count
If adoc.Layouts.Item(b).name =
Worksheets("Sheetlist").Range("A" & a) Then
Set alay = adoc.Layouts.Item(b)
b = adoc.Layouts.Count
End If
Next
alay.CopyFrom pconf
laytp(1) = Worksheets("Sheetlist").Range("A" & a)
laytplot = laytp
adoc.plot.SetLayoutsToPlot laytplot
alay.PlotType = acExtents
alay.RefreshPlotDeviceInfo
adoc.plot.PlotToDevice

'    Print #2, Worksheets("Sheetlist").Range("A" & a)
'        Print #2, "Name       :  " & alay.name
'        Print #2, "CanonicalMediaName:  " &
alay.CanonicalMediaName
'        Print #2, "CenterPlot :  " & alay.CenterPlot
'        Print #2, "ConfigName :  " & alay.ConfigName
'        Print #2, "Document   :  " & alay.Document
'        Print #2, "Handle     :  " & alay.Handle
'        Print #2, "HasExtensionDictionary:  " &
alay.HasExtensionDictionary
'        Print #2, "ModelType  :  " & alay.ModelType
'        Print #2, "ObjectID   :  " & alay.ObjectID
'        Print #2, "ObjectName :  " & alay.ObjectName
'        Print #2, "OwnerID    :  " & alay.OwnerID
'        Print #2, "PaperUnits :  " & alay.PaperUnits
'        Print #2, "PlotHidden :  " & alay.PlotHidden
'        Print #2, "PlotOrigin :  " & alay.PlotOrigin
'        Print #2, "PlotRotation: " & alay.PlotRotation
'        Print #2, "PlotType   :  " & alay.PlotType
'        Print #2, "PlotViewportBorders:  " &
alay.PlotViewportBorders
'        Print #2, "PlotViewportsFirst:  " &
alay.PlotViewportsFirst
'        Print #2, "PlotWithLineweights:  " &
alay.PlotWithLineweights
'        Print #2, "PlotWithPlotStyles:  " &
aalay.PlotWithPlotStyles
'        Print #2, "ScaleLineweights:  " & alay.ScaleLineweights
'        Print #2, "ShowPlotStyles:  " & alay.ShowPlotStyles
'        Print #2, "StandardScale:  " & alay.StandardScale
'        Print #2, "StyleSheet :  " & alay.StyleSheet
'        Print #2, "UseStandardScale:  " & alay.UseStandardScale
'        Print #2, "ViewToPlot :  " & alay.ViewToPlot

Worksheets("Sheetlist").Range("B" & a) = c
If Worksheets("Sheetlist").Range("C" & a) <>
Worksheets("Sheetlist").Range("C" & a + 1) Then
adoc.Close
Else
b = adoc.PlotConfigurations.Count + 1
End If
Else
Worksheets("Sheetlist").Range("B" & a) = "E"
End If
a = a + 1
Wend
'Close #2
c = c + 1
Wend
e.Quit
End Sub

Sub remove()
Selection.Delete Shift:=xlUp
End Sub


Sub back1()
Call Workbook_Open
End Sub

Sub main2()
Worksheets("Sheetlist").Visible = True
Call layers
Call remover("Model")
Worksheets("list1").Visible = False
Worksheets("Sheetlist").Activate
Worksheets("Sheetlist").Range("A:C").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlDescending,
Key2:=Range("C2") _
, Order2:=xlDescending, header:=xlYes, OrderCustom:=1,
MatchCase:=False _
, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal,
DataOption2:= _
xlSortNormal
Worksheets("Sheetlist").Range("A1").Select
End Sub

Sub back2()
Worksheets("inputs").Visible = True
Worksheets("list1").Visible = False
Worksheets("inputs").Activate
End Sub

Sub main3()
a = Worksheets("Sheetlist").Range("G1")
Close #2
Open ThisWorkbook.Path & "\" & a & ".bp3" For Output As #2
Call header(a)
Call body
Close #2
End Sub

Sub back3()
Worksheets("list1").Visible = True
Worksheets("Sheetlist").Visible = False
Worksheets("list1").Activate
End Sub

Sub remover(a)
b = 2
While Worksheets("Sheetlist").Range("A" & b) <> ""
If (Worksheets("Sheetlist").Range("A" & b) = a) Then
Worksheets("Sheetlist").Range(b & ":" & b).Delete
Else
b = b + 1
End If
Wend
End Sub

Sub layers()
a = 2
b = 2
Dim cad As AcadApplication, doc As AcadDocument
Dim acad As AxDbDocument, sheetname As Variant
Set cad = CreateObject("AutoCAD.Application.16")
Set fil = CreateObject("Scripting.FileSystemObject")
cad.Visible = True

Set acad = cad.GetInterfaceObject("ObjectDBX.AxDbDocument.16")

While Excel.Worksheets("list1").Range("A" & a) <> ""
sheetname = (Worksheets("list1").Range("A" & a))
checkfile = Mid(Worksheets("list1").Range("A" & a), 1,
Worksheets("list1").Range("A" & a).Characters.Count - 4) & ".dwl"
If fil.fileexists(checkfile) = False Then
acad.Open sheetname
For c = 0 To acad.Layouts.Count - 1
If acad.Layouts.Item(c).name <> "Model" Then
Excel.Worksheets("Sheetlist").Range("A" & b) =
acad.Layouts.Item(c).name
Excel.Worksheets("Sheetlist").Range("C" & b) =
Excel.Worksheets("list1").Range("A" & a)
b = b + 1
End If
Next
Else
Set doc = cad.Documents.Open(sheetname, 1)
For c = 0 To doc.Layouts.Count - 1
If doc.Layouts.Item(c).name <> "Model" Then
Excel.Worksheets("Sheetlist").Range("A" & b) =
doc.Layouts.Item(c).name
Excel.Worksheets("Sheetlist").Range("C" & b) =
Excel.Worksheets("list1").Range("A" & a)
b = b + 1
End If
Next
doc.Close
End If
a = a + 1
Wend
cad.Quit
Set cad = Nothing
Set acad = Nothing
Set doc = Nothing
End Sub

Function list1(location, start)
a = 1
With Application.FileSearch
.LookIn = location
.FileType = msoFileTypeAllFiles
.SearchSubFolders = True
If (.Execute <> 0) Then
While a <= .FoundFiles.Count
b = .FoundFiles.Item(a)
If (Right(b, 3) = "dwg" Or Right(b, 3) = "DWG") Then
Worksheets("list1").Range("A" & start)
= .FoundFiles.Item(a)
start = start + 1
End If
a = a + 1
Wend
End If
End With
list1 = start
End Function

Private Sub Workbook_Open()
ScreenUpdating = False
Worksheets("inputs").Visible = True
Worksheets("inputs").Select
Worksheets("list1").Visible = False
Worksheets("inputs").Visible = True
Worksheets("inputs").Activate
Worksheets("Sheetlist").Visible = False
Worksheets("inputs").Cells.ClearContents
Worksheets("inputs").Range("A1") = "insert below all folder
address relative to this file. (unless normal)"
Worksheets("list1").Cells.ClearContents
Worksheets("list1").Range("A1") = "Please Check that all desired
Files are selected"
Worksheets("Sheetlist").Cells.ClearContents
Worksheets("Sheetlist").Range("A1") = "Please check that all
Desired layers are selected if one is missing please go back and check
that its file was in the list if one is extra please delete its row"
Worksheets("Sheetlist").Range("F1") = "Please select a plot type -[QUOTE]
"[/QUOTE]
Worksheets("Sheetlist").Range("G2") = "Number of copys ->"
Worksheets("Sheetlist").Range("H2") = 1
ScreenUpdating = True
End Sub
     
    Figmint, Nov 30, 2007
    #2
  3. josh.dylewski

    Figmint Guest

    the following code is designed to be called from an excel sheet. i am
    not sure if it will help, but it prints batches of drawings using page
    setups.


    Sub main1()
    a = 2
    b = 2
    Worksheets("list1").Visible = True
    mpath = ThisWorkbook.Path
    If (Worksheets("inputs").Range("A" & a) = "") Then
    If (Right(mpath, 3) <> "CAD") Then
    Call list1(mpath & "\CAD\Elec", list1(mpath & "\CAD\Mech", 2))
    Else
    Call list1(mpath & "\Elec", list1(mpath & "\Mech", 2))
    End If
    Else
    While Worksheets("inputs").Range("A" & a) <> ""
    b = list1(mpath & Worksheets("inputs").Range("A" & a), b)
    a = a + 1
    Wend
    End If
    Worksheets("inputs").Visible = False
    Worksheets("list1").Activate
    Columns("A:A").Sort Key1:=Range("A2"), Order1:=xlAscending,
    header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    Range("A1").Select
    End Sub
    Sub clear_progress()
    a = 2
    While Worksheets("Sheetlist").Range("B" & a) <> ""
    a = a + 1
    Wend
    Worksheets("Sheetlist").Range("B2:B" & a).Clear
    End Sub

    Sub ploting()
    Dim e As New AcadApplication
    Dim adoc As AcadDocument, pconf As AcadPlotConfiguration, lay As
    Variant, alay As AcadLayout
    Dim addlayouts() As String, plot As AcadPlot, laytplot As Variant,
    laytp(1 To 1) As String
    Call clear_progress
    'Close #2
    'Open ThisWorkbook.Path & "\plotconfigs.txt" For Output As #2
    On Error Resume Next
    c = 1
    While c <= Worksheets("Sheetlist").Range("H2") 'number of copys
    a = 2
    While Worksheets("Sheetlist").Range("A" & a) <> "" 'to end of list
    If Worksheets("Sheetlist").Range("C" & a) <>
    Worksheets("Sheetlist").Range("C" & a - 1) Then
    Set adoc =
    e.Documents.Open(Worksheets("Sheetlist").Range("C" & a))
    Worksheets("Sheetlist").Range("B" & a) = 1
    For b = 0 To adoc.PlotConfigurations.Count - 1
    If adoc.PlotConfigurations.Item(b).name =
    Worksheets("Sheetlist").Range("G1") Then
    Set pconf = adoc.PlotConfigurations.Item(b)
    b = adoc.PlotConfigurations.Count
    End If
    Next
    End If
    If b = adoc.PlotConfigurations.Count + 1 Or
    Worksheets("Sheetlist").Range("G1") =
    Worksheets("Sheetlist").Range("A" & a) Then

    For b = 0 To adoc.Layouts.Count
    If adoc.Layouts.Item(b).name =
    Worksheets("Sheetlist").Range("A" & a) Then
    Set alay = adoc.Layouts.Item(b)
    b = adoc.Layouts.Count
    End If
    Next
    alay.CopyFrom pconf
    laytp(1) = Worksheets("Sheetlist").Range("A" & a)
    laytplot = laytp
    adoc.plot.SetLayoutsToPlot laytplot
    alay.PlotType = acExtents
    alay.RefreshPlotDeviceInfo
    adoc.plot.PlotToDevice

    ' Print #2, Worksheets("Sheetlist").Range("A" & a)
    ' Print #2, "Name : " & alay.name
    ' Print #2, "CanonicalMediaName: " &
    alay.CanonicalMediaName
    ' Print #2, "CenterPlot : " & alay.CenterPlot
    ' Print #2, "ConfigName : " & alay.ConfigName
    ' Print #2, "Document : " & alay.Document
    ' Print #2, "Handle : " & alay.Handle
    ' Print #2, "HasExtensionDictionary: " &
    alay.HasExtensionDictionary
    ' Print #2, "ModelType : " & alay.ModelType
    ' Print #2, "ObjectID : " & alay.ObjectID
    ' Print #2, "ObjectName : " & alay.ObjectName
    ' Print #2, "OwnerID : " & alay.OwnerID
    ' Print #2, "PaperUnits : " & alay.PaperUnits
    ' Print #2, "PlotHidden : " & alay.PlotHidden
    ' Print #2, "PlotOrigin : " & alay.PlotOrigin
    ' Print #2, "PlotRotation: " & alay.PlotRotation
    ' Print #2, "PlotType : " & alay.PlotType
    ' Print #2, "PlotViewportBorders: " &
    alay.PlotViewportBorders
    ' Print #2, "PlotViewportsFirst: " &
    alay.PlotViewportsFirst
    ' Print #2, "PlotWithLineweights: " &
    alay.PlotWithLineweights
    ' Print #2, "PlotWithPlotStyles: " &
    aalay.PlotWithPlotStyles
    ' Print #2, "ScaleLineweights: " & alay.ScaleLineweights
    ' Print #2, "ShowPlotStyles: " & alay.ShowPlotStyles
    ' Print #2, "StandardScale: " & alay.StandardScale
    ' Print #2, "StyleSheet : " & alay.StyleSheet
    ' Print #2, "UseStandardScale: " & alay.UseStandardScale
    ' Print #2, "ViewToPlot : " & alay.ViewToPlot

    Worksheets("Sheetlist").Range("B" & a) = c
    If Worksheets("Sheetlist").Range("C" & a) <>
    Worksheets("Sheetlist").Range("C" & a + 1) Then
    adoc.Close
    Else
    b = adoc.PlotConfigurations.Count + 1
    End If
    Else
    Worksheets("Sheetlist").Range("B" & a) = "E"
    End If
    a = a + 1
    Wend
    'Close #2
    c = c + 1
    Wend
    e.Quit
    End Sub

    Sub remove()
    Selection.Delete Shift:=xlUp
    End Sub


    Sub back1()
    Call Workbook_Open
    End Sub

    Sub main2()
    Worksheets("Sheetlist").Visible = True
    Call layers
    Call remover("Model")
    Worksheets("list1").Visible = False
    Worksheets("Sheetlist").Activate
    Worksheets("Sheetlist").Range("A:C").Select
    Selection.Sort Key1:=Range("A2"), Order1:=xlDescending,
    Key2:=Range("C2") _
    , Order2:=xlDescending, header:=xlYes, OrderCustom:=1,
    MatchCase:=False _
    , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal,
    DataOption2:= _
    xlSortNormal
    Worksheets("Sheetlist").Range("A1").Select
    End Sub

    Sub back2()
    Worksheets("inputs").Visible = True
    Worksheets("list1").Visible = False
    Worksheets("inputs").Activate
    End Sub

    Sub main3()
    a = Worksheets("Sheetlist").Range("G1")
    Close #2
    Open ThisWorkbook.Path & "\" & a & ".bp3" For Output As #2
    Call header(a)
    Call body
    Close #2
    End Sub

    Sub back3()
    Worksheets("list1").Visible = True
    Worksheets("Sheetlist").Visible = False
    Worksheets("list1").Activate
    End Sub

    Sub remover(a)
    b = 2
    While Worksheets("Sheetlist").Range("A" & b) <> ""
    If (Worksheets("Sheetlist").Range("A" & b) = a) Then
    Worksheets("Sheetlist").Range(b & ":" & b).Delete
    Else
    b = b + 1
    End If
    Wend
    End Sub

    Sub layers()
    a = 2
    b = 2
    Dim cad As AcadApplication, doc As AcadDocument
    Dim acad As AxDbDocument, sheetname As Variant
    Set cad = CreateObject("AutoCAD.Application.16")
    Set fil = CreateObject("Scripting.FileSystemObject")
    cad.Visible = True

    Set acad = cad.GetInterfaceObject("ObjectDBX.AxDbDocument.16")

    While Excel.Worksheets("list1").Range("A" & a) <> ""
    sheetname = (Worksheets("list1").Range("A" & a))
    checkfile = Mid(Worksheets("list1").Range("A" & a), 1,
    Worksheets("list1").Range("A" & a).Characters.Count - 4) & ".dwl"
    If fil.fileexists(checkfile) = False Then
    acad.Open sheetname
    For c = 0 To acad.Layouts.Count - 1
    If acad.Layouts.Item(c).name <> "Model" Then
    Excel.Worksheets("Sheetlist").Range("A" & b) =
    acad.Layouts.Item(c).name
    Excel.Worksheets("Sheetlist").Range("C" & b) =
    Excel.Worksheets("list1").Range("A" & a)
    b = b + 1
    End If
    Next
    Else
    Set doc = cad.Documents.Open(sheetname, 1)
    For c = 0 To doc.Layouts.Count - 1
    If doc.Layouts.Item(c).name <> "Model" Then
    Excel.Worksheets("Sheetlist").Range("A" & b) =
    doc.Layouts.Item(c).name
    Excel.Worksheets("Sheetlist").Range("C" & b) =
    Excel.Worksheets("list1").Range("A" & a)
    b = b + 1
    End If
    Next
    doc.Close
    End If
    a = a + 1
    Wend
    cad.Quit
    Set cad = Nothing
    Set acad = Nothing
    Set doc = Nothing
    End Sub

    Function list1(location, start)
    a = 1
    With Application.FileSearch
    .LookIn = location
    .FileType = msoFileTypeAllFiles
    .SearchSubFolders = True
    If (.Execute <> 0) Then
    While a <= .FoundFiles.Count
    b = .FoundFiles.Item(a)
    If (Right(b, 3) = "dwg" Or Right(b, 3) = "DWG") Then
    Worksheets("list1").Range("A" & start)
    = .FoundFiles.Item(a)
    start = start + 1
    End If
    a = a + 1
    Wend
    End If
    End With
    list1 = start
    End Function

    Private Sub Workbook_Open()
    ScreenUpdating = False
    Worksheets("inputs").Visible = True
    Worksheets("inputs").Select
    Worksheets("list1").Visible = False
    Worksheets("inputs").Visible = True
    Worksheets("inputs").Activate
    Worksheets("Sheetlist").Visible = False
    Worksheets("inputs").Cells.ClearContents
    Worksheets("inputs").Range("A1") = "insert below all folder
    address relative to this file. (unless normal)"
    Worksheets("list1").Cells.ClearContents
    Worksheets("list1").Range("A1") = "Please Check that all desired
    Files are selected"
    Worksheets("Sheetlist").Cells.ClearContents
    Worksheets("Sheetlist").Range("A1") = "Please check that all
    Desired layers are selected if one is missing please go back and check
    that its file was in the list if one is extra please delete its row"
    Worksheets("Sheetlist").Range("F1") = "Please select a plot type -
    Worksheets("Sheetlist").Range("G2") = "Number of copys ->"
    Worksheets("Sheetlist").Range("H2") = 1
    ScreenUpdating = True
    End Sub
     
    Figmint, Nov 30, 2007
    #3
  4. josh.dylewski

    josh.dylewski Guest

    Yeah, not what I was looking for, but thanks for a quick reply :)
     
    josh.dylewski, Nov 30, 2007
    #4
Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments (here). After that, you can post your question and our members will help you out.
Similar Threads

  1. Which journal should I choose?

  2. SpectreVerilog "choose anaylses" problem

  3. Compilation order of verilog files in NCVerilog/VCS simulator to choose the dealy mode

  4. Which Linux to choose for Cadence IC 6.10

  5. choose all identical shapes in two layers in divaDRC.rul DRC check

  6. Which Graphic Board would you choose?

  7. How-To: Choose What Material Your Part Is Made Of

  8. Things slowing down - not able to choose OpenGL in SP0

Loading...