Rob
/
FrymasterVB
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
FrymasterVB/SPOOLER1.FRM

690 lines
21 KiB
Plaintext
Raw Permalink Normal View History

first commit
2024-12-18 13:56:36 -06:00
VERSION 5.00
Begin VB.Form frmPSSpooler
Caption = "Post Script File Spooler"
ClientHeight = 7950
ClientLeft = 60
ClientTop = 345
ClientWidth = 11205
Icon = "SPOOLER1.frx":0000
LinkTopic = "Form1"
ScaleHeight = 7950
ScaleWidth = 11205
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdClearlstLog
Caption = "clear"
Height = 195
Left = 1320
TabIndex = 16
Top = 4200
Width = 735
End
Begin VB.FileListBox filDistilled
Height = 675
Left = 90
Pattern = "*.pdf"
TabIndex = 15
Top = 6540
Width = 5295
End
Begin VB.CommandButton cmdHide
Caption = "Hide"
Height = 255
Left = 10020
TabIndex = 14
Top = 60
Width = 945
End
Begin VB.ListBox lstDistilled
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 780
ItemData = "SPOOLER1.frx":27A2
Left = 5430
List = "SPOOLER1.frx":27A4
TabIndex = 13
Top = 5700
Width = 5295
End
Begin VB.ListBox lstDistiller
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 780
ItemData = "SPOOLER1.frx":27A6
Left = 180
List = "SPOOLER1.frx":27A8
TabIndex = 11
Top = 5700
Width = 5295
End
Begin VB.CheckBox Scanning
Caption = "Scanning"
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 7230
TabIndex = 10
Top = 60
Value = 1 'Checked
Width = 1545
End
Begin VB.ListBox lstLog
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1020
ItemData = "SPOOLER1.frx":27AA
Left = 180
List = "SPOOLER1.frx":27AC
TabIndex = 8
Top = 4380
Width = 18495
End
Begin VB.CommandButton cmdTest
Caption = "Test Print"
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 675
Left = 7200
TabIndex = 7
Top = 390
Width = 1665
End
Begin VB.ListBox lstLocalQs
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2460
Left = 3330
TabIndex = 5
Top = 330
Width = 3825
End
Begin VB.Timer Timer1
Interval = 1000
Left = 2490
Top = 60
End
Begin VB.CommandButton cmdPrintFromList
Caption = "Print File From List"
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 675
Left = 7200
TabIndex = 4
Top = 1080
Width = 1665
End
Begin VB.ListBox lstFiles
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1020
ItemData = "SPOOLER1.frx":27AE
Left = 60
List = "SPOOLER1.frx":27B0
TabIndex = 2
Top = 3090
Width = 18555
End
Begin VB.ListBox lstPrintQs
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2460
Left = 120
TabIndex = 0
Top = 330
Width = 3165
End
Begin VB.Label Label5
Caption = "Files to Distill"
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 120
TabIndex = 12
Top = 5430
Width = 4815
End
Begin VB.Label Label4
Caption = "Error Log double click to copy buffer "
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 120
TabIndex = 9
Top = 4110
Width = 5955
End
Begin VB.Label Label3
Caption = "Local Printers Loaded"
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 3360
TabIndex = 6
Top = 60
Width = 3825
End
Begin VB.Label Label2
Caption = "Files to Print"
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 120
TabIndex = 3
Top = 2820
Width = 4815
End
Begin VB.Label Label1
Caption = "Printer Queues"
BeginProperty Font
Name = "Courier New"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 120
TabIndex = 1
Top = 60
Width = 2235
End
End
Attribute VB_Name = "frmPSSpooler"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Copyright <20> 1997 by Desaware Inc. All Rights Reserved.
'**********************************
'** Type Definitions:
#If Win32 Then
Private Type DOC_INFO_1
pDocName As String
pOutputFile As String
pDatatype As String
End Type
#End If 'WIN32 Types
'**********************************
'** Function Declarations:
#If Win32 Then
Private Declare Function OpenPrinter& Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, ByVal pDefault As Long) ' Third param changed to long
Private Declare Function StartDocPrinter& Lib "winspool.drv" Alias "StartDocPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pDocInfo As DOC_INFO_1)
Private Declare Function StartPagePrinter& Lib "winspool.drv" (ByVal hPrinter As Long)
Private Declare Function WritePrinter& Lib "winspool.drv" (ByVal hPrinter As Long, pBuf As Any, ByVal cdBuf As Long, pcWritten As Long)
Private Declare Function EndDocPrinter& Lib "winspool.drv" (ByVal hPrinter As Long)
Private Declare Function EndPagePrinter& Lib "winspool.drv" (ByVal hPrinter As Long)
Private Declare Function ClosePrinter& Lib "winspool.drv" (ByVal hPrinter As Long)
#End If 'WIN32
Dim DistillPathIn$, DistillPathOut$, userdataarea$, haldataarea$, engrdataarea$, svcdataarea$, bdvdataarea$, anyonedataarea$
Dim chinadataarea$, MCFdataarea$, HZdataarea$
Private Sub cmdClearlstLog_Click()
lstLog.Clear
End Sub
Private Sub cmdHide_Click()
frmPSSpooler.Hide
End Sub
Private Sub cmdPrintFromList_Click()
Call PrintFile
End Sub
Private Sub addlstLog(st$)
lstLog.AddItem st$ + "|" + Date$ + " " + Time$
End Sub
Private Sub cmdResendtoLst_Click()
End Sub
Private Sub cmdTest_Click()
a$ = "|c:\files\buffers\cmdpbuff.ps"
pr$ = lstPrintQs.List(lstPrintQs.ListIndex)
If pr$ <> "" Then
If left(pr$, 7) = "DISTILL" Then
lstDistiller.AddItem "DONLEY-9109999" + a$
Else
If InStr(pr$, "queue not available") <> 0 Then
a$ = pr$ + a$ + "|Printer Selected for TEST not available"
Call addlstLog(a$)
Else
pr$ = pr$ + a$
lstFiles.AddItem pr$
End If
End If
Else
a$ = a$ + "|No Printer Selected for TEST"
Call addlstLog(a$)
End If
End Sub
Private Sub Command1_Click()
End Sub
Private Sub Form_Load()
frmPSSpooler.Caption = "Post Script File Spooler Version " + AppRevision$
Dim c As Collection
Dim sp As New dwSpool
Dim obj As Object
'DistillPathIn$ = "\\fm1\eng\users\286\CMNDPROC\in\"
'DistillPathOut$ = "\\fm1\eng\users\286\CMNDPROC\out\"
'filDistilled.Path = DistillPathOut$
'userdataarea$ = "\\fm1\DATA\DEPTS\PURCH\PDFDrawings\"
'engrdataarea$ = "\\fm1\eng\users\"
'svcdataarea$ = "\\fm1\service\USERS\"
'bdvdataarea$ = "\\fm1\DATA\DEPTS\BUSDEV\"
'anyonedataarea$ = "\\fm1\DATA\USERS\"
'haldataarea$ = "\\qhal\wwwroot\EMAILDRAWINGS"
'chinadataarea$ = "\\qhal\wwwroot\EMAILDRAWINGS\CHINADRAWINGS"
'MCFdataarea$ = "\\qhal\wwwroot\EMAILDRAWINGS\MCFDRAWINGS"
'Open "\\fm1\eng\users\cadprint\printer.cfg" For Input As #13 'using #13
DistillPathIn$ = NETDRV + "\eng\users\286\CMNDPROC\in\"
DistillPathOut$ = NETDRV + "\eng\users\286\CMNDPROC\out\"
filDistilled.Path = DistillPathOut$
userdataarea$ = NETDRV + "\DATA\DEPTS\PURCH\PDFDrawings\"
engrdataarea$ = NETDRV + "\eng\users\"
svcdataarea$ = NETDRV + "\service\USERS\"
bdvdataarea$ = NETDRV + "\DATA\DEPTS\BUSDEV\"
anyonedataarea$ = NETDRV + "\DATA\USERS\"
haldataarea$ = NETHAL + "\wwwroot\EMAILDRAWINGS"
chinadataarea$ = NETHAL + "\wwwroot\EMAILDRAWINGS\CHINADRAWINGS"
MCFdataarea$ = NETHAL + "\wwwroot\EMAILDRAWINGS\MCFDRAWINGS"
HZdataarea$ = NETHAL + "\wwwroot\EMAILDRAWINGS\HZDRAWINGS"
Open NETDRV + "\eng\users\cadprint\printer.cfg" For Input As #13 'using #13
While Not EOF(13)
Line Input #13, prt$
If left$(prt$, 1) <> ";" Then
prt$ = Trim$(Mid$(prt$, 19, 15))
lstPrintQs.AddItem prt$
End If
Wend
Close #13
lstLocalQs.Clear
lstDistiller.Clear
Set c = sp.EnumPrinters(PRINTER_ENUM_LOCAL, "", 1)
For Each obj In c
lstLocalQs.AddItem obj.pName
Next
For i = 0 To lstPrintQs.ListCount - 1
prt$ = lstPrintQs.List(i)
fnd = False
For j = 0 To lstLocalQs.ListCount - 1
If UCase(prt$) = UCase(lstLocalQs.List(j)) Then
fnd = True
Exit For
End If
Next
If fnd = False Then
lstPrintQs.List(i) = prt$ + " - queue not available"
End If
Next
End Sub
Private Sub PrintFile()
If lstFiles.ListCount > 0 Then
fln$ = lstFiles.List(0)
Req$ = fln$
lstFiles.RemoveItem 0
q = InStr(fln$, "|")
queue$ = UCase$(left(fln$, q - 1))
fln$ = Mid(fln$, q + 1)
Prntr$ = ""
For i = 0 To lstPrintQs.ListCount - 1
If queue$ = UCase(lstPrintQs.List(i)) Then
Prntr$ = queue$
Exit For
End If
Next
If Prntr$ <> "" Then
If Not (ExistsNew(fln$)) Then
Pause 3
End If
If ExistsNew(fln$) Then
Call PrintIt(Prntr$, fln$, RC%)
If RC <> 0 Then
Call addlstLog(Req$ + "|print error" + Str(RC%))
End If
Else
Call addlstLog(Req$ + "|file does not exist")
End If
Else
Call addlstLog(Req$ + "|no such printer")
End If
End If
If lstDistiller.ListCount > 0 Then
fln$ = lstDistiller.List(0)
Req$ = fln$
lstDistiller.RemoveItem 0
q = InStr(fln$, "|")
Who$ = UCase$(left(fln$, q - 1))
fln$ = Mid(fln$, q + 1)
If Not (ExistsNew(fln$)) Then
Pause 3
End If
If ExistsNew(fln$) Then
Call Fcopy(fln$, DistillPathIn$ + Who$ + ".ps", RC%)
If RC <> 0 Then
Pause 3
Call Fcopy(fln$, DistillPathIn$ + Who$ + ".ps", RC%)
If RC <> 0 Then
Call addlstLog(Req$ + "|copy error" + Str(RC%))
End If
End If
Else
Call addlstLog(Req$ + "|file does not exist")
End If
End If
filDistilled.Refresh
For idx = 0 To filDistilled.ListCount - 1
fl$ = UCase(filDistilled.List(idx))
fndfl = False
For icx = 0 To lstDistilled.ListCount - 1
xxx$ = lstDistilled.List(icx)
q = InStr(xxx$, "|")
xy$ = UCase$(left(xxx$, q - 1))
tg$ = UCase$(Mid(xxx$, q + 1))
If xy$ = fl$ Then
fndfl = True
Exit For
End If
Next
If Not (fndfl) Then
lstDistilled.AddItem fl$ + "|15"
End If
Next
icx = 0
Do While icx <= lstDistilled.ListCount - 1
xxx$ = lstDistilled.List(icx)
q = InStr(xxx$, "|")
xy$ = UCase$(left(xxx$, q - 1))
cnt = Val(UCase$(Mid(xxx$, q + 1))) - 1
If cnt <= 0 Then
f$ = DistillPathOut$ + xy$
q = InStr(xxx$, "-")
If q > 0 Then
WhoGetsIt$ = Trim(UCase$(left(xxx$, q - 1)))
If (WhoGetsIt$ = "QHAL") Or (WhoGetsIt$ = "CHINA") Or (WhoGetsIt$ = "MCF") Then
Select Case WhoGetsIt$
Case "QHAL"
usrs$ = haldataarea$ + "\"
Case "CHINA"
usrs$ = chinadataarea$ + "\"
Case "MCF"
usrs$ = MCFdataarea$ + "\"
Case "HZ"
usrs$ = HZdataarea$ + "\"
Case Else
usrs$ = haldataarea$ + "\"
End Select
Else
If left$(WhoGetsIt$, 10) = "DISTILLENG" Then
usrs$ = engrdataarea$ + Mid(WhoGetsIt$, 11) + "\"
ElseIf left$(WhoGetsIt$, 10) = "DISTILLSVC" Then
usrs$ = svcdataarea$ + Mid(WhoGetsIt$, 11) + "\"
ElseIf left$(WhoGetsIt$, 10) = "DISTILLBDV" Then
usrs$ = bdvdataarea$ + Mid(WhoGetsIt$, 11) + "\"
ElseIf left$(WhoGetsIt$, 10) = "DISTILLANY" Then
usrs$ = anyonedataarea$ + Mid(WhoGetsIt$, 11) + "\"
Else
usrs$ = userdataarea$ + WhoGetsIt$ + "\"
End If
End If
t$ = usrs$ + UCase$(Mid(xxx$, q + 1))
t$ = left(t$, Len(t$) - 2)
Call Fcopy(f$, t$, RC%)
If RC% <> 0 Then
If InStr(usrs$, "AUTHORIZED") = 0 Then
Pause 2
Call Fcopy(f$, t$, RC%)
Pause 3
If RC% <> 0 Then
Call addlstLog(f$ + "|from copy to user failed|" + Str(RC%))
Call addlstLog(t$ + "|to copy to user failed|" + Str(RC%))
End If
End If
End If
Else
Call addlstLog(f$ + "|File name format invalid|-1")
Select Case WhoGetsIt$
Case "QHAL"
usrs$ = haldataarea$ + "\"
Case "CHINA"
usrs$ = chinadataarea$ + "\"
Case "MCF"
usrs$ = MCFdataarea$ + "\"
Case "HZ"
usrs$ = HZdataarea$ + "\"
Case Else
usrs$ = haldataarea$ + "\"
End Select
t$ = usrs$ + UCase$(Mid(xxx$, q + 1))
t$ = left(t$, Len(t$) - 2)
Call Fcopy(f$, t$, RC%)
If RC% <> 0 Then
Pause 2
Call Fcopy(f$, t$, RC%)
Pause 3
If RC% <> 0 Then
Call addlstLog(f$ + "|from copy to user failed|" + Str(RC%))
Call addlstLog(t$ + "|to copy to user failed|" + Str(RC%))
End If
End If
End If
If Not KillIt(f$) Then PrintLog "---------- Failed to delete " + f$ + " Removing distiller file"
lstDistilled.RemoveItem (icx)
Else
lstDistilled.List(icx) = xy$ + "|" + Trim(Str(cnt))
icx = icx + 1
End If
Loop
End Sub
Private Sub PrintIt(Prntr$, fln$, RC%)
Dim hPrinter&
Dim jobid&
Dim res&, itsaText
Dim written&
Dim printdata$
Dim docinfo As DOC_INFO_1
If UCase(right(fln, 3)) = "TXT" Then
itsaText = True
Else
itsaText = False
End If
RC% = 0
res& = OpenPrinter(Prntr$, hPrinter, 0)
If res = 0 Then
RC% = 1 'unable to open printer
Exit Sub
End If
spname$ = UCase(BreakFileName(fln$, 4))
If spname$ = "" Then spname$ = "Spooler"
docinfo.pDocName = spname$
docinfo.pOutputFile = vbNullString
docinfo.pDatatype = vbNullString
jobid = StartDocPrinter(hPrinter, 1, docinfo)
Call StartPagePrinter(hPrinter)
Open fln$ For Input As #27 'using #27
While Not EOF(27)
Line Input #27, printdata$
If itsaText = True Then
printdata$ = printdata$ + vbCrLf
Else
printdata$ = printdata$ + Chr$(10)
End If
Call WritePrinter(hPrinter, ByVal printdata$, Len(printdata$), written)
Wend
Close #27
Call EndPagePrinter(hPrinter)
Call EndDocPrinter(hPrinter)
Call ClosePrinter(hPrinter) ' Close when done
End Sub
Private Sub PrintItText(Prntr$, fln$, RC%)
Dim hPrinter&
Dim jobid&
Dim res&
Dim written&
Dim printdata$
Dim docinfo As DOC_INFO_1
RC% = 0
res& = OpenPrinter(Prntr$, hPrinter, 0)
If res = 0 Then
RC% = 1 'unable to open printer
Exit Sub
End If
spname$ = UCase(left$(right$(fln$, 10), 8))
If spname$ = "" Then spname$ = "Spooler"
docinfo.pDocName = spname$
docinfo.pOutputFile = vbNullString
docinfo.pDatatype = vbNullString
jobid = StartDocPrinter(hPrinter, 1, docinfo)
Call StartPagePrinter(hPrinter)
Open fln$ For Input As #26 'using #26
While Not EOF(26)
Line Input #26, printdata$
printdata$ = printdata$ + vbCrLf
Call WritePrinter(hPrinter, ByVal printdata$, Len(printdata$), written)
Wend
Close #26
Call EndPagePrinter(hPrinter)
Call EndDocPrinter(hPrinter)
Call ClosePrinter(hPrinter) ' Close when done
End Sub
Private Sub lstLog_DblClick()
Clipboard.Clear
Z$ = lstLog.List(lstLog.ListIndex)
Clipboard.SetText (Z$)
End Sub
Private Sub Timer1_Timer()
If Timer1.Tag = "" Then
Timer1.Tag = "Busy"
If Scanning = 1 Then
Call PrintFile
End If
If lstLog.ListCount > 1000 Then
lstLog.RemoveItem (0)
End If
Timer1.Tag = ""
End If
End Sub