home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 June / Chip_2001-06_cd1.bin / zkuste / vbasic / Data / Zdroj / printer.bas < prev    next >
BASIC Source File  |  1999-09-20  |  10KB  |  280 lines
  1. Attribute VB_Name = "modPrinter"
  2. Option Explicit
  3. '------------------------------------------------------------
  4. ' SC Productions
  5. ' Name: RFN
  6. ' Company: SCP
  7. ' Purpose: Mod for all Printer const, types, and declairs
  8. ' Parameters: varies
  9. ' Date: June,24 99
  10. '------------------------------------------------------------
  11. Public Const NULLPTR = 0&
  12. ' Constants for DEVMODE
  13. Public Const CCHDEVICENAME = 32
  14. Public Const CCHFORMNAME = 32
  15. ' Constants for DocumentProperties
  16. Public Const DM_MODIFY = 8
  17. Public Const DM_COPY = 2
  18. Public Const DM_IN_BUFFER = DM_MODIFY
  19. Public Const DM_OUT_BUFFER = DM_COPY
  20. ' Constants for dmOrientation
  21. Public Const DMORIENT_PORTRAIT = 1
  22. Public Const DMORIENT_LANDSCAPE = 2
  23. ' Constants for dmPrintQuality
  24. Public Const DMRES_DRAFT = (-1)
  25. Public Const DMRES_HIGH = (-4)
  26. Public Const DMRES_LOW = (-2)
  27. Public Const DMRES_MEDIUM = (-3)
  28. ' Constants for dmTTOption
  29. Public Const DMTT_BITMAP = 1
  30. Public Const DMTT_DOWNLOAD = 2
  31. Public Const DMTT_DOWNLOAD_OUTLINE = 4
  32. Public Const DMTT_SUBDEV = 3
  33. ' Constants for dmColor
  34. Public Const DMCOLOR_COLOR = 2
  35. Public Const DMCOLOR_MONOCHROME = 1
  36.  
  37. Public Type DEVMODE
  38.     dmDeviceName(1 To CCHDEVICENAME) As Byte
  39.     dmSpecVersion As Integer
  40.     dmDriverVersion As Integer
  41.     dmSize As Integer
  42.     dmDriverExtra As Integer
  43.     dmFields As Long
  44.     dmOrientation As Integer
  45.     dmPaperSize As Integer
  46.     dmPaperLength As Integer
  47.     dmPaperWidth As Integer
  48.     dmScale As Integer
  49.     dmCopies As Integer
  50.     dmDefaultSource As Integer
  51.     dmPrintQuality As Integer
  52.     dmColor As Integer
  53.     dmDuplex As Integer
  54.     dmYResolution As Integer
  55.     dmTTOption As Integer
  56.     dmCollate As Integer
  57.     dmFormName(1 To CCHFORMNAME) As Byte
  58.     dmUnusedPadding As Integer
  59.     dmBitsPerPel As Integer
  60.     dmPelsWidth As Long
  61.     dmPelsHeight As Long
  62.     dmDisplayFlags As Long
  63.     dmDisplayFrequency As Long
  64. End Type
  65.  
  66.  
  67. Public Declare Function OpenPrinter Lib "winspool.drv" Alias _
  68.         "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
  69.         ByVal pDefault As Long) As Long
  70.  
  71. Public Declare Function DocumentProperties Lib "winspool.drv" _
  72.         Alias "DocumentPropertiesA" (ByVal hwnd As Long, _
  73.         ByVal hPrinter As Long, ByVal pDeviceName As String, _
  74.         pDevModeOutput As Any, pDevModeInput As Any, ByVal fMode As Long) _
  75.         As Long
  76.  
  77. Public Declare Function ClosePrinter Lib "winspool.drv" _
  78.         (ByVal hPrinter As Long) As Long
  79.  
  80. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
  81.         (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
  82.  
  83. Private Declare Function GetProfileString Lib "kernel32" Alias _
  84.         "GetProfileStringA" (ByVal lpAppName As String, _
  85.         ByVal lpKeyName As String, ByVal lpDefault As String, _
  86.         ByVal lpReturnedString As String, _
  87.         ByVal nSize As Long) As Long
  88.  
  89. Private Declare Function EnumDisplaySettings Lib _
  90.         "user32" Alias "EnumDisplaySettingsA" _
  91.         (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, _
  92.         lpDevMode As Any) As Boolean
  93.  
  94. Public Sub EnumDisplay()
  95.  
  96.     Dim lTemp As Long, tDevMode As DEVMODE, lIndex As Long
  97.     ' Declare variables
  98.     lIndex = 0
  99.     Do
  100.         lTemp = EnumDisplaySettings(0&, lIndex, tDevMode)
  101.         ' Call the API function with the current index
  102.         If lTemp = 0 Then Exit Do
  103.         ' If the API function returns 0 then no more
  104.         ' data is availible or an error has occurred.
  105.         ' As you increase the index on each call
  106.         ' when there is no more data to enumerate the
  107.         ' function will return 0
  108.  
  109.         With tDevMode
  110.             FormSSI.List1.AddItem .dmPelsWidth & " pixels by " _
  111.                     & .dmPelsHeight & " pixels, Color Mode " _
  112.                     & .dmBitsPerPel & " bit"
  113.             'Debug.Print .dmPelsWidth & " pixels by " _
  114.              '& .dmPelsHeight & " pixels, Color Mode " _
  115.              '& .dmBitsPerPel & " bit"
  116.             ' Print the mode information to the debug
  117.         End With
  118.  
  119.         lIndex = lIndex + 1
  120.     Loop
  121. End Sub
  122. '------------------------------------------------------------
  123. ' Name: Nall
  124. ' Company: SC Productions
  125. ' Purpose: Retrive the printer settings
  126. ' Parameters: As shown below
  127. ' Date: June,01 99' Time: 21:47
  128. '------------------------------------------------------------
  129. Private Function StripNulls(startStrg As String) As String
  130.     Dim c As Integer
  131.     Dim item As String
  132.     c = 1
  133.     Do
  134.         If Mid(startStrg, c, 1) = Chr(0) Then
  135.             item = Mid(startStrg, 1, c - 1)
  136.             startStrg = Mid(startStrg, c + 1, Len(startStrg))
  137.             StripNulls = item
  138.             Exit Function
  139.         End If
  140.         c = c + 1
  141.     Loop
  142. End Function
  143. Function ByteToString(ByteArray() As Byte) As String
  144.     Dim TempStr As String
  145.     Dim i As Integer
  146.  
  147.     For i = 1 To CCHDEVICENAME
  148.         TempStr = TempStr & Chr(ByteArray(i))
  149.     Next i
  150.     ByteToString = StripNulls(TempStr)
  151. End Function
  152. Function GetPrinterSettings(szPrinterName As String, hdc As Long) _
  153.             As Boolean
  154.     On Error GoTo Err
  155.     Dim hPrinter As Long
  156.     Dim nSize As Long
  157.     Dim pDevMode As DEVMODE
  158.     Dim aDevMode() As Byte
  159.     Dim TempStr As String
  160.  
  161.     If OpenPrinter(szPrinterName, hPrinter, NULLPTR) Then
  162.         nSize = DocumentProperties(NULLPTR, hPrinter, szPrinterName, _
  163.                 NULLPTR, NULLPTR, 0)
  164.         ReDim aDevMode(1 To nSize)
  165.         nSize = DocumentProperties(NULLPTR, hPrinter, szPrinterName, _
  166.                 aDevMode(1), NULLPTR, DM_OUT_BUFFER)
  167.         Call CopyMemory(pDevMode, aDevMode(1), Len(pDevMode))
  168.  
  169.         FormSSI.List2.Clear   ' empty the ListBox
  170.         FormSSI.List2.AddItem "Printer Name: " & _
  171.                 ByteToString(pDevMode.dmDeviceName)
  172.  
  173.         If pDevMode.dmOrientation = DMORIENT_PORTRAIT Then
  174.             TempStr = "PORTRAIT"
  175.         ElseIf pDevMode.dmOrientation = DMORIENT_LANDSCAPE Then
  176.             TempStr = "LANDSCAPE"
  177.         Else
  178.             TempStr = "UNDEFINED"
  179.         End If
  180.         FormSSI.List2.AddItem "Orientation: " & TempStr
  181.  
  182.         Select Case pDevMode.dmPrintQuality
  183.             Case DMRES_DRAFT
  184.                 TempStr = "DRAFT"
  185.             Case DMRES_HIGH
  186.                 TempStr = "HIGH"
  187.             Case DMRES_LOW
  188.                 TempStr = "LOW"
  189.             Case DMRES_MEDIUM
  190.                 TempStr = "MEDIUM"
  191.             Case Else   ' positive value
  192.                 TempStr = CStr(pDevMode.dmPrintQuality) & " dpi"
  193.         End Select
  194.         FormSSI.List2.AddItem "Print Quality: " & TempStr
  195.  
  196.         Select Case pDevMode.dmTTOption
  197.             Case DMTT_BITMAP    ' default for dot-matrix printers
  198.                 TempStr = "TrueType fonts as graphics"
  199.             Case DMTT_DOWNLOAD  ' default for HP printers that use PCL
  200.                 TempStr = "Downloads TrueType fonts as soft fonts"
  201.             Case DMTT_SUBDEV    ' default for PostScript printers
  202.                 TempStr = "Substitute device fonts for TrueType fonts"
  203.             Case Else
  204.                 TempStr = "UNDEFINED"
  205.         End Select
  206.         FormSSI.List2.AddItem "TrueType Option: " & TempStr
  207.  
  208.         ' Windows NT drivers often return COLOR from Monochrome printers
  209.         If pDevMode.dmColor = DMCOLOR_MONOCHROME Then
  210.             TempStr = "MONOCHROME"
  211.         ElseIf pDevMode.dmColor = DMCOLOR_COLOR Then
  212.             TempStr = "COLOR"
  213.         Else
  214.             TempStr = "UNDEFINED"
  215.         End If
  216.         FormSSI.List2.AddItem "Color or Monochrome: " & TempStr
  217.  
  218.         If pDevMode.dmScale = 0 Then
  219.             TempStr = "NONE"
  220.         Else
  221.             TempStr = CStr(pDevMode.dmScale)
  222.         End If
  223.         FormSSI.List2.AddItem "Scale Factor: " & TempStr
  224.  
  225.         FormSSI.List2.AddItem "Y Resolution: " & pDevMode.dmYResolution & " dpi"
  226.         FormSSI.List2.AddItem "Copies: " & CStr(pDevMode.dmCopies)
  227.         ' Add any other items of interest ...
  228.  
  229.         Call ClosePrinter(hPrinter)
  230.         GetPrinterSettings = True
  231.     Else
  232.         GetPrinterSettings = False
  233.     End If
  234.  
  235. Err:
  236.     If Err.Number = 0 Then
  237.         Exit Function
  238.     Else
  239.         WriteError Err.Number, Err.Description, "Get Printer Settings", Now, App.Path & "\err.log"
  240.         MsgBox Err.Description, vbCritical + vbOKOnly, "Get Printer Settings"
  241.     End If
  242.  
  243. End Function
  244.  
  245. Public Function GetDefaultPrinter() As Printer
  246.     On Error GoTo Err
  247.     Dim strBuffer As String * 254
  248.     Dim iRetValue As Long
  249.     Dim strDefaultPrinterInfo As String
  250.     Dim tblDefaultPrinterInfo() As String
  251.     Dim objPrinter As Printer
  252.  
  253.     ' Retreive current default printer information
  254.     iRetValue = GetProfileString("windows", "device", ",,,", strBuffer, 254)
  255.     strDefaultPrinterInfo = Left(strBuffer, InStr(strBuffer, Chr(0)) - 1)
  256.     tblDefaultPrinterInfo = Split(strDefaultPrinterInfo, ",")
  257.     For Each objPrinter In Printers
  258.         If objPrinter.DeviceName = tblDefaultPrinterInfo(0) Then
  259.             ' Default printer found !
  260.             Exit For
  261.         End If
  262.     Next
  263.  
  264.     ' If not found, return nothing
  265.     If objPrinter.DeviceName <> tblDefaultPrinterInfo(0) Then
  266.         Set objPrinter = Nothing
  267.     End If
  268.  
  269.     Set GetDefaultPrinter = objPrinter
  270. Err:
  271.     If Err.Number = 0 Then
  272.         Exit Function
  273.     Else
  274.         WriteError Err.Number, Err.Description, "Get Default Printer", Now, App.Path & "\err.log"
  275.         Exit Function
  276.         'MsgBox Err.Description, vbCritical + vbOKOnly, "Get Default Printer"
  277.     End If
  278.  
  279. End Function
  280.