Solved

Excel VBA print to microsoft office document imagewrite, portnumber keeps changing (ne00

Posted on 2011-03-15
4
788 Views
Last Modified: 2013-11-26
as many people i encoutered the fact that the activeport of the modi-printer keeps changing. Out there you find some solutions but my lack of programming knowledge prohibits me from getting it working correctly.

i want to print to tif file where the filename is in a cel And that it works regardless of the NE-port number.
so it should print to the MODI-printer and find out on what port it is and print/save the file as.......

Attached you find an example file i got it from an ealier post and hope someone can help me get it working. Below some examples of solutions that give an idea of what's the problem:
http://www.pcreview.co.uk/forums/vba-active-printer-port-problem-t3540182.html
https://support.automatedresults.net/KB/a79/generic-printing-in-excel-without-specifiing-ne-ports.aspx

gatenpatroon-module-v5.xlsm
0
Comment
Question by:mco_boonstra
  • 2
4 Comments
 
LVL 85

Accepted Solution

by:
Rory Archibald earned 500 total points
ID: 35139013
Try this:
Sub export()
   Dim strPrinter As String
   strPrinter = "Microsoft Office Document Image Writer"
    Sheets("boorgat coordinaten").Select
    Range("A1:P58").Select
    Path = "f:\klant_tekening\"
    Filename = Range("h4").Value & "." & Range("I4").Value & ".1" & ".tif"
    ActiveWorkbook.PrintOut 1, 1, 1, False, strPrinter & " op " & GetPrinterPort(strPrinter), True, False, Path & Filename, False
 
End Sub
Public Function GetPrinterPort(strPrinterName As String) As String
    Dim objReg As Object, strRegVal As String, strValue As String
    Const HKEY_CURRENT_USER = &H80000001
    Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
    strRegVal = "Software\Microsoft\Windows NT\CurrentVersion\PrinterPorts\"
    objReg.getstringvalue HKEY_CURRENT_USER, strRegVal, strPrinterName, strValue
    GetPrinterPort = Mid$(strValue, 10, 5)
End Function

Open in new window

0
 
LVL 19

Expert Comment

by:akoster
ID: 35139109
you could use the code from http://www.tek-tips.com/viewthread.cfm?qid=628174&page=8 to find out which printers are installed on your system.
It takes some tweaking to get it in a format you'd be looking for but it works.
In short, the upper function looks in the registry which NE port is linked to a specific printer name. The second function queries the registry for all known printer names and uses the getnewprinter function to combine these values.
As a proof of concept, the active printer is set and printed to the debug output for each printer.

succes !

Function GetNewPrinter(Printer As String) As String
'
' Get EXCEL printer name from windows printer name
' Input: printer name like "HP Laserjet"
' Output: printer name like "HP Laserjet at Ne02:"
'
Dim ws As Object
On Error GoTo ErrHandler

Set ws = CreateObject("WScript.Shell")
np = ws.regread("HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Devices\" & Printer)
If Len(np) >= 5 Then GetNewPrinter = Printer & " op " & Right(np, 5) Else GetNewPrinter = ""
Exit Function

ErrHandler:
GetNewPrinter = ""
End Function


Public Function ListAllPrinters() As String

   Dim lObj_ScriptControl        As IWshNetwork_Class
   Dim lCol_Printers             As IWshCollection_Class
   Dim lStr_PrinterList          As String
   Dim lInt_Idx                  As Integer
   
   Set lObj_ScriptControl = New IWshNetwork_Class
   Set lCol_Printers = lObj_ScriptControl.EnumPrinterConnections

   lStr_PrinterList = vbNullString
   For lInt_Idx = 1 To lCol_Printers.Count - 1 Step 2
      
      Debug.Print "Voor : " & Application.ActivePrinter
      new_printer = GetNewPrinter(lCol_Printers.Item(lInt_Idx))
      Application.ActivePrinter = new_printer
      Debug.Print "Na   : " & Application.ActivePrinter
      
      lStr_PrinterList = lStr_PrinterList & lCol_Printers.Item(lInt_Idx) & ";"
   Next lInt_Idx

   If (Right(lStr_PrinterList, 1) = ";") Then
      lStr_PrinterList = Left(lStr_PrinterList, Len(lStr_PrinterList) - 1)
   End If

   Set lObj_ScriptControl = Nothing
   Set lCol_Printers = Nothing
   
   ListAllPrinters = lStr_PrinterList

End Function

Open in new window

0
 
LVL 19

Expert Comment

by:akoster
ID: 35139173
For the code to run, you have to add a reference to the "Windows Script Host Object Model"
0
 

Author Closing Comment

by:mco_boonstra
ID: 35139195
This solution was great, copy and paste and it works flawlessly.
And the responcetime was super.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Enums (shorthand for ‘enumerations’) are not often used by programmers but they can be quite valuable when they are.  What are they? An Enum is just a type of variable like a string or an Integer, but in this case one that you create that contains…
Background What I'm presenting in this article is the result of 2 conditions in my work area: We have a SQL Server production environment but no development or test environment; andWe have an MS Access front end using tables in SQL Server but we a…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

867 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now