first commit

main
Ryland 2024-12-18 13:56:36 -06:00
commit 293c16e220
44 changed files with 10475 additions and 0 deletions

105
APIGID32.BAS Normal file
View File

@ -0,0 +1,105 @@
Attribute VB_Name = "APIGuide32"
Option Explicit
' ------------------------------------------------------------------------
'
' APIGID32.BAS -- APIGID32.DLL API Declarations for Visual Basic
'
' Copyright (C) 1992-1996 Desaware
'
' You have a royalty-free right to use, modify, reproduce and distribute
' this file (and/or any modified version) in any way you find useful,
' provided that you agree that Desaware and Ziff-Davis Press has no
' warranty, obligation or liability for its contents.
' Refer to the Ziff-Davis Visual Basic Programmer's Guide to the
' Win32 API for further information.
'
' ------------------------------------------------------------------------
Type POINTS
x As Integer
y As Integer
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
#If Win32 Then
Declare Function agGetInstance& Lib "apigid32.dll" ()
Declare Function agPOINTStoLong& Lib "apigid32.dll" (pt As POINTS)
Declare Sub agCopyData Lib "apigid32.dll" (source As Any, dest As Any, ByVal nCount&)
Declare Sub agCopyDataBynum Lib "apigid32.dll" Alias "agCopyData" (ByVal source&, ByVal dest&, ByVal nCount&)
Declare Function agGetAddressForObject& Lib "apigid32.dll" (object As Any)
Declare Function agGetAddressForInteger& Lib "apigid32.dll" Alias "agGetAddressForObject" (intnum%)
Declare Function agGetAddressForLong& Lib "apigid32.dll" Alias "agGetAddressForObject" (intnum&)
Declare Function agGetAddressForLPSTR& Lib "apigid32.dll" Alias "agGetAddressForObject" (ByVal lpstring$) ' See warning!
Declare Function agGetAddressForVBString& Lib "apigid32.dll" (vbstring$)
Declare Function agGetStringFrom2NullBuffer$ Lib "apigid32.dll" (ByVal ptr&)
Declare Function agGetStringFromLPSTR$ Lib "apigid32.dll" (ByVal src$)
Declare Function agGetStringFromPointer$ Lib "apigid32.dll" Alias "agGetStringFromLPSTR" (ByVal ptr&)
Declare Function agSwapBytes% Lib "apigid32.dll" (ByVal src%)
Declare Function agSwapWords& Lib "apigid32.dll" (ByVal src&)
Declare Function agMakeROP4& Lib "apigid32.dll" (ByVal foreground&, ByVal background&)
Declare Function agGetWndInstance& Lib "apigid32.dll" (ByVal hwnd&)
Declare Function agDWORDto2Integers& Lib "apigid32.dll" (ByVal l&, lw%, lh%)
Declare Function agIsValidName& Lib "apigid32.dll" (ByVal o As Object, ByVal lpname$)
Declare Function agInp% Lib "apigid32.dll" (ByVal portid%)
Declare Function agInpw% Lib "apigid32.dll" (ByVal portid%)
Declare Function agInpd& Lib "apigid32.dll" (ByVal portid%)
Declare Sub agOutp Lib "apigid32.dll" (ByVal portid%, ByVal outval%)
Declare Sub agOutpw Lib "apigid32.dll" (ByVal portid%, ByVal outval%)
Declare Sub agOutpd Lib "apigid32.dll" (ByVal portid%, ByVal outval&)
' Declared As Any to allow it to be used within classes, not to mention by other
' double long structures
Declare Sub agSubtractFileTimes Lib "apigid32.dll" (f1 As Any, f2 As Any, f3 As Any)
Declare Sub agAddFileTimes Lib "apigid32.dll" (f1 As Any, f2 As Any, f3 As Any)
Declare Sub agNegateFileTime Lib "apigid32.dll" (f1 As Any)
Declare Function agConvertFileTimeToDouble Lib "apigid32.dll" (f1 As Any) As Double
Declare Sub agConvertDoubleToFileTime Lib "apigid32.dll" (ByVal d As Double, f1 As Any)
#Else
' Note, not all 16 bit declarations have equivalent 32 bit functions
' and vice versa. Nor is their behavior always identical.
' Refer to the Visual Basic Programmer's Guide to the Windows API (16 bit)
' for documentation on the following functions
Global Const CTLFLG_USESPALETTE% = 2
Global Const CTLFLG_HASPALETTE% = 1
Declare Function agGetControlHwnd% Lib "Apiguide.dll" (hctl As Control)
Declare Function agGetInstance% Lib "Apiguide.dll" ()
Declare Sub agCopyData Lib "Apiguide.dll" (source As Any, dest As Any, ByVal nCount%)
Declare Sub agCopyDataBynum Lib "Apiguide.dll" Alias "agCopyData" (ByVal source&, ByVal dest&, ByVal nCount%)
Declare Function agGetAddressForObject& Lib "Apiguide.dll" (object As Any)
Declare Function agGetAddressForInteger& Lib "Apiguide.dll" Alias "agGetAddressForObject" (intnum%)
Declare Function agGetAddressForLong& Lib "Apiguide.dll" Alias "agGetAddressForObject" (intnum&)
Declare Function agGetAddressForLPSTR& Lib "Apiguide.dll" Alias "agGetAddressForObject" (ByVal lpstring$)
Declare Function agGetAddressForVBString& Lib "Apiguide.dll" (vbstring$)
Declare Function agGetStringFromLPSTR$ Lib "Apiguide.dll" (ByVal lpstring$)
Declare Function agGetControlName$ Lib "Apiguide.dll" (ByVal hwnd%)
Declare Function agPOINTAPItoLong& Lib "Apiguide.dll" (pt As POINTAPI)
Declare Function agPOINTStoLong& Lib "Apiguide.dll" Alias "agPOINTAPItoLong" (pt As POINTS)
Declare Sub agDWORDto2Integers Lib "Apiguide.dll" (ByVal l&, lw%, lh%)
Declare Function agXPixelsToTwips& Lib "Apiguide.dll" (ByVal pixels%)
Declare Function agYPixelsToTwips& Lib "Apiguide.dll" (ByVal pixels%)
Declare Function agXTwipsToPixels% Lib "Apiguide.dll" (ByVal twips&)
Declare Function agYTwipsToPixels% Lib "Apiguide.dll" (ByVal twips&)
Declare Function agDeviceCapabilities& Lib "Apiguide.dll" (ByVal hlib%, ByVal lpszDevice$, ByVal lpszPort$, ByVal fwCapability%, ByVal lpszOutput&, ByVal lpdm&)
Declare Function agDeviceMode% Lib "Apiguide.dll" (ByVal hwnd%, ByVal hModule%, ByVal lpszDevice$, ByVal lpszOutput$)
Declare Function agExtDeviceMode% Lib "Apiguide.dll" (ByVal hwnd%, ByVal hDriver%, ByVal lpdmOutput&, ByVal lpszDevice$, ByVal lpszPort$, ByVal lpdmInput&, ByVal lpszProfile&, ByVal fwMode%)
Declare Function agInp% Lib "Apiguide.dll" (ByVal portid%)
Declare Function agInpw% Lib "Apiguide.dll" (ByVal portid%)
Declare Sub agOutp Lib "Apiguide.dll" (ByVal portid%, ByVal outval%)
Declare Sub agOutpw Lib "Apiguide.dll" (ByVal portid%, ByVal outval%)
Declare Function agHugeOffset& Lib "Apiguide.dll" (ByVal addr&, ByVal offset&)
Declare Function agVBGetVersion% Lib "Apiguide.dll" ()
Declare Function agVBSendControlMsg& Lib "Apiguide.dll" (ctl As Control, ByVal msg%, ByVal wp%, ByVal lp&)
Declare Function agVBSetControlFlags& Lib "Apiguide.dll" (ctl As Control, ByVal mask&, ByVal value&)
Declare Sub agVBScreenToClient Lib "Apiguide.dll" (ctl As Control, pap As POINTS)
Declare Sub agVBClientToScreen Lib "Apiguide.dll" (ctl As Control, pap As POINTS)
Declare Function dwVBSetControlFlags& Lib "Apiguide.dll" (ctl As Control, ByVal mask&, ByVal value&)
#End If

2423
CMNDPROC.BAS Normal file

File diff suppressed because it is too large Load Diff

119
CMNDPROC.PDM Normal file
View File

@ -0,0 +1,119 @@
[Root]
Most Recent Package=Standard Setup Package 1
[Package|Standard Setup Package 1|Root]
SubWizProgID=PDWizard.SetupPkgSubWiz
BuildFolder=u:\QCOMMAND\NewCMD\setup
[Package|Standard Setup Package 1|Configure DAO ISAMs]
Applicable=No
[Package|Standard Setup Package 1|Configure DAO ODBC]
JetWorkspace=
ODBCDirect=
[Package|Standard Setup Package 1|Files Found]
[Package|Standard Setup Package 1|Files Released]
Apiguide.dll=
[Package|Standard Setup Package 1|Missing Dependency Information]
C:\Program Files\Common Files\System\ado\msado25.tlb=
C:\WINDOWS\system32\apigid32.dll=
[Package|Standard Setup Package 1|Out-of-Date Dependency Information]
C:\WINDOWS\system32\TABCTL32.OCX=
C:\WINDOWS\system32\scrrun.dll=
C:\WINDOWS\system32\MSSTDFMT.DLL=
[Package|Standard Setup Package 1|Files Added]
[Package|Standard Setup Package 1|Files Removed]
[Package|Standard Setup Package 1|Files In Project]
C:\WINDOWS\system32\msvbvm60.dll=Yes
C:\WINDOWS\system32\oleaut32.dll=Yes
C:\WINDOWS\system32\olepro32.dll=Yes
C:\WINDOWS\system32\asycfilt.dll=Yes
C:\WINDOWS\system32\stdole2.tlb=Yes
C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\Redist\COMCAT.DLL=Yes
C:\WINDOWS\system32\apigid32.dll=Yes
C:\WINDOWS\system32\MSBIND.DLL=Yes
C:\WINDOWS\system32\MSSTDFMT.DLL=Yes
C:\Program Files\Common Files\System\ado\msado25.tlb=Yes
C:\WINDOWS\system32\scrrun.dll=Yes
C:\WINDOWS\system32\msvcrt.dll=Yes
C:\WINDOWS\system32\COMCTL32.OCX=Yes
C:\WINDOWS\system32\TABCTL32.OCX=Yes
C:\WINDOWS\system32\MSADODC.OCX=Yes
C:\WINDOWS\system32\MSDatGrd.ocx=Yes
C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\SETUP.EXE=Yes
C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\SETUP1.EXE=Yes
C:\WINDOWS\system32\VB6STKIT.DLL=Yes
C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\ST6UNST.EXE=Yes
U:\QCOMMAND\NewCMD\Cmndproc 2014-04-09.exe=Yes
C:\ccrpftv6-10\ccrpftv6.ocx=Yes
[Package|Standard Setup Package 1|Configure Registry Files]
Applicable=No
[Package|Standard Setup Package 1|Configure Remote Servers]
Applicable=No
[Package|Standard Setup Package 1|Install Locations]
\\Fm1\eng\USERS\286\CMNDPROC\Cmndproc17OCT2012.exe=$(AppPath)
C:\WINDOWS\system32\msvbvm60.dll=$(WinSysPathSysFile)
C:\WINDOWS\system32\oleaut32.dll=$(WinSysPathSysFile)
C:\WINDOWS\system32\olepro32.dll=$(WinSysPathSysFile)
C:\WINDOWS\system32\asycfilt.dll=$(WinSysPathSysFile)
C:\WINDOWS\system32\stdole2.tlb=$(WinSysPathSysFile)
C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\Redist\COMCAT.DLL=$(WinSysPathSysFile)
C:\WINDOWS\system32\apigid32.dll=$(WinSysPath)
C:\WINDOWS\system32\MSBIND.DLL=$(WinSysPath)
C:\WINDOWS\system32\MSSTDFMT.DLL=$(WinSysPath)
C:\Program Files\Common Files\System\ado\msado25.tlb=$(WinSysPath)
C:\WINDOWS\system32\scrrun.dll=$(WinSysPath)
C:\WINDOWS\system32\msvcrt.dll=$(WinSysPathSysFile)
C:\WINDOWS\system32\COMCTL32.OCX=$(WinSysPath)
C:\WINDOWS\system32\TABCTL32.OCX=$(WinSysPath)
C:\WINDOWS\system32\MSADODC.OCX=$(WinSysPath)
C:\WINDOWS\system32\MSDatGrd.ocx=$(WinSysPath)
C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\SETUP.EXE=$(AppPath)
C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\SETUP1.EXE=$(WinPath)
C:\WINDOWS\system32\VB6STKIT.DLL=$(WinSysPathSysFile)
C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\ST6UNST.EXE=$(WinPath)
U:\QCOMMAND\NewCMD\Cmndproc 2014-04-09.exe=$(AppPath)
C:\ccrpftv6-10\ccrpftv6.ocx=$(AppPath)
[Package|Standard Setup Package 1|Configure Shared Files]
Applicable=Yes
\\Fm1\eng\USERS\286\CMNDPROC\Cmndproc17OCT2012.exe=No
U:\QCOMMAND\NewCMD\Cmndproc 2014-04-09.exe=No
C:\ccrpftv6-10\ccrpftv6.ocx=No
[Package|Standard Setup Package 1|Distribution]
Type=single
Size=
Title=Cmndproc
[Package|Standard Setup Package 1|IconGroups]
Group0=Cmndproc
PrivateGroup0=True
Parent0=$(Programs)
[Package|Standard Setup Package 1|Cmndproc]
Icon1=Cmndproc17OCT2012.exe
Title1=Cmndproc
StartIn1=$(AppPath)
Key1=Icon1
[Package|Standard Setup Package 1|Package]
PackageFolder=u:\QCOMMAND\NewCMD\setup
ProjectFolder=U:\QCOMMAND\NewCMD
ServerSideCab=
File1=u:\QCOMMAND\NewCMD\setup\setup.exe
File2=u:\QCOMMAND\NewCMD\setup\Setup.Lst
File3=u:\QCOMMAND\NewCMD\setup\Cmndproc 2014-04-09.CAB
Handler1=PDWizard.FolderDplySubWiz
Handler2=PDWizard.WebPostDplySubWiz

64
CMNDPROC.VBP Normal file
View File

@ -0,0 +1,64 @@
Type=Exe
Reference=*\G{56BF9020-7A2F-11D0-9482-00A0C91110ED}#1.0#0#C:\Windows\System32\msbind.dll#Microsoft Data Binding Collection
Reference=*\G{00000205-0000-0010-8000-00AA006D2EA4}#2.5#0#C:\Program Files\Common Files\System\ado\msado25.tlb#Microsoft ActiveX Data Objects 2.5 Library
Reference=*\G{420B2830-E718-11CF-893D-00A0C9054228}#1.0#0#C:\Windows\system32\scrrun.dll#Microsoft Scripting Runtime
Reference=*\G{19B7F2A2-1610-11D3-BF30-1AF820524153}#1.2#0#C:\Program Files\Cmndproc\ccrpftv6.ocx#CCRP FolderTreeview Control (VB6)
Object={BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0; Tabctl32.ocx
Object={67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0; MSADODC.OCX
Object={CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0; MSDATGRD.OCX
Object={6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0; COMCTL32.OCX
Object={248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0; MSWINSCK.OCX
Form=Cmdproc-3.frm
Module=Main; CMNDPROC.BAS
Module=MyFunctions; ..\..\vbsubs\Myfunc.bas
Form=Cmdproc-4.frm
Form=Cmdproc-1.frm
Form=Cmdproc-2.frm
Class=dwPortInfo; DWPORT.CLS
Class=dwPrinterInfo; DWPRINFO.CLS
Class=dwPrintMonitor; DWPRMON.CLS
Class=dwSpool; DWSPOOL.CLS
Form=SPOOLER1.FRM
Module=APIGuide32; APIGID32.BAS
Module=PrinterConstants; SPPRINT.BAS
Module=dwTypes; SPTYPES.BAS
Form=filewatch.frm
Form=Cmdproc-5.frm
Form=Cmdproc-6.frm
Class=ClearBOM; ClearBom.cls
Form=Pdf.frm
Module=InnerTaskComm; ..\..\vbsubs\InnerTaskComm.bas
Form=..\..\vbsubs\frmMonitorNib.frm
IconForm="frmMain"
Startup="frmStart"
HelpFile=""
Title="Cmndproc"
ExeName32="Cmndproc 2023-05-26.exe"
Command32=""
Name="CommandProcessor"
HelpContextID="0"
CompatibleMode="0"
MajorVer=7
MinorVer=0
RevisionVer=73
AutoIncrementVer=1
ServerSupportFiles=0
VersionCompanyName="Enterprise Computing Services, Inc."
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1

21
CMNDPROC.vbw Normal file
View File

@ -0,0 +1,21 @@
frmStart = 132, 132, 946, 457, , 176, 176, 1023, 674, C
Main = 83, 8, 1180, 396,
MyFunctions = 122, 4, 969, 502,
frmCheckAssembly = 0, 0, 1096, 388, , 198, 198, 1045, 696, C
frmMain = 65, 66, 1163, 454, , 110, 171, 957, 669, C
frmQueHandler = 22, 22, 1119, 410, , 220, 220, 1067, 718, C
dwPortInfo = 0, 0, 0, 0, C
dwPrinterInfo = 22, 22, 1118, 410,
dwPrintMonitor = 0, 0, 0, 0, C
dwSpool = 44, 44, 1140, 432,
frmPSSpooler = 44, 44, 1141, 432, , 242, 242, 1089, 740, C
APIGuide32 = 0, 0, 0, 0, C
PrinterConstants = 66, 66, 1162, 454,
dwTypes = 0, 0, 0, 0, C
frmFileWatch = 154, 154, 1001, 652, C, 0, 0, 847, 498, C
frmBOM = 0, 0, 0, 0, C, 22, 22, 869, 520, C
frmFolderCopy = 85, 11, 1181, 399, , 44, 44, 891, 542, C
ClearBOM = 88, 88, 1184, 476,
frmPDF = 88, 88, 935, 586, C, 66, 66, 913, 564, C
InnerTaskComm = 0, 0, 1097, 388,
frmMonitorNib = 132, 132, 925, 455, , 88, 88, 935, 586, C

95
ClearBom.cls Normal file
View File

@ -0,0 +1,95 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "ClearBOM"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'**********************************************************************
' IBM grants you a nonexclusive license to use this as an example
' from which you can generate similar function tailored to your own
' specific needs. This sample is provided in the form of source
' material which you may change and use.
' If you change the source, it is recommended that you first copy
' the source to a different directory. This will ensure that your
' changes are preserved when the tool kit contents are changed by
' IBM.
'
' DISCLAIMER
' -------------
'
' This sample code is provided by IBM for illustrative purposes
' only. These examples have not been thoroughly tested under all
' conditions. IBM, therefore, cannot guarantee or imply reliability,
' serviceability, or function of these programs. All programs
' contained herein are provided to you "AS IS" without any
' warranties of any kind. ALL WARRANTIES, INCLUDING BUT NOT
' LIMITED TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
' FOR A PARTICULAR PURPOSE, ARE EXPRESSLY DISCLAIMED.
'
' Your license to this sample code provides you no right or licenses
' to any IBM patents. IBM has no obligation to defend or indemnify
' against any claim of infringement, including but not limited to:
' patents, copyright, trade secret, or intellectual property rights
' of any kind.
'
' COPYRIGHT
' ---------
' (C) Copyright IBM CORP. 1997, 1998
' All rights reserved.
' US Government Users Restricted Rights -
' Use, duplication or disclosure restricted
' by GSA ADP Schedule Contract with IBM Corp.
' Licensed Material - Property of IBM
'*********************************************************************
Public cnRCHAS002 As New ADODB.Connection
Public cm_ACTIVEXSDK_CUSTINS As New ADODB.Command
Public Sub Connect()
Dim systemName As String
systemName = "qhal"
If systemName = "" Then
MsgBox ("No system name entered. Ending program.")
End
End If
cnRCHAS002.Open "Provider=IBMDA400;Data Source=" & systemName & ";", "EGNETLINK", "DRAWINGS"
End Sub
Public Sub Prepare()
Set cm_ACTIVEXSDK_CUSTINS.ActiveConnection = cnRCHAS002
cm_ACTIVEXSDK_CUSTINS.CommandText = "{{call /QSYS.LIB/OBJLIB.LIB/EGR465.PGM(?,?,?)}}"
cm_ACTIVEXSDK_CUSTINS.Prepared = True
cm_ACTIVEXSDK_CUSTINS.Parameters.Append cm_ACTIVEXSDK_CUSTINS.CreateParameter("PN", adChar, adParamInputOutput, 15)
cm_ACTIVEXSDK_CUSTINS.Parameters.Append cm_ACTIVEXSDK_CUSTINS.CreateParameter("RV", adChar, adParamInputOutput, 1)
cm_ACTIVEXSDK_CUSTINS.Parameters.Append cm_ACTIVEXSDK_CUSTINS.CreateParameter("RC", adChar, adParamInputOutput, 2)
End Sub
Public Sub OpenLinks()
Dim Rcds As Variant
Dim Parms As Variant
Const DBPROPVAL_UP_CHANGE = 1
Const DBPROPVAL_UP_DELETE = 2
Const DBPROPVAL_UP_INSERT = 4
End Sub
Public Sub Execute()
Dim Rcds As Variant
Dim Parms As Variant
Parms = Array("", "", "")
cm_ACTIVEXSDK_CUSTINS.Execute Rcds, Parms, adCmdText
cnRCHAS002.Execute "{{CHGCURLIB CURLIB(ACTIVEXSDK)}}", Rcds, adCmdText
End Sub
Private Sub Class_Initialize()
Call Connect
Call Prepare
Call OpenLinks
End Sub
Private Sub Class_Terminate()
Set cm_ACTIVEXSDK_CUSTINS = Nothing
If Not cnRCHAS002 Is Nothing Then cnRCHAS002.Close
End Sub

1353
Cmdproc-1.frm Normal file

File diff suppressed because it is too large Load Diff

BIN
Cmdproc-1.frx Normal file

Binary file not shown.

1
Cmdproc-1.log Normal file
View File

@ -0,0 +1 @@
Line 368: Class TabDlg.SSTab of control SSTab1 was not a loaded control class.

295
Cmdproc-2.frm Normal file
View File

@ -0,0 +1,295 @@
VERSION 5.00
Begin VB.Form frmQueHandler
BackColor = &H00C0C0C0&
Caption = "Que Test Messages"
ClientHeight = 1575
ClientLeft = 90
ClientTop = 5355
ClientWidth = 11865
LinkTopic = "Form1"
PaletteMode = 1 'UseZOrder
ScaleHeight = 1575
ScaleWidth = 11865
Begin VB.CommandButton cmdPrintText
Caption = "PrintText"
Height = 195
Left = 10320
TabIndex = 17
Top = 510
Width = 975
End
Begin VB.CommandButton Command1
Caption = "Move Ref"
Height = 225
Left = 9210
TabIndex = 16
Top = 480
Width = 975
End
Begin VB.TextBox StatusBar1
BackColor = &H00C0C0C0&
BeginProperty Font
Name = "Fixedsys"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 0
TabIndex = 15
Text = "StatusBar1"
Top = 1200
Width = 11775
End
Begin VB.CommandButton cmdWire
Caption = "Wire Diag."
Height = 195
Left = 8160
TabIndex = 14
Top = 480
Width = 975
End
Begin VB.TextBox UserName
Height = 285
Left = 2280
TabIndex = 13
Text = "FEDUCIA"
Top = 360
Width = 1455
End
Begin VB.CommandButton cmdSend
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "SEND COMMAND"
Height = 495
Left = 10320
TabIndex = 11
Top = 0
Width = 1455
End
Begin VB.CommandButton cmdQuit
Caption = "&Cancel"
Height = 375
Left = 0
TabIndex = 10
Top = 0
Width = 615
End
Begin VB.TextBox XmitCommand
BeginProperty Font
Name = "Fixedsys"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 330
Left = 0
TabIndex = 9
Text = "Text2"
Top = 840
Width = 11775
End
Begin VB.CommandButton cmdMoveBack
Caption = "Move Back"
Height = 195
Left = 9240
TabIndex = 8
Top = 240
Width = 975
End
Begin VB.CommandButton cmdMoveOut
Caption = "Move Out"
Height = 195
Left = 9240
TabIndex = 7
Top = 0
Width = 975
End
Begin VB.CommandButton cmdMoveIn
Caption = "Move In"
Height = 195
Left = 8160
TabIndex = 6
Top = 240
Width = 975
End
Begin VB.CommandButton cmdPrint
Caption = "Print File"
Height = 195
Left = 8160
TabIndex = 5
Top = 0
Width = 975
End
Begin VB.TextBox PrinterName
Height = 285
Left = 6240
TabIndex = 4
Text = "PrinterName"
Top = 0
Width = 1815
End
Begin VB.TextBox FileToActOn
Height = 285
Left = 2280
TabIndex = 1
Text = "9002028C"
Top = 0
Width = 1455
End
Begin VB.ListBox lstPrinters
Height = 255
Left = 6240
TabIndex = 0
Top = 360
Width = 1815
End
Begin VB.Label Label3
Alignment = 1 'Right Justify
Caption = "User Name"
Height = 255
Left = 720
TabIndex = 12
Top = 360
Width = 1455
End
Begin VB.Label Label2
Alignment = 1 'Right Justify
Caption = "Printer Name"
Height = 255
Left = 4680
TabIndex = 3
Top = 0
Width = 1455
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
Caption = "File To Act On"
Height = 255
Left = 720
TabIndex = 2
Top = 0
Width = 1455
End
End
Attribute VB_Name = "frmQueHandler"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdMoveBack_Click()
XmitCommand.Text = MakeCmd$("B")
End Sub
Private Sub cmdMoveIn_Click()
XmitCommand.Text = MakeCmd$("I")
End Sub
Private Sub cmdMoveOut_Click()
XmitCommand.Text = MakeCmd$("O")
End Sub
Private Sub cmdPrint_Click()
XmitCommand.Text = MakeCmd$("P")
End Sub
Private Sub cmdPrintText_Click()
XmitCommand.Text = MakeCmd$("T")
End Sub
Private Sub cmdQuit_Click()
frmQueHandler.Hide
End Sub
Private Sub cmdSend_Click()
StatusBar1.Text = "Creating Income File"
DoEvents
Open INCOME$ For Output As #4 'using #4
p$ = RPad$(XmitCommand.Text, CQueSize%)
Print #4, p$
Close #4
StatusBar1.Text = "Income File Created"
DoEvents
StatusBar1.Text = "Activating Handshake File"
Call Fcopy(COMPLETE2$, COMPLETE$, Rc%)
DoEvents
StatusBar1.Text = "Idle"
End Sub
Private Sub Command1_Click()
XmitCommand.Text = MakeCmd$("R")
End Sub
Private Sub cmdWire_Click()
XmitCommand.Text = MakeCmd$("W")
End Sub
Private Sub Form_Load()
For i = 1 To lptI%
lstPrinters.AddItem Place$(i)
Next
PrinterName.Text = Place$(1)
End Sub
Private Sub lstPrinters_DblClick()
t$ = lstPrinters.Text
PrinterName.Text = t$
End Sub
Public Function MakeCmd$(TypeOfCmd$)
WhoEver$ = UserName.Text
M$ = TypeOfCmd$
Select Case TypeOfCmd$
Case "P", "W"
''''''print P Part Printer Banner1 Date Product Number mesg type
'''''' 1<---8--><---10---><---10---><-----14-----><------15----->X
M$ = M$ + RPad$(FileToActOn.Text, 8) ' PART
M$ = M$ + RPad$(PrinterName.Text, 10) ' PRINTER
M$ = M$ + RPad$(WhoEver$, 10) ' BANNER
M$ = M$ + RPad$(Format$(Now, "YYYYMMDDHHMMSS"), 14)
M$ = M$ + RPad$(FileToActOn.Text, 15) ' PRODUCT NO
If TypeOfCmd$ = "W" Then
M$ = M$ + "6" ' MESSAGE TYPE
Else
M$ = M$ + "1" ' MESSAGE TYPE
End If
Case "I", "O", "B", "R"
''''''ck out O Part# Product # Directory New Name Date
'''''' in 1<---8--><------15-----><---10---><--8---><-----14----->
'''''' back
M$ = M$ + RPad$(FileToActOn.Text, 8) ' PART
M$ = M$ + RPad$(FileToActOn.Text, 15) ' PRODUCT NO
M$ = M$ + RPad$(WhoEver$, 10) ' BANNER
M$ = M$ + RPad$(FileToActOn.Text, 8) ' PART
M$ = M$ + RPad$(Format$(Now, "YYYYMMDDHHMMSS"), 14)
Case "E"
''''''ie move E Part# Product # Directory IE Dir Date
'''''' 1<---8--><------15-----><---10---><--10----><-----14----->
M$ = M$ + RPad$(FileToActOn.Text, 8) ' PART
M$ = M$ + RPad$(FileToActOn.Text, 15) ' PRODUCT NO
M$ = M$ + RPad$(WhoEver$, 10) ' BANNER
M$ = M$ + RPad$(WhoEver$, 10) ' BANNER
M$ = M$ + RPad$(Format$(Now, "YYYYMMDDHHMMSS"), 14)
Case "T"
M$ = M$ + RPad$(FileToActOn.Text, 10) ' PART
M$ = M$ + RPad$(PrinterName.Text, 10) ' PRINTER
Case Else
End Select
MakeCmd$ = M$
End Function

175
Cmdproc-3.frm Normal file
View File

@ -0,0 +1,175 @@
VERSION 5.00
Begin VB.Form frmStart
Caption = "CMNDPROC - Startup"
ClientHeight = 5895
ClientLeft = 1095
ClientTop = 1515
ClientWidth = 10035
LinkTopic = "Form1"
PaletteMode = 1 'UseZOrder
ScaleHeight = 5895
ScaleWidth = 10035
Begin VB.CommandButton Command2
Caption = "Cancel StartUp"
Height = 495
Left = 240
TabIndex = 7
Top = 120
Width = 9615
End
Begin VB.CommandButton Command1
Caption = "Press this button to start program immediately or it will start in 30 seconds."
Height = 495
Left = 240
TabIndex = 4
Top = 5280
Width = 9615
End
Begin VB.Timer Timer1
Interval = 1000
Left = 360
Top = 1800
End
Begin VB.Label Label6
Caption = $"Cmdproc-3.frx":0000
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 1200
TabIndex = 6
Top = 3600
Width = 8055
End
Begin VB.Label Label5
Caption = $"Cmdproc-3.frx":00BD
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 1200
TabIndex = 5
Top = 2880
Width = 8055
End
Begin VB.Label Label4
Caption = $"Cmdproc-3.frx":0174
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 1200
TabIndex = 3
Top = 1440
Width = 8055
End
Begin VB.Label Label3
Caption = $"Cmdproc-3.frx":0220
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 1200
TabIndex = 2
Top = 4320
Width = 8055
End
Begin VB.Label Label2
Caption = $"Cmdproc-3.frx":02C5
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 1200
TabIndex = 1
Top = 2160
Width = 8055
End
Begin VB.Label Label1
Caption = "During Startup this program must have available its C:\Work\ directory and three mapped network drives:"
BeginProperty Font
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 480
TabIndex = 0
Top = 840
Width = 9015
End
End
Attribute VB_Name = "frmStart"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click()
frmMain.Show
Unload frmStart
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Form_Load()
frmStart.Caption = "Command Processor Version: " + AppRevision$
NETDRV = "\\fryfs001v.manitowocfs.com"
NETDRAW = "\\fryfs001v.manitowocfs.com\drawings"
NETHAL = "\\qhal"
' NETDRV = "\\fm1"
' NETDRAW = "\\fm1\eng\eng\drawings"
' NETHAL = "\\qhal"
End Sub
Private Static Sub Timer1_Timer()
timit = timit + 1
tm$ = Trim$(Str$(31 - timit))
tx$ = tm$
tm$ = "Press this button to start program immediately or it will start in " + tm$ + " seconds."
frmStart.Command1.Caption = tm$
frmStart.Caption = "CMNDPROC - START " + tx$ + " Version: " + AppRevision$
If timit > 30 Then
frmMain.Show
Unload frmStart
End If
End Sub

BIN
Cmdproc-3.frx Normal file

Binary file not shown.

531
Cmdproc-4.frm Normal file
View File

@ -0,0 +1,531 @@
VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmCheckAssembly
Caption = "Form1"
ClientHeight = 4755
ClientLeft = 1455
ClientTop = 3180
ClientWidth = 11565
LinkTopic = "Form1"
PaletteMode = 1 'UseZOrder
ScaleHeight = 4755
ScaleWidth = 11565
Begin VB.CheckBox chkNoCheck
Caption = "No Check"
Height = 375
Left = 3780
TabIndex = 7
Top = 3330
Value = 1 'Checked
Width = 1200
End
Begin VB.CommandButton cmdHide
Caption = "Hide"
Height = 330
Left = 5190
TabIndex = 4
Top = 3240
Width = 1410
End
Begin VB.ListBox lstIModels
Height = 1035
Left = 1920
TabIndex = 2
Top = 1080
Width = 9615
End
Begin VB.ListBox lstParts
Height = 1035
Left = 1920
TabIndex = 1
Top = 2160
Width = 9615
End
Begin VB.ListBox lstSearchAsm
Height = 1035
Left = 1920
TabIndex = 0
Top = 0
Width = 9615
End
Begin ComctlLib.TreeView TreeView1
Height = 3135
Left = 120
TabIndex = 3
Top = 120
Width = 1695
_ExtentX = 2990
_ExtentY = 5530
_Version = 327682
Style = 7
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.Label Label1
Caption = "Return Code"
Height = 225
Left = 210
TabIndex = 6
Top = 3270
Width = 3465
End
Begin VB.Label lblErrorLevel
Height = 255
Left = 195
TabIndex = 5
Top = 3525
Width = 3540
End
End
Attribute VB_Name = "frmCheckAssembly"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Sub FillIModels(lst As ListBox)
Dim specialSearch$(100)
' specialSearch(0) = "\\fm1\eng\depts\eng\Models\"
' specialSearch(1) = "\\fm1\eng\depts\eng\Models\contacttoasterwiring\"
' specialSearch(2) = "\\fm1\eng\depts\eng\Models\IE-SYMBOLS\"
' specialSearch(3) = "\\fm1\eng\depts\eng\Models\translation symbols\"
' specialSearch(4) = "\\fm1\eng\depts\eng\Models\wire-fully modelled with datum curve\"
' specialSearch(5) = "\\fm1\eng\depts\eng\Models\wiresIbarnesapc\"
' specialSearch(6) = "\\fm1\eng\depts\eng\Models\WiresOwens\"
specialSearch(0) = NETDRV + "\eng\depts\eng\Models\"
specialSearch(1) = NETDRV + "\eng\depts\eng\Models\contacttoasterwiring\"
specialSearch(2) = NETDRV + "\eng\depts\eng\Models\IE-SYMBOLS\"
specialSearch(3) = NETDRV + "\eng\depts\eng\Models\translation symbols\"
specialSearch(4) = NETDRV + "\eng\depts\eng\Models\wire-fully modelled with datum curve\"
specialSearch(5) = NETDRV + "\eng\depts\eng\Models\wiresIbarnesapc\"
specialSearch(6) = NETDRV + "\eng\depts\eng\Models\WiresOwens\"
specialS = 6
lst.Clear
For i = 0 To specialS
fl$ = Dir$(specialSearch(i) + "*.*")
Do While fl$ <> "" ' Start the loop.
If (fl$ <> ".") And (fl$ <> "..") Then
ex = LastStr%(fl$, ".")
rev$ = UCase$(Mid$(fl$, ex + 1))
nfl$ = left$(fl$, ex - 1)
If Val(rev$) <> 0 Then
lst.AddItem nfl$ + "|" + specialSearch$(i) + "|" + rev$
Else
If (rev$ = "PRT") Or (rev$ = "ASM") Or (rev$ = "DRW") Then
lst.AddItem fl$ + "|" + specialSearch$(i) + "|"
End If
End If
End If
fl$ = Dir$
Loop
Next
End Sub
Private Sub Command1_Click()
End Sub
Public Function Execute%(ass$)
Dim lookfor$(100), LookRev$(100)
Dim indata As Byte
Dim nodX As Node
On Error GoTo Ender
perr = 1
lblErrorLevel.Caption = "Scanning assembly"
Call FillIModels(lstIModels)
lstSearchAsm.Clear
lstSearchAsm.AddItem ass$
If lstSearchAsm.ListCount = 0 Then
Execute% = -1
Exit Function
End If
errorlevel = 0
TreeView1.Nodes.Clear
StopTransfer = False
lstParts.Clear
lf% = 1
lookfor$(1) = "@model_name"
lr% = 1
LookRev$(1) = "@revnum"
' todr$ = pathCheck$(Dir2.SelectedFolder)
''''''''''''+revnum
revnum = 0
''''''''''''-revnum
assm = 0: lvl$ = "0"
Filename$ = lstSearchAsm.List(assm)
x$ = Filename$
x$ = Mid$(x$, LastStr(x$, "\") + 1)
Rootasm$ = x$
x$ = left$(x$, LastStr(x$, ".") - 1)
Parent$ = ""
Rootname$ = x$
TreeView1.LineStyle = tvwRootLines ' Linestyle 1 ' Add Node objects.
Parent$ = "X" + x$
Set nodX = TreeView1.Nodes.Add(, , Parent$, x$ + ".asm")
i = TreeView1.Nodes.Count
TreeView1.Nodes(i).Expanded = True
TreeView1.Nodes(i).Tag = lvl$
x$ = StrRemove$(x$, Chr$(13))
GoSub AddToList
If ExistsNew(Filename$) Then
Do While assm <= lstSearchAsm.ListCount - 1
Filename$ = lstSearchAsm.List(assm)
DoEvents
u$ = ""
lineno = 0
lf% = 1
lr% = 1
pt$ = Filename$
pt$ = Mid$(pt$, LastStr(pt$, "\") + 1)
pt$ = left$(pt$, LastStr(pt$, ".") - 1)
Parent$ = "X" + pt$
On Error GoTo Ender
Open Filename$ For Binary As #25 'using #25
Do While Not EOF(25)
Get #25, , indata
If EOF(25) Then Exit Do
ax% = indata
ax% = ax% And &HFF
x$ = Chr$(ax%)
If ax% <> 10 Then
u$ = u$ + x$
Else
lineno = lineno + 1
Call WDTServer
If getlookfor <> 0 Then
Z = InStr(u$, " ")
t = Z + InStr(Mid$(u$, Z + 1), " ") + 1
x$ = Mid$(u$, t)
x$ = StrRemove$(x$, Chr$(13))
GoSub AddToList
y$ = left$(u$, t - 1)
lf% = lf% + 1
lookfor$(lf%) = y$
getlookfor = 0
DoEvents
Else
If left$(u$, 16) = "#END_OF_P_OBJECT" Then
Exit Do
End If
For i = 1 To lf%
lflen% = Len(lookfor$(i))
If left$(u$, lflen%) = lookfor$(i) Then
If i = 1 Then
getlookfor = i
Else
Z = InStr(u$, " ")
t = Z + InStr(Mid$(u$, Z + 1), " ") + 1
x$ = Mid$(u$, t)
x$ = StrRemove$(x$, Chr$(13))
GoSub AddToList
Exit For
End If
End If
DoEvents
Call WDTServer
Next
''''''''''''+revnum
If revnum = 1 Then
revnum = 0
Z = InStr(u$, " ")
t = Z + InStr(Mid$(u$, Z + 1), " ") + 1
x$ = Trim$(Mid$(u$, t))
If x$ = "-1" Then
GoSub RemoveLastAssembly
y$ = left$(u$, t - 1)
lr = lr + 1
LookRev$(lr) = y$
End If
Else
For i = 1 To lr
lrlen% = Len(LookRev$(i))
If left$(u$, lrlen%) = LookRev$(i) Then
If i = 1 Then
revnum = 1
Else
Z = InStr(u$, " ")
t = Z + InStr(Mid$(u$, Z + 1), " ") + 1
x$ = Trim$(Mid$(u$, t))
If x$ = "-1" Then
GoSub RemoveLastAssembly
End If
End If
End If
Next
End If
''''''''''''-revnum
End If
u$ = ""
End If
GoSub RefreshDisp
If StopTransfer Then Exit Do
Loop
Close #25
assm = assm + 1
If StopTransfer Then Exit Do
Loop
End If
For i = 1 To TreeView1.Nodes.Count
TreeView1.Nodes(i).Expanded = True
Next
GoSub RefreshDisp
errorlevel = 0
For i = 0 To lstParts.ListCount - 1
lstp$ = lstParts.List(i)
If Val(right$(lstp$, Len(lstp$) - LastInStr(lstp$, "|"))) <> 0 Then
errorlevel = 99
Exit For
End If
Next
' cmdCancelTransfer.Visible = False
exitender:
Execute% = errorlevel
lblErrorLevel.Caption = Str$(errorlevel)
Close
Exit Function
Ender:
errorlevel = perr
Resume exitender
'
' Add a part or assembly to the list of pars to transfer
'
AddToList:
AsmScanFnd = False
If InStr(x$, "_") Then
x$ = left$(x$, InStr(x$, "_") - 1)
End If
If InStr(x$, "#") Then
x$ = left$(x$, InStr(x$, "#") - 1)
End If
If x$ <> Rootname$ Then
''''''''''''+revnum
lastpartadded$ = x$
''''''''''''-revnum
For imx = 0 To lstParts.ListCount - 1
lstpt$ = lstParts.List(imx)
lstpt$ = left$(lstpt$, InStr(lstpt$, "|") - 1)
If x$ = lstpt$ Then
AsmScanFnd = True
Exit For
End If
Next
If Not (AsmScanFnd) Then
y$ = x$ + "| " + Filename$
asm$ = AddSubdirectory$(x$) + ".asm"
prt$ = AddSubdirectory$(x$) + ".prt"
drw$ = AddSubdirectory$(x$) + ".drw"
GoSub RefreshDisp
If ExistsNew(asm$) Then
'
' Is this assembly already in the list of assemblies to scan?
'
If right$(asm$, Len(Rootasm$)) = Rootasm$ Then
lsafnd = True
Else
lsafnd = False
For iv = 0 To lstSearchAsm.ListCount - 1
If lstSearchAsm.List(iv) = asm$ Then
lsafnd = True
Exit For
End If
Next
End If
If Not (lsafnd) Then
' lstSearchAsm.AddItem asm$
' perr = 97
' On Error GoTo Ender
' Set nodX = TreeView1.Nodes.Add(Parent$, tvwChild, "X" + x$, x$ + ".asm")
' On Error GoTo 0
' perr = 0
' GoSub GetLevel
End If
GoSub RefreshDisp
If Not (ExistsNew(drw$)) Then
y$ = y$ + "|ERROR Assembly file found without drw file|0"
Else
y$ = y$ + "|Assembly file found|0"
End If
Else
'
' Is this part the root assembly?
'
If right$(asm$, Len(Rootasm$)) = Rootasm$ Then
y$ = y$ + "|ERROR This Part file is the root assembly|0"
Else
If ExistsNew(prt$) Then
GoSub RefreshDisp
If Not ExistsNew(drw$) Then
y$ = y$ + "|ERROR Part file found without drw file|0"
Else
y$ = y$ + "|Part file found|0"
End If
perr = 96
On Error GoTo Ender
Set nodX = TreeView1.Nodes.Add(Parent$, tvwChild, "X" + x$, x$ + ".prt")
On Error GoTo 0
perr = 0
GoSub GetLevel
Else
'
'I Model Search
'
fndSps = False
Call WDTServer
For ext = 0 To lstIModels.ListCount - 1
im$ = lstIModels.List(ext)
ipt$ = left$(im$, InStr(im$, ".") - 1)
If UCase$(ipt$) = UCase$(x$) Then
fndSps = True
End If
Next
If fndSps Then
y$ = y$ + "|ERROR Part Found in Imodels|0"
On Error Resume Next
Set nodX = TreeView1.Nodes.Add(Parent$, tvwChild, "X" + x$, x$ + ".prt")
On Error GoTo 0
GoSub GetLevel
Else
If right$(asm$, Len(Rootasm$)) = Rootasm$ Then
y$ = y$ + "|Root Assembly file|0"
Else
y$ = y$ + "|ERROR No part file found|99"
End If
End If
End If
End If
End If
lstParts.AddItem y$
End If
End If
Return
'
' Update all counters and timers on the form
'
RefreshDisp:
' lblAssembyCount.Caption = "cnt:" + Str$(lstSearchAsm.ListCount) + " Time: " + Format$((Timer - starttime!) / 60, "##0.00") + " mins"
' lblPartCount.Caption = lstParts.ListCount
' lstParts.ListIndex = lstParts.ListCount - 1
' lstSearchAsm.ListIndex = lstSearchAsm.ListCount - 1
DoEvents
Return
'
' Find the parent node and get level number
'
GetLevel:
ixt = TreeView1.Nodes.Count
lvl$ = ""
parfnd = False
For ijx = 1 To TreeView1.Nodes.Count
If TreeView1.Nodes(ijx).Key = Parent$ Then
lvl$ = Trim$(Str$(Val(TreeView1.Nodes(ijx).Tag) + 1))
parfnd = True
Exit For
End If
Next
TreeView1.Nodes(ixt).Tag = lvl$
Return
''''''''''''+revnum
RemoveLastAssembly:
If lastpartadded$ <> "" Then
For imx = 0 To lstParts.ListCount - 1
lstpt$ = lstParts.List(imx)
lstpt$ = left$(lstpt$, InStr(lstpt$, "|") - 1)
If lastpartadded$ = lstpt$ Then
lstParts.RemoveItem imx
Exit For
End If
Next
For i = 1 To TreeView1.Nodes.Count
If TreeView1.Nodes(i).Key = "X" + lastpartadded$ Then
TreeView1.Nodes.Remove (i)
Exit For
End If
Next
For i = 0 To lstSearchAsm.ListCount - 1
If InStr(lstSearchAsm.List(i), lastpartadded$) <> 0 Then
lstSearchAsm.RemoveItem (i)
Exit For
End If
Next
lastpartadded$ = ""
End If
Return
''''''''''''-revnum
End Function
Private Sub cmdHide_Click()
frmCheckAssembly.Hide
End Sub
Private Sub Form_Load()
frmCheckAssembly.Caption = App.Title + " Version " + AppRevision$
' SUBSCFG$ = "\\fm1\eng\users\cadprint\subs.cfg"
Call LoadSubDirs
Call FillIModels(lstIModels)
End Sub
Function AddSubdirectory$(p$)
AddSubdirectory$ = Subdirectory$(p$) + p$
End Function
'
' This subroutine searches the array submask$(300,2) for the subdirectory
' that this part is in . . . if the part has no agreed to mask then it is
' given no sub directory
'
Function Subdirectory$(part$)
subd$ = ""
If Len(part$) < 7 Then
Subdirectory$ = ""
Exit Function
End If
sear$ = left$(part$ + " ", 7)
For ix = 1 To submaskI%
lx = InStr(submask$(ix, 1), "X") - 1
If lx = -1 Then lx = 7
If lx = 0 Then
subd$ = submask$(ix, 2) + "\"
Exit For
End If
If left$(part$, lx) = left$(submask$(ix, 1), lx) Then
subd$ = submask$(ix, 2) + "\"
Exit For
End If
Next
' Subdirectory$ = "\\fm1\eng\eng\drawings" + subd$
Subdirectory$ = NETDRAW + subd$
Subdirectory$ = NETDRAW + subd$
End Function

1
Cmdproc-4.log Normal file
View File

@ -0,0 +1 @@
Line 51: Class ComctlLib.TreeView of control TreeView1 was not a loaded control class.

625
Cmdproc-5.frm Normal file
View File

@ -0,0 +1,625 @@
VERSION 5.00
Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
Object = "{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0"; "MSDATGRD.OCX"
Begin VB.Form frmBOM
Caption = "BOM"
ClientHeight = 5085
ClientLeft = 60
ClientTop = 450
ClientWidth = 9990
ControlBox = 0 'False
LinkTopic = "Form1"
ScaleHeight = 5085
ScaleWidth = 9990
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdReadSolidBOM
Caption = "Read SolidWorks BOM"
Height = 615
Left = 5850
TabIndex = 13
Top = 3240
Width = 1815
End
Begin VB.CommandButton cmdReadAltimaBOM
Caption = "Read Altima BOM"
Height = 615
Left = 4320
TabIndex = 10
Top = 3240
Width = 1515
End
Begin VB.ListBox lstStatus
Height = 1035
Left = 540
TabIndex = 9
Top = 3870
Width = 9405
End
Begin VB.CommandButton cmdShow
Caption = "Show Loaded BOM"
Height = 615
Left = 2670
TabIndex = 8
Top = 3240
Width = 1635
End
Begin VB.CommandButton cmdClearBOM
Caption = "Clear BOM"
Height = 615
Left = 1620
TabIndex = 7
Top = 3240
Width = 1035
End
Begin VB.CommandButton cmdHide
Caption = "Close"
Height = 345
Left = 8250
TabIndex = 5
Top = 60
Width = 1635
End
Begin VB.TextBox txtGood
Height = 255
Left = 480
TabIndex = 4
Top = 2880
Width = 1215
End
Begin VB.CommandButton cmdReadBOM
Caption = "Read BOM"
Height = 615
Left = 540
TabIndex = 3
Top = 3240
Width = 1065
End
Begin VB.TextBox txtBOM
Height = 255
Left = 1200
TabIndex = 2
Text = "J:\Broyles\8235482.bom.1"
ToolTipText = "Full path and file name"
Top = 480
Width = 8745
End
Begin MSDataGridLib.DataGrid DataGrid1
Bindings = "Cmdproc-5.frx":0000
Height = 1575
Left = 480
TabIndex = 1
Top = 840
Width = 7155
_ExtentX = 12621
_ExtentY = 2778
_Version = 393216
HeadLines = 1
RowHeight = 15
FormatLocked = -1 'True
BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ColumnCount = 5
BeginProperty Column00
DataField = "WASM#"
Caption = "WASM#"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column01
DataField = "WASMR"
Caption = "WASMR"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column02
DataField = "WCMP#"
Caption = "WCMP#"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column03
DataField = "WQTY"
Caption = "WQTY"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column04
DataField = "WENTD"
Caption = "WENTD"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
SplitCount = 1
BeginProperty Split0
BeginProperty Column00
EndProperty
BeginProperty Column01
ColumnWidth = 645.165
EndProperty
BeginProperty Column02
EndProperty
BeginProperty Column03
ColumnWidth = 1065.26
EndProperty
BeginProperty Column04
ColumnWidth = 1590.236
EndProperty
EndProperty
End
Begin MSAdodcLib.Adodc Adodc1
Height = 330
Left = 480
Top = 2460
Width = 7155
_ExtentX = 12621
_ExtentY = 582
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 2
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 3
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = "DSN=ODBCrms"
OLEDBString = ""
OLEDBFile = ""
DataSourceName = "ODBCrms"
OtherAttributes = ""
UserName = "EGNETLINK"
Password = "DRAWINGS"
RecordSource = "EGBWP1A0"
Caption = "Adodc1"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
Begin VB.TextBox txtAssembly
Height = 285
Left = 1200
TabIndex = 0
Text = "82354821"
ToolTipText = "Must be 8 characters PN and rev"
Top = 120
Width = 3255
End
Begin VB.Label Label2
Caption = "BOM File"
Height = 255
Left = 450
TabIndex = 12
Top = 480
Width = 855
End
Begin VB.Label Label1
Caption = "Assembly"
Height = 255
Left = 450
TabIndex = 11
Top = 120
Width = 855
End
Begin VB.Label lblStat
Height = 195
Left = 2340
TabIndex = 6
Top = 3000
Width = 4635
End
End
Attribute VB_Name = "frmBOM"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public Sub cmdClearBOM_Click()
Dim Rcds As Variant
Dim Parms As Variant
If cmdClearBOM.Tag <> "X" Then
cmdClearBOM.Tag = "X"
Set Links = New ClearBOM
ass$ = left(txtAssembly, 7)
rev$ = right(left(Trim(txtAssembly) + " ", 8), 1)
loglist ("StartClear - " + ass$ + " " + rev$)
'
p1$ = left$(ass$ + Space$(15), 15) 'partnumber to get
P2$ = left$(rev$ + Space$(1), 1) 'filename
p3$ = Space$(2) 'status
'
Parms = Array(p1$, P2$, p3$)
Links.cm_ACTIVEXSDK_CUSTINS.Execute Rcds, Parms, adCmdText
retcd$ = Links.cm_ACTIVEXSDK_CUSTINS.Parameters(2).value
' On Error GoTo BadCBom
''
'' Clear out the old records
''
' loglist ("clear rec " + "(([WASM#] = '" + ass$ + "') and ([WASMR] = '" + rev$ + "'))")
' Adodc1.Recordset.Filter = "(([WASM#] = '" + ass$ + "') and ([WASMR] = '" + rev$ + "'))"
' ix = 1
' Adodc1.Recordset.MoveFirst
' Do While Adodc1.Recordset.RecordCount > 0
' loglist "deleting rec rcnt: " + Str(ix)
' If ((UCase(Trim(Adodc1.Recordset![WASM#])) = Trim(UCase(ass$))) And (UCase(Trim(Adodc1.Recordset![WASMR])) = Trim(UCase(rev$)))) Then
' Adodc1.Recordset.Delete
' Adodc1.Recordset.MoveFirst
' Else
' Adodc1.Recordset.MoveNext
' End If
' ix = ix + 1
' If Adodc1.Recordset.EOF Then Exit Do
' Loop
loglist "clear done! RC=" + retcd$
cmdClearBOM.Tag = ""
Else
loglist "clear FAILED! BOM BUSY"
End If
'
Exit Sub
BadCBom:
Resume Next
' Adodc1.Refresh
End Sub
Private Sub cmdHide_Click()
frmBOM.Hide
End Sub
Public Sub cmdReadAltimaBOM_Click()
If cmdReadAltimaBOM.Tag <> "X" Then
cmdReadAltimaBOM.Tag = "X"
fln$ = txtBOM
ass$ = left(txtAssembly, 7)
rev$ = right(left(Trim(txtAssembly) + " ", 8), 1)
goodread = 0
loglist ("StartRead alt - " + ass$)
loglist (" from file - " + fln$)
' lblStat.Caption = "StartRead"
If ExistsNew(fln$) Then
On Error GoTo BadAltBom
'
' parse the file
'
loglist "Parsing file " + fln$
fl = FreeFile
BomRecs = 0
Open fln$ For Input As #fl
'
' skip first two records
'
Line Input #fl, a$ ' column headers
Line Input #fl, a$ ' blank line
flstate = 0
Do While Not EOF(fl)
Line Input #fl, a$
ax$ = UCase(a$)
If Trim(ax$) <> "" Then
Call PARSE(ax$, qty$, ",", RC%): qty$ = ReplaceStr(qty$, Chr$(34), "")
Call PARSE(ax$, Pn$, ",", RC%): Pn$ = left(ReplaceStr(Pn$, Chr$(34), ""), 7)
If Pn$ <> "" Then
'Pn$ = prt$
loglist "Adding rec:" + ass$ + Pn$
qut$ = Format(qty, "#.0")
Adodc1.Recordset.AddNew
Adodc1.Recordset![WASM#] = UCase(ass$)
Adodc1.Recordset!WASMR = UCase(rev$)
Adodc1.Recordset![WCMP#] = Pn$
Adodc1.Recordset!WQTY = LPad(Format(Val(qut$), "####.000"), 8)
Adodc1.Recordset!WENTD = Format(Now, "YYYYMMDDHHNNSS")
Adodc1.Recordset.Update
BomRecs = BomRecs + 1
End If
End If
Loop
Close #fl
loglist "Done!"
If BomRecs = 0 Then
goodread = 1 ' bad bom
loglist "BAD altBOM No Records added"
End If
Else
loglist "BAD altBOM Didn't find BOM - " + fln$
goodread = 2 ' No bom
End If
txtGood.Text = goodread
txtBOM = ""
txtAssembly = ""
Adodc1.Refresh
cmdReadAltimaBOM.Tag = ""
Else
loglist "altBOM BUSY"
End If
On Error GoTo 0
AltBOMDIE:
Exit Sub
BadAltBom:
txtGood.Text = 1 ' bad bom
txtBOM = ""
txtAssembly = ""
loglist "BAD altBOM On ERROR Kick out"
' Adodc1.Refresh
cmdReadAltimaBOM.Tag = ""
Resume AltBOMDIE
End Sub
Public Sub cmdReadSolidBOM_Click()
Call ReadSolidBOM
End Sub
Public Sub ReadSolidBOM()
If cmdReadSolidBOM.Tag <> "X" Then
cmdReadSolidBOM.Tag = "X"
fln$ = txtBOM
ass$ = left(txtAssembly, 7)
rev$ = right(left(Trim(txtAssembly) + " ", 8), 1)
goodread = 0
loglist ("StartRead SW - " + ass$ + " " + rev$)
loglist (" from file - " + fln$)
' lblStat.Caption = "StartRead"
If ExistsNew(fln$) Then
'
' parse the file
'
' Tab Delimited ignore first line
'
' ItemNo<TAB>PartNo<TAB>Qty<TAB>Descr
'
loglist "File Exists "
fl = FreeFile
BomRecs = 0
Open fln$ For Input As #fl
flstate = 0
If Not EOF(fl) Then
bad = False
For ix = 1 To Len(a$)
b = Asc(Mid(a$, ix, 1))
If b >= 255 Then
bad = True
Exit For
End If
Next
End If
Close fl
If bad Then
goodread = 1 'bad bom
txtGood.Text = goodread
txtBOM = ""
txtAssembly = ""
loglist "BOM BAD"
Else
Open fln$ For Input As #fl
Do While Not EOF(fl)
Line Input #fl, a$
ax$ = UCase(a$)
loglist "Number of Tabs in rec: " + Str(Howmany%(ax$, Chr(9)))
If left(ax$, 4) = "ITEM" Then ax$ = "" 'ignore heading
If Trim(ax$) <> "" Then
Call PARSE(ax$, itm$, Chr(9), rcx%)
Call PARSE(ax$, Pn$, Chr(9), rcx%)
Call PARSE(ax$, quty$, Chr(9), rcx%)
loglist "Adding rec:" + ass$ + Pn$
qut$ = Format(Val(quty$), "#.0")
Adodc1.Recordset.AddNew
Adodc1.Recordset![WASM#] = UCase(ass$)
loglist UCase(ass$)
Adodc1.Recordset!WASMR = UCase(rev$)
loglist UCase(rev$)
Adodc1.Recordset![WCMP#] = Pn$
loglist Pn$
Adodc1.Recordset!WQTY = LPad(Format(Val(qut$), "####.000"), 8)
loglist LPad(Format(Val(qut$), "####.000"), 8)
Adodc1.Recordset!WENTD = Format(Now, "YYYYMMDDHHNNSS")
loglist Format(Now, "YYYYMMDDHHNNSS")
Adodc1.Recordset.Update
loglist "----------"
BomRecs = BomRecs + 1
End If
Loop
Close #fl
End If
End If
txtGood.Text = goodread
txtBOM = ""
txtAssembly = ""
Adodc1.Refresh
loglist "----------complete----------"
cmdReadSolidBOM.Tag = ""
Else
loglist "BOM BUSY"
End If
On Error GoTo 0
End Sub
Public Sub cmdReadBOM_Click()
If cmdReadBOM.Tag <> "X" Then
cmdReadBOM.Tag = "X"
fln$ = txtBOM
ass$ = left(txtAssembly, 7)
rev$ = right(left(Trim(txtAssembly) + " ", 8), 1)
goodread = 0
loglist ("StartRead - " + ass$)
' lblStat.Caption = "StartRead"
If ExistsNew(fln$) Then
On Error GoTo BadBom
'
' parse the file
'
' 1 Sub-Assembly 8241378
'--qty-|----descr----|---PN--
'123456789012345678901234567890
' 12345678901234
' 1-6 8-20 22->
' left(ax$,6):mid(ax$,8,24):mid(ax$,22)
'
loglist "Parsing file " + fln$
fl = FreeFile
BomRecs = 0
Open fln$ For Input As #fl
flstate = 0
Do While Not EOF(fl)
Line Input #fl, a$
ax$ = UCase(a$)
Select Case flstate
Case 0
If InStr(ax$, "ASSEMBLY") <> 0 Then
flstate = 1
End If
Case 1
If Trim(ax$) = "" Then
flstate = 2
Else
dsc$ = Trim(Mid(ax$, 8, 14)): prt$ = Mid(ax$, 22)
qty = Val(Trim(left(ax$, 6)))
Pn$ = ""
d = 0
If (dsc$ <> "PART") And (dsc$ <> "SUB-ASSEMBLY") Then
loglist "BAD BOM dsc wasn't right - " + dsc$
goodread = 1 ' bad bom
flstate = 2
Else
Pn$ = prt$
loglist "Adding rec:" + ass$ + Pn$
qut$ = Format(qty, "#.0")
Adodc1.Recordset.AddNew
Adodc1.Recordset![WASM#] = UCase(ass$)
Adodc1.Recordset!WASMR = UCase(rev$)
Adodc1.Recordset![WCMP#] = Pn$
Adodc1.Recordset!WQTY = LPad(Format(Val(qut$), "####.000"), 8)
Adodc1.Recordset!WENTD = Format(Now, "YYYYMMDDHHNNSS")
Adodc1.Recordset.Update
BomRecs = BomRecs + 1
End If
End If
Case Else
Exit Do
End Select
Loop
Close #fl
loglist "Done!"
If BomRecs = 0 Then
goodread = 1 ' bad bom
loglist "BAD BOM No Records added"
End If
Else
loglist "BAD BOM Didn't find BOM - " + fln$
goodread = 2 ' No bom
End If
txtGood.Text = goodread
txtBOM = ""
txtAssembly = ""
Adodc1.Refresh
cmdReadBOM.Tag = ""
Else
loglist "BOM BUSY"
End If
On Error GoTo 0
BOMDIE:
Exit Sub
BadBom:
txtGood.Text = 1 ' bad bom
txtBOM = ""
txtAssembly = ""
loglist "BAD BOM On ERROR Kick out"
' Adodc1.Refresh
cmdReadBOM.Tag = ""
Resume BOMDIE
End Sub
Private Sub cmdShow_Click()
ass$ = left(txtAssembly, 7)
rev$ = right(left(Trim(txtAssembly) + " ", 8), 1)
loglist "Start Display of BOM - " + ass$ + " " + rev$
On Error Resume Next
'
' Clear out the old records
'
loglist "clear rec " + "(([WASM#] = '" + ass$ + "') and ([WASMR] = '" + rev$ + "'))"
Adodc1.Recordset.Filter = "(([WASM#] = '" + ass$ + "') and ([WASMR] = '" + rev$ + "'))"
End Sub
Private Sub loglist(xxx$)
lblStat.Caption = xxx$
lstStatus.AddItem xxx$
While lstStatus.ListCount > 600
lstStatus.RemoveItem (0)
Wend
End Sub

BIN
Cmdproc-5.frx Normal file

Binary file not shown.

1
Cmdproc-5.log Normal file
View File

@ -0,0 +1 @@
Line 86: Class MSDataGridLib.DataGrid of control DataGrid1 was not a loaded control class.

406
Cmdproc-6.frm Normal file
View File

@ -0,0 +1,406 @@
VERSION 5.00
Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
Object = "{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0"; "MSDatGrd.ocx"
Begin VB.Form frmFolderCopy
Caption = "Folder Copy"
ClientHeight = 7335
ClientLeft = 60
ClientTop = 450
ClientWidth = 8400
LinkTopic = "Form1"
ScaleHeight = 7335
ScaleWidth = 8400
StartUpPosition = 3 'Windows Default
Begin MSDataGridLib.DataGrid DataGrid1
Bindings = "Cmdproc-6.frx":0000
Height = 915
Left = 300
TabIndex = 7
Top = 5370
Width = 8025
_ExtentX = 14155
_ExtentY = 1614
_Version = 393216
HeadLines = 1
RowHeight = 15
FormatLocked = -1 'True
BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ColumnCount = 4
BeginProperty Column00
DataField = "HFLD#"
Caption = "HFLD#"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column01
DataField = "HPRD#"
Caption = "HPRD#"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column02
DataField = "HHEX"
Caption = "HHEX"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column03
DataField = "HENTD"
Caption = "HENTD"
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 1033
SubFormatType = 0
EndProperty
EndProperty
SplitCount = 1
BeginProperty Split0
BeginProperty Column00
ColumnWidth = 1275.024
EndProperty
BeginProperty Column01
ColumnWidth = 1260.284
EndProperty
BeginProperty Column02
ColumnWidth = 3209.953
EndProperty
BeginProperty Column03
ColumnWidth = 1590.236
EndProperty
EndProperty
End
Begin VB.ListBox List2
Height = 1425
Left = 300
TabIndex = 6
Top = 3870
Width = 8025
End
Begin VB.CommandButton cmdReadFileNames
Caption = "Read File Names"
Height = 345
Left = 4620
TabIndex = 5
Top = 60
Width = 3675
End
Begin VB.FileListBox File1
Height = 3015
Left = 4650
TabIndex = 4
Top = 450
Width = 3645
End
Begin VB.ListBox List1
Height = 1815
Left = 300
TabIndex = 3
Top = 1560
Width = 4095
End
Begin VB.CommandButton Command1
Caption = "Copy Folder"
Height = 435
Left = 690
TabIndex = 2
Top = 900
Width = 2955
End
Begin VB.TextBox pthDst
Height = 285
Left = 120
TabIndex = 1
Text = "Q:\A\8074932D"
Top = 420
Width = 4335
End
Begin VB.TextBox pthSrc
Height = 285
Left = 120
TabIndex = 0
Text = "\\fryfs001v\eng\users\FEDUCIA\8074932D"
Top = 90
Width = 4335
End
Begin MSAdodcLib.Adodc Adodc1
Height = 330
Left = 360
Top = 3540
Visible = 0 'False
Width = 8025
_ExtentX = 14155
_ExtentY = 582
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 2
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 3
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = "DSN=ODBCrms"
OLEDBString = ""
OLEDBFile = ""
DataSourceName = "ODBCrms"
OtherAttributes = ""
UserName = "EGNETLINK"
Password = "DRAWINGS"
RecordSource = "EGSHP1A0"
Caption = "Adodc1"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
End
Attribute VB_Name = "frmFolderCopy"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2006 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const INVALID_HANDLE_VALUE = -1
Private Const MAX_PATH As Long = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function CreateDirectory Lib "kernel32" _
Alias "CreateDirectoryA" _
(ByVal lpPathName As String, _
lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Declare Function CopyFile Lib "kernel32" _
Alias "CopyFileA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Dim fsoMain As FileSystemObject
Private Sub cmdReadFileNames_Click()
cmdReadFileNames.Enabled = False
On Error Resume Next
pthd$ = pthDst.Text
'SW00007C
List2.Clear
File1.Path = pthd$
fldr$ = UCase(Mid(pthd$, LastStr(pthd$, "\") + 1))
Pn$ = UCase(left(fldr$, 7))
File1.Refresh
If File1.Path = pthd$ Then
Recname$ = pthd$
recn# = 0
retry# = 0
If (Adodc1.Recordset.RecordCount <> 0) Then Adodc1.Recordset.MoveFirst
Do While (Not (Adodc1.Recordset.EOF)) And (Adodc1.Recordset.RecordCount <> 0)
rfld$ = UCase(Trim(Adodc1.Recordset![HFLD#]))
If rfld$ = fldr$ Then
Adodc1.Recordset.Delete
Pause (1)
retry# = retry# + 1
Else
recn# = recn# + 1
Adodc1.Recordset.MoveNext
End If
cmdReadFileNames.Caption = "retry=" + Str(retry#) + " - Recnum=" + Str(recn#)
Loop
cmdReadFileNames.Caption = "delete complete"
On Error GoTo 0
If File1.ListCount > 0 Then
For ixc = 0 To File1.ListCount - 1
nw$ = Format(Now, "yyyymmddhhnnss")
d# = Val(nw$)
flx$ = File1.List(ixc)
'
' add the record
List2.AddItem fldr$ + "|" + Pn$ + "|" + nw$ + "|" + flx$
Adodc1.Recordset.AddNew
Adodc1.Recordset![HFLD#] = fldr$
Adodc1.Recordset![HPRD#] = Pn$
Adodc1.Recordset!HHEX = RPad(flx$, 70)
Adodc1.Recordset!HENTD = d#
Adodc1.Recordset.Update
'
Next
End If
End If
cmdReadFileNames.Caption = "Read File Names"
cmdReadFileNames.Enabled = True
End Sub
Private Sub Command1_Click()
Dim sSourcePath As String
Dim sDestination As String
Dim sFiles As String
Dim numCopied As Long
'set the appropriate initializing values
sSourcePath = pathCheck(pthSrc)
sDestination = pathCheck(pthDst)
sFiles = "*.*"
'perform the copy and return the copied file count
numCopied = 0
Call Copydir(sSourcePath, sDestination, Rc%)
numCopied = Rc%
Call DeleteDir(sSourcePath)
End Sub
Public Sub Copydir(sSourcePath As String, sDestination As String, iRetCd As Integer)
Dim numCopied, numDeleted As Long
Dim fsosub As New FileSystemObject
'set the appropriate initializing values
pthDst = pathCheck(sDestination)
pthSrc = pathCheck(sSourcePath)
pthDst = left(pthDst, Len(pthDst) - 1)
pthSrc = left(pthSrc, Len(pthSrc) - 1)
ce = 0: On Error GoTo erretcopy
Call fsosub.CopyFolder(pthSrc, pthDst, True)
On Error GoTo 0
'
'place filenames in folder into the as400
'
If ce = 0 Then
Call cmdReadFileNames_Click
End If
iRetCd = ce
Pause (2)
Exit Sub
erretcopy:
ce = 1
Resume Next
End Sub
Public Sub KillDir(sSourcePath As String, iRetCd As Integer)
Dim sFiles As String
Dim numCopied, numDeleted As Long
'set the appropriate initializing values
sSourcePath = pathCheck(sSourcePath)
'MsgBox numCopied & " files copied to " & sDestination
Call DeleteDir(sSourcePath)
iRetCd = 0
End Sub
Private Sub DeleteDir(sSourcePath As String)
On Error Resume Next
Dim fsosub As New FileSystemObject
pthn$ = pathCheck(sSourcePath)
pthn$ = left(pthn$, Len(pthn$) - 1)
Call fsosub.DeleteFolder(pthn$, True)
End Sub

BIN
Cmdproc-6.frx Normal file

Binary file not shown.

1
Cmdproc-6.log Normal file
View File

@ -0,0 +1 @@
Line 14: Class MSDataGridLib.DataGrid of control DataGrid1 was not a loaded control class.

77
DWPORT.CLS Normal file
View File

@ -0,0 +1,77 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "dwPortInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Desaware API Class library
' Copyright (c) 1995-1997 by Desaware Inc.
' All rights reserved
' Preliminary demonstration edition
Option Explicit
Private Type PORT_INFO_1
pName As Long
End Type
Private Type PORT_INFO_2
pPortName As Long
pMonitorName As Long
pDescription As Long
fPortType As Long
Reserved As Long
End Type
Public pName$
Public pMonitorName$
Public pDescription$
Public fPortType&
Public Level&
Public Sub LoadInfo(Buf As Byte, pLevel&, x&)
Level = pLevel
Select Case Level
Case 1
LoadPortInfo1 Buf, x&
Case 2
LoadPortInfo2 Buf, x&
End Select
End Sub
Public Sub LoadPortInfo1(Buf As Byte, x&)
Dim pi As PORT_INFO_1
Dim offset&
Dim useaddr&
offset& = x * Len(pi)
useaddr& = agGetAddressForObject(Buf) + offset
Call agCopyData(ByVal useaddr, pi, Len(pi))
If (pi.pName <> 0) Then pName = agGetStringFromPointer(pi.pName)
End Sub
Public Sub LoadPortInfo2(Buf As Byte, x&)
Dim pi As PORT_INFO_2
Dim offset&
Dim useaddr&
offset& = x * Len(pi)
useaddr& = agGetAddressForObject(Buf) + offset
Call agCopyData(ByVal useaddr, pi, Len(pi))
pPortName = agGetStringFromPointer(pi.pPortName)
pMonitorName = agGetStringFromPointer(pi.pMonitorName)
pDescription = agGetStringFromPointer(pi.pDescription)
fPortType = pi.fPortType
End Sub
' pPortName is an alias for pName
Public Property Get pPortName() As String
pPortName = pName
End Property
Public Property Let pPortName(ByVal vNewValue$)
pName = vNewValue
End Property

206
DWPRINFO.CLS Normal file
View File

@ -0,0 +1,206 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "dwPrinterInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Desaware API Class library
' Copyright (c) 1995-1997 by Desaware
' All rights reserved
' Preliminary demonstration edition
Option Explicit
Private Type PRINTER_INFO_1
Flags As Long
pDescription As Long
pName As Long
pComment As Long
End Type
Private Type PRINTER_INFO_2
pServerName As Long
pPrinterName As Long
pShareName As Long
pPortName As Long
pDriverName As Long
pComment As Long
pLocation As Long
pDevMode As Long ' Pointer to DEVMODE
pSepFile As String
pPrintProcessor As Long
pDatatype As Long
pParameters As Long
pSecurityDescriptor As Long ' Pointer to SECURITY_DESCRIPTOR
Attributes As Long
Priority As Long
DefaultPriority As Long
StartTime As Long
UntilTime As Long
Status As Long
cJobs As Long
AveragePPM As Long
End Type
Private Type PRINTER_INFO_3
pSecurityDescriptor As Long ' Pointer to SECURITY_DESCRIPTOR
End Type
Private Type PRINTER_INFO_4
pPrinterName As Long
pServerName As Long
Attributes As Long
End Type
Private Type PRINTER_INFO_5
pPrinterName As Long
pPortName As Long
Attributes As Long
DeviceNotSelectedTimeout As Long
TransmissionRetryTimeout As Long
End Type
Public Flags&
Public pDescription$
Public pName$
Public pComment$
Public pServerName$
Public pPrinterName$
Public pShareName$
Public pPortName$
Public pDriverName$
Public pLocation$
Private pDevMode As DEVMODE
Public pSepFile$
Public pPrintProcessor$
Public pDatatype$
Public pParameters$
Public Attributes&
Public Priority&
Public DefaultPriority&
Public StartTime&
Public UntilTime&
Public Status&
Public cJobs&
Public AveragePPM&
Public DeviceNotSelectedTimeout&
Public TransmissionRetryTimeout&
Private pSecurityDescriptor As SECURITY_DESCRIPTOR
Public Level& ' Level for which this object was created
Public Sub ResetContents()
Flags = 0
pDescription$ = ""
pName$ = ""
pComment$ = ""
pServerName$ = ""
pPrinterName$ = ""
pShareName$ = ""
pPortName$ = ""
pDriverName$ = ""
pLocation$ = ""
pSepFile$ = ""
pPrintProcessor$ = ""
pDatatype$ = ""
pParameters$ = ""
Attributes& = 0
Priority& = 0
DefaultPriority& = 0
StartTime& = 0
UntilTime& = 0
Status& = 0
cJobs& = 0
AveragePPM& = 0
DeviceNotSelectedTimeout& = 0
TransmissionRetryTimeout& = 0
End Sub
' Load information from a byte structure
Public Sub LoadInfo(Buf As Byte, pLevel&, x&)
Level = pLevel
Select Case Level
Case 1
LoadPrinterInfo1 Buf, x&
Case 2
LoadPrinterInfo2 Buf, x&
Case 4
LoadPrinterInfo4 Buf, x&
Case 5
LoadPrinterInfo5 Buf, x&
End Select
End Sub
' Load from PRINTER_INFO_1
Public Sub LoadPrinterInfo1(Buf As Byte, x&)
Dim pi As PRINTER_INFO_1
Dim offset&
Dim useaddr&
offset& = x * Len(pi)
useaddr& = agGetAddressForObject(Buf) + offset
Call agCopyData(ByVal useaddr, pi, Len(pi))
Flags = pi.Flags
pDescription = agGetStringFromPointer(pi.pDescription)
pName = agGetStringFromPointer(pi.pName)
pComment = agGetStringFromPointer(pi.pComment)
End Sub
' Load from PRINTER_INFO_2
Public Sub LoadPrinterInfo2(Buf As Byte, x&)
Dim pi As PRINTER_INFO_2
Dim offset&
Dim useaddr&
offset& = x * Len(pi)
useaddr& = agGetAddressForObject(Buf) + offset
Call agCopyData(ByVal useaddr, pi, Len(pi))
pServerName = agGetStringFromPointer(pi.pServerName)
pPrinterName = agGetStringFromPointer(pi.pPrinterName)
pShareName = agGetStringFromPointer(pi.pShareName)
pPortName = agGetStringFromPointer(pi.pPortName)
pDriverName = agGetStringFromPointer(pi.pDriverName)
pComment = agGetStringFromPointer(pi.pComment)
pLocation = agGetStringFromPointer(pi.pLocation)
agCopyData ByVal pi.pDevMode, pDevMode, Len(pDevMode)
agCopyData ByVal pi.pSecurityDescriptor, pSecurityDescriptor, Len(pSecurityDescriptor)
pSepFile = agGetStringFromPointer(pi.pSepFile)
pPrintProcessor = agGetStringFromPointer(pi.pPrintProcessor)
pDatatype = agGetStringFromPointer(pi.pDatatype)
pParameters = agGetStringFromPointer(pi.pParameters)
Attributes = pi.Attributes
Priority = pi.Priority
DefaultPriority = pi.DefaultPriority
StartTime = pi.StartTime
UntilTime = pi.UntilTime
Status = pi.Status
cJobs = pi.cJobs
AveragePPM = pi.AveragePPM
End Sub
' Load from PRINTER_INFO_4
Public Sub LoadPrinterInfo4(Buf As Byte, x&)
Dim pi As PRINTER_INFO_4
Dim offset&
Dim useaddr&
offset& = x * Len(pi)
useaddr& = agGetAddressForObject(Buf) + offset
Call agCopyData(ByVal useaddr, pi, Len(pi))
pPrinterName = agGetStringFromPointer(pi.pPrinterName)
pServerName = agGetStringFromPointer(pi.pServerName)
Attributes = pi.Attributes
End Sub
Public Sub LoadPrinterInfo5(Buf As Byte, x&)
Dim pi As PRINTER_INFO_5
Dim offset&
Dim useaddr&
offset& = x * Len(pi)
useaddr& = agGetAddressForObject(Buf) + offset
Call agCopyData(ByVal useaddr, pi, Len(pi))
pPrinterName = agGetStringFromPointer(pi.pPrinterName)
pPortName = agGetStringFromPointer(pi.pPortName)
Attributes = pi.Attributes
DeviceNotSelectedTimeout = pi.DeviceNotSelectedTimeout
TransmissionRetryTimeout = pi.TransmissionRetryTimeout
End Sub

65
DWPRMON.CLS Normal file
View File

@ -0,0 +1,65 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "dwPrintMonitor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Desaware API Class library
' Copyright (c) 1995-1997 by Desaware
' All rights reserved
' Preliminary demonstration edition
Option Explicit
Public pName$ ' Print monitor name
Public pEnvironment$ ' Environment for monitor
Public pDLLName$ ' DLL name of print monitor
Public Level&
Private Type MONITOR_INFO_1
pName As Long
End Type
Private Type MONITOR_INFO_2
pName As Long
pEnvironment As Long
pDLLName As Long
End Type
Public Sub LoadInfo(Buf As Byte, pLevel&, x&)
Level = pLevel
Select Case Level
Case 1
LoadMonitorInfo1 Buf, x&
Case 2
LoadMonitorInfo2 Buf, x&
End Select
End Sub
Public Sub LoadMonitorInfo1(Buf As Byte, x&)
Dim pi As MONITOR_INFO_1
Dim offset&
Dim useaddr&
offset& = x * Len(pi)
useaddr& = agGetAddressForObject(Buf) + offset
Call agCopyData(ByVal useaddr, pi, Len(pi))
If (pi.pName <> 0) Then pName = agGetStringFromPointer(pi.pName)
End Sub
Public Sub LoadMonitorInfo2(Buf As Byte, x&)
Dim pi As MONITOR_INFO_2
Dim offset&
Dim useaddr&
offset& = x * Len(pi)
useaddr& = agGetAddressForObject(Buf) + offset
Call agCopyData(ByVal useaddr, pi, Len(pi))
If (pi.pName <> 0) Then pName = agGetStringFromPointer(pi.pName)
If (pi.pEnvironment <> 0) Then pEnvironment = agGetStringFromPointer(pi.pEnvironment)
If (pi.pDLLName <> 0) Then pDLLName = agGetStringFromPointer(pi.pDLLName)
End Sub

110
DWSPOOL.CLS Normal file
View File

@ -0,0 +1,110 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "dwSpool"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' Desaware API Class library
' Copyright (c) 1995-1997 by Desaware
' All rights reserved
' Preliminary demonstration edition
Option Explicit
Private Declare Function apiEnumPrinters Lib "winspool.drv" Alias "EnumPrintersA" (ByVal Flags As Long, ByVal Name As String, ByVal Level As Long, pPrinterEnum As Byte, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function apiEnumPorts Lib "winspool.drv" Alias "EnumPortsA" (ByVal pName As String, ByVal Level As Long, lpbPorts As Byte, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function apiEnumMonitors Lib "winspool.drv" Alias "EnumMonitorsA" (ByVal pName As String, ByVal Level As Long, pMonitors As Byte, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
' Retrieves a collection of printer objects
Public Function EnumPrinters(Flags As Long, Name As String, Level As Long) As Collection
Dim needed&
Dim returned&
Dim res&
Dim tbt As Byte
Dim usename$
Dim cprinters As New Collection
Dim x&
Dim ppi As dwPrinterInfo
If Name$ = "" Then usename$ = vbNullString Else usename$ = Name
res& = apiEnumPrinters(Flags, usename$, Level, tbt, 0, needed, returned)
If needed& = 0 Then
Set EnumPrinters = cprinters
Exit Function
End If
ReDim ResultBuffer(needed) As Byte
res& = apiEnumPrinters(Flags, usename$, Level, ResultBuffer(0), needed, needed, returned)
' Now enumerate create an object for each printer structure
For x = 1 To returned
Set ppi = New dwPrinterInfo
Call ppi.LoadInfo(ResultBuffer(0), Level, x - 1)
cprinters.Add ppi
Next x
Set EnumPrinters = cprinters
End Function
' Retrieves a collection of printer objects
Public Function EnumPorts(Server As String, Level As Long) As Collection
Dim needed&
Dim returned&
Dim res&
Dim tbt As Byte
Dim useserver$
Dim cports As New Collection
Dim x&
Dim ppi As dwPortInfo
If Server$ = "" Then useserver$ = vbNullString Else useserver$ = Server
res& = apiEnumPorts(useserver, Level, tbt, 0, needed, returned)
If needed& = 0 Then
Set EnumPorts = cports
Exit Function
End If
ReDim ResultBuffer(needed) As Byte
res& = apiEnumPorts(useserver, Level, ResultBuffer(0), needed, needed, returned)
Debug.Print GetLastError()
' Now enumerate create an object for each printer structure
For x = 1 To returned
Set ppi = New dwPortInfo
Call ppi.LoadInfo(ResultBuffer(0), Level, x - 1)
cports.Add ppi
Next x
Set EnumPorts = cports
End Function
' Retrieves a collection of monitor objects
Public Function EnumMonitors(Server As String, Level As Long) As Collection
Dim needed&
Dim returned&
Dim res&
Dim tbt As Byte
Dim useserver$
Dim cmonitors As New Collection
Dim x&
Dim ppi As dwPrintMonitor
If Server$ = "" Then useserver$ = vbNullString Else useserver$ = Server
res& = apiEnumPorts(useserver, Level, tbt, 0, needed, returned)
If needed& = 0 Then
Set EnumMonitors = cmonitors
Exit Function
End If
ReDim ResultBuffer(needed) As Byte
res& = apiEnumMonitors(useserver, Level, ResultBuffer(0), needed, needed, returned)
Debug.Print GetLastError()
' Now enumerate create an object for each printer structure
For x = 1 To returned
Set ppi = New dwPrintMonitor
Call ppi.LoadInfo(ResultBuffer(0), Level, x - 1)
cmonitors.Add ppi
Next x
Set EnumMonitors = cmonitors
End Function

11
MSSCCPRJ.SCC Normal file
View File

@ -0,0 +1,11 @@
[SCC]
SCC=This is a source code control file
[Cmndproc.vbp]
SCC_Project_Name=this project is not under source code control
SCC_Aux_Path=<This is an empty string for the mssccprj.scc file>
[SPOOLER.VBP]
SCC_Project_Name=this project is not under source code control
SCC_Aux_Path=<This is an empty string for the mssccprj.scc file>
[TestFolder.VBP]
SCC_Project_Name=this project is not under source code control
SCC_Aux_Path=<This is an empty string for the mssccprj.scc file>

2
Makeps.BAT Normal file
View File

@ -0,0 +1,2 @@
PSMODE Q:\2\2000000\2000768B.plt C:\t2.fil C:\T.FIL C:\CMDPBUFF.1 Y
copy c:\work\shelwait.hld c:\work\shelwait.go

2
PRINTCFG.BAT Normal file
View File

@ -0,0 +1,2 @@
NPRINT C:\CMDPBUFF.1 /NAM=2000768B_KEL /Q=Q-FAB NT NB NFF NNOTI
copy c:\work\shelwait.hld c:\work\shelwait.go

309
Pdf.frm Normal file
View File

@ -0,0 +1,309 @@
VERSION 5.00
Begin VB.Form frmPDF
Caption = "PDF Printer"
ClientHeight = 7380
ClientLeft = 60
ClientTop = 345
ClientWidth = 11355
LinkTopic = "Form1"
ScaleHeight = 7380
ScaleWidth = 11355
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtPrintedBy
Height = 285
Left = 1920
TabIndex = 14
Text = "FEDUCIA"
Top = 1200
Width = 5730
End
Begin VB.TextBox txtBanner
Height = 285
Left = 1920
TabIndex = 13
Text = "Official Production Print"
Top = 1515
Width = 5730
End
Begin VB.ListBox List5
Height = 3765
Left = 5760
TabIndex = 12
Top = 3195
Width = 1635
End
Begin VB.ListBox List4
Height = 3765
Left = 4050
TabIndex = 11
Top = 3195
Width = 1635
End
Begin VB.ListBox List3
Height = 3765
Left = 2340
TabIndex = 10
Top = 3195
Width = 1635
End
Begin VB.ListBox List2
Height = 3765
Left = 630
TabIndex = 9
Top = 3195
Width = 1635
End
Begin VB.ListBox List1
Height = 2790
Left = 7785
TabIndex = 8
Top = 225
Width = 3390
End
Begin VB.Timer Timer1
Left = 9960
Top = 6000
End
Begin VB.TextBox Text1
Height = 735
Left = 90
MultiLine = -1 'True
TabIndex = 7
Text = "Pdf.frx":0000
Top = 2400
Width = 7575
End
Begin VB.TextBox txtPDFPrinter
Height = 285
Left = 1890
TabIndex = 6
Text = "MIS LJ4000"
Top = 855
Width = 5730
End
Begin VB.CommandButton cmdPrintPDF
Caption = "Print PDF"
Height = 405
Left = 120
TabIndex = 4
Top = 1920
Width = 2040
End
Begin VB.TextBox txtPDFtoPrint
Height = 285
Left = 1890
TabIndex = 3
Text = "c:\files\test.pdf"
Top = 540
Width = 5730
End
Begin VB.TextBox txtAdobeStr
Height = 285
Left = 1920
TabIndex = 1
Text = "C:\Program Files\Adobe\Acrobat 5.0\Acrobat\Acrobat.exe"
Top = 225
Width = 5730
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
Caption = "Printed By: "
Height = 240
Index = 4
Left = 120
TabIndex = 16
Top = 1245
Width = 1725
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
Caption = "Banner: "
Height = 240
Index = 3
Left = 120
TabIndex = 15
Top = 1560
Width = 1725
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
Caption = "Printer to Print to:"
Height = 240
Index = 2
Left = 90
TabIndex = 5
Top = 900
Width = 1725
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
Caption = "File To Print:"
Height = 240
Index = 1
Left = 90
TabIndex = 2
Top = 585
Width = 1725
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
Caption = "Adobe Start up string:"
Height = 240
Index = 0
Left = 90
TabIndex = 0
Top = 270
Width = 1725
End
End
Attribute VB_Name = "frmPDF"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdPrintPDF_Click()
' cmdstr$ = "%Start% " + Chr$(34) + "C:\Program Files\Adobe\Reader 8.0\Reader\AcroRd32.exe" + Chr$(34) + " /N /T " + Chr$(34) + "%~1" + Chr$(34) + " " + Chr$(34) + "%~2" + Chr$(34) + ""
FileToPrint$ = txtPDFtoPrint.Text
PrinterToUse$ = txtPDFPrinter.Text
PrintedBy$ = txtPrintedBy.Text
Banner$ = txtBanner.Text
Call PrintAPDF(FileToPrint$, PrinterToUse$, PrintedBy$, Banner$)
End Sub
Private Sub Form_Load()
ppp$ = GetAdobeShellStr
If ppp$ <> "" Then
txtAdobeStr.Text = GetAdobeShellStr
End If
End Sub
Public Sub PrintAPDF(FileToPrint$, PrinterToUse$, PrintedBy$, Banner$)
txtPDFtoPrint.Text = FileToPrint$
txtPDFPrinter.Text = PrinterToUse$
txtPrintedBy.Text = PrintedBy$
txtBanner.Text = Banner$
cmdstr$ = "C:\files\exefolder\printrequest " + Chr$(34) + "sendto=pdfPrinter mesg=" + FileToPrint$ + "|" + PrinterToUse$ + "|" + PrintedBy$ + "|" + Banner$ + Chr$(34)
' cmdstr$ = "cmd /c " + Chr$(34) + "START /MIN " + Chr$(34) + Chr$(34) + " " + Chr$(34) + txtAdobeStr + Chr$(34) + " /N /T " + Chr$(34) + FileToPrint$ + Chr$(34) + " " + Chr$(34) + PrinterToUse$ + Chr$(34) + "" + Chr$(34)
Text1.Text = cmdstr$
pid = Shell(cmdstr$, vbMinimizedNoFocus)
Pause 2
Do
Call LookForAndKillAdobeErrors
If List5.ListCount > 0 Then
Pause 2
a = a
Else
Exit Do
End If
Loop
haldataarea$ = NETHAL + "\wwwroot\EMAILDRAWINGS"
chinadataarea$ = NETHAL + "\wwwroot\EMAILDRAWINGS\CHINADRAWINGS"
MCFdataarea$ = NETHAL + "\wwwroot\EMAILDRAWINGS\MCFDRAWINGS"
HZdataarea$ = NETHAL + "\wwwroot\EMAILDRAWINGS\HZDRAWINGS"
If PrintedBy$ = "CHINA" Then
fln$ = BreakFileName(FileToPrint, 3)
Call Fcopy(FileToPrint$, pathCheck$(chinadataarea$) + fln$, RC%)
Call PrintLog("Copy File - " + FileToPrint + " -> ")
Call PrintLog(" To -> " + pathCheck(chinadataarea) + fln)
Call PrintLog(" Results = " + Str(RC%))
End If
If PrintedBy$ = "MCF" Then
fln$ = BreakFileName(FileToPrint, 3)
Call Fcopy(FileToPrint$, pathCheck$(MCFdataarea$) + fln$, RC%)
Call PrintLog("Copy File - " + FileToPrint + " -> ")
Call PrintLog(" To -> " + pathCheck(MCFdataarea) + fln)
Call PrintLog(" Results = " + Str(RC%))
End If
If PrintedBy$ = "HZ" Then
fln$ = BreakFileName(FileToPrint, 3)
Call Fcopy(FileToPrint$, pathCheck$(HZdataarea$) + fln$, RC%)
Call PrintLog("Copy File - " + FileToPrint + " -> ")
Call PrintLog(" To -> " + pathCheck(HZdataarea) + fln)
Call PrintLog(" Results = " + Str(RC%))
End If
If PrintedBy$ = "QHAL" Then
fln$ = BreakFileName(FileToPrint, 3)
Call Fcopy(FileToPrint$, pathCheck$(haldataarea$) + fln$, RC%)
Call PrintLog("Copy File - " + FileToPrint + " -> ")
Call PrintLog(" To -> " + pathCheck(haldataarea) + fln)
Call PrintLog(" Results = " + Str(RC%))
End If
End Sub
Public Sub LookForAndKillAdobeErrors()
'
' this subroutine requires
' list2, list3,list4,list5
'
List2.Clear
' Call findalllevel(0&, "Adobe Reader", List2)
Call findalllevel(0&, "Adobe Acrobat", List2)
'
' find children with error
'
List5.Clear
For ix = 0 To List2.ListCount - 1
zzz& = Val(Trim(List2.List(ix)))
List3.Clear
Call findalllevel(zzz&, "", List3)
If List3.ListCount > 0 Then
zzc& = Val(Trim(List3.List(0)))
List4.Clear
Call findalllevel(zzc&, "There was an error", List4)
If List4.ListCount > 0 Then
List4.Clear
Call findalllevel(zzc&, "OK", List4)
If List4.ListCount > 0 Then
List5.AddItem Trim(List4.List(0))
End If
End If
End If
Next
For ix = 0 To List5.ListCount - 1
pid$ = List5.List(ix)
zzc& = Val(Trim(pid$))
ck& = SetForegroundWindow(zzc&)
ck& = SetFocusAPI(zzc&)
Pause (0.2)
Call SendKeys("~")
Next
End Sub
Private Sub findalllevel(lvl&, WindowString$, List1 As ListBox)
'
xxt& = lvl&
hdl& = 0
Do
hdl& = FindWindowEx&(xxt&, hdl&, vbNullString, vbNullString)
If WindowString$ = "" Then
List1.AddItem Str(hdl&)
Else
wn$ = left(WindowName$(hdl&), Len(WindowString$))
If wn$ = WindowString$ Then
List1.AddItem Str(hdl&)
End If
End If
If hdl& = 0 Then Exit Do
Loop
End Sub
Private Function WindowName$(wnd&)
If wnd& <> 0 Then
BufferA$ = Space(300)
winlen& = GetWindowText(wnd&, BufferA$, 250)
BufferA$ = left$(BufferA$, winlen&)
WindowName$ = BufferA$
End If
End Function

1
Pdf.frx Normal file
View File

@ -0,0 +1 @@
Text1

47
SPOOLER.VBP Normal file
View File

@ -0,0 +1,47 @@
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINNT\System32\stdole2.tlb#Standard OLE Types
Form=Spooler1.frm
Module=MyFunctions; ..\vbsubs\MYFUNC.BAS
Class=dwPrinterInfo; dwPRInfo.cls
Class=dwSpool; dwSpool.cls
Class=dwPrintMonitor; dwPrMon.cls
Class=dwPortInfo; dwPort.cls
Module=dwTypes; spTypes.bas
Module=APIGuide32; APIGID32.BAS
Module=PrinterConstants; spPrint.bas
IconForm="frmPSSpooler"
Startup="frmPSSpooler"
HelpFile=""
Title="Spooler"
ExeName32="Spooler.exe"
Command32=""
Name="Project1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=2
MinorVer=0
RevisionVer=3
AutoIncrementVer=1
ServerSupportFiles=0
VersionCompanyName="Desaware Inc."
VersionFileDescription="Chapter 12 - Miscellaneous Examples"
VersionLegalCopyright="Copyright (c) 1997, By Desaware"
VersionProductName="Visual Basic Programmer's Guide to the Win32 API"
CompilationType=-1
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1

9
SPOOLER.VBW Normal file
View File

@ -0,0 +1,9 @@
frmPSSpooler = 146, 129, 693, 493, , 5, 18, 850, 540, C
dwPrinterInfo = 56, 65, 776, 429,
dwSpool = 154, 154, 741, 566, C
dwPrintMonitor = 0, 0, 0, 0, C
dwPortInfo = 0, 0, 0, 0, C
dwTypes = 110, 110, 944, 474,
APIGuide32 = 0, 0, 0, 0, C
PrinterConstants = 0, 0, 0, 0, C
MyFunctions = 0, 0, 0, 0, C

689
SPOOLER1.FRM Normal file
View File

@ -0,0 +1,689 @@
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 © 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

BIN
SPOOLER1.frx Normal file

Binary file not shown.

13
SPPRINT.BAS Normal file
View File

@ -0,0 +1,13 @@
Attribute VB_Name = "PrinterConstants"
Option Explicit
' Copyright © 1997 by Desaware Inc. All Rights Reserved.
Public Const PRINTER_ENUM_DEFAULT = &H1
Public Const PRINTER_ENUM_LOCAL = &H2
Public Const PRINTER_ENUM_CONNECTIONS = &H4
Public Const PRINTER_ENUM_FAVORITE = &H4
Public Const PRINTER_ENUM_NAME = &H8
Public Const PRINTER_ENUM_REMOTE = &H10
Public Const PRINTER_ENUM_SHARED = &H20
Public Const PRINTER_ENUM_NETWORK = &H40

47
SPTYPES.BAS Normal file
View File

@ -0,0 +1,47 @@
Attribute VB_Name = "dwTypes"
' Desaware API Class library
' Copyright (c) 1995-1997 by Desaware Inc.
' All rights reserved
Option Explicit
#If Win32 Then
Public Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
#Else
Public Type RECT
left As Integer
top As Integer
right As Integer
bottom As Integer
End Type
#End If 'WIN32 Types
#If Win32 Then
Type ACL
AclRevision As Byte
Sbz1 As Byte
AclSize As Integer
AceCount As Integer
Sbz2 As Integer
End Type
Type SECURITY_DESCRIPTOR
Revision As Byte
Sbz1 As Byte
Control As Long
Owner As Long
Group As Long
Sacl As ACL
Dacl As ACL
End Type
#End If

51
TEST.VBP Normal file
View File

@ -0,0 +1,51 @@
Type=Exe
Reference=*\G{56BF9020-7A2F-11D0-9482-00A0C91110ED}#1.0#0#C:\WINDOWS\system32\MSBIND.DLL#Microsoft Data Binding Collection
Reference=*\G{00000205-0000-0010-8000-00AA006D2EA4}#2.5#0#C:\Program Files\Common Files\system\ado\msado25.tlb#Microsoft ActiveX Data Objects 2.5 Library
Object={6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0; COMCTL32.OCX
Object={BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0; TABCTL32.OCX
Object={67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0; MSADODC.OCX
Object={CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0; MSDATGRD.OCX
Module=Main; CMNDPROC.BAS
Module=MyFunctions; ..\..\vbsubs\Myfunc.bas
Class=dwPortInfo; DWPORT.CLS
Class=dwPrinterInfo; DWPRINFO.CLS
Class=dwPrintMonitor; DWPRMON.CLS
Class=dwSpool; DWSPOOL.CLS
Module=APIGuide32; APIGID32.BAS
Module=PrinterConstants; SPPRINT.BAS
Module=dwTypes; SPTYPES.BAS
Form=Cmdproc-6.frm
Class=ClearBOM; ClearBom.cls
Startup="frmFolderCopy"
HelpFile=""
Title="Cmndproc"
ExeName32="Cmndproc1FEB2008.exe"
Path32="\\Fm1\eng\USERS\286\CMNDPROC"
Command32=""
Name="test"
HelpContextID="0"
CompatibleMode="0"
MajorVer=4
MinorVer=0
RevisionVer=61
AutoIncrementVer=1
ServerSupportFiles=0
VersionCompanyName="Enterprise Computing Services, Inc."
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1

11
TEST.vbw Normal file
View File

@ -0,0 +1,11 @@
Main = 57, 13, 694, 567, C
MyFunctions = 23, -11, 780, 358,
dwPortInfo = 0, 0, 0, 0, C
dwPrinterInfo = -38, 129, 558, 493, C
dwPrintMonitor = 0, 0, 0, 0, C
dwSpool = 0, 0, 0, 0, C
APIGuide32 = -31, 69, 803, 433, C
PrinterConstants = 154, 154, 741, 566, C
dwTypes = 0, 0, 0, 0, C
frmFolderCopy = 11, 9, 772, 604, , 95, 13, 756, 616, C
ClearBOM = -65, -10, 644, 483, C

43
TestFolder.VBP Normal file
View File

@ -0,0 +1,43 @@
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINNT\system32\stdole2.tlb#Standard OLE Types
Reference=*\G{420B2830-E718-11CF-893D-00A0C9054228}#1.0#0#C:\WINNT\System32\scrrun.dll#Microsoft Scripting Runtime
Object={67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0; MSADODC.OCX
Object={CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0; MSDATGRD.OCX
Reference=*\G{56BF9020-7A2F-11D0-9482-00A0C91110ED}#1.0#0#C:\WINNT\System32\MSBIND.DLL#Microsoft Data Binding Collection
Module=MyFunctions; ..\..\vbsubs\MYFUNC.BAS
Form=Pdf.frm
Startup="frmPDF"
HelpFile=""
Title="Spooler"
ExeName32="Spooler.exe"
Command32=""
Name="Project1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=2
MinorVer=0
RevisionVer=3
AutoIncrementVer=1
ServerSupportFiles=0
VersionCompanyName="Desaware Inc."
VersionFileDescription="Chapter 12 - Miscellaneous Examples"
VersionLegalCopyright="Copyright (c) 1997, By Desaware"
VersionProductName="Visual Basic Programmer's Guide to the Win32 API"
CompilationType=-1
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1

2
TestFolder.vbw Normal file
View File

@ -0,0 +1,2 @@
MyFunctions = 274, 111, 1024, 546, C
frmPDF = 145, 44, 979, 596, , 110, 145, 944, 697, C

129
filewatch.frm Normal file
View File

@ -0,0 +1,129 @@
VERSION 5.00
Begin VB.Form frmFileWatch
Caption = "File Watch"
ClientHeight = 7005
ClientLeft = 60
ClientTop = 345
ClientWidth = 10875
BeginProperty Font
Name = "Courier New"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ScaleHeight = 7005
ScaleWidth = 10875
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdClose
Caption = "Close"
Height = 285
Left = 1680
TabIndex = 1
Top = 6720
Width = 1515
End
Begin VB.Timer Timer1
Interval = 1000
Left = 5550
Top = 210
End
Begin VB.ListBox lstFileWatch
Height = 6570
Left = 60
TabIndex = 0
Top = 60
Width = 10455
End
End
Attribute VB_Name = "frmFileWatch"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdClose_Click()
Unload frmFileWatch
End Sub
Private Sub Form_Load()
lstFileWatch.AddItem doesit$(MessageFileName$, "0")
lstFileWatch.AddItem doesit$(MessageLogName$, "0")
lstFileWatch.AddItem doesit$(MessageLogName2$, "0")
lstFileWatch.AddItem doesit$(COMPLETE$, "1")
lstFileWatch.AddItem doesit$(COMPLETE2$, "0")
lstFileWatch.AddItem doesit$(INCOME$, "1")
lstFileWatch.AddItem doesit$(Reply$, "1")
lstFileWatch.AddItem doesit$(ReplyComplete$, "1")
lstFileWatch.AddItem doesit$(ReplyComplete2$, "0")
lstFileWatch.AddItem doesit$(CADPRINT$, "0")
lstFileWatch.AddItem doesit$(QUEHANDL, "0")
lstFileWatch.AddItem doesit$(CADPRNT2, "1")
lstFileWatch.AddItem doesit$(PLOTCFG$, "0")
lstFileWatch.AddItem doesit$(PrinterCFG$, "0")
lstFileWatch.AddItem doesit$(SUBSCFG$, "0")
lstFileWatch.AddItem doesit$(PrintCfg$, "0")
lstFileWatch.AddItem doesit$(MAKEPS$, "0")
lstFileWatch.AddItem doesit$(TFIL$, "0")
lstFileWatch.AddItem doesit$(BufferName$, "1")
lstFileWatch.AddItem doesit$(ACADComplete$, "1")
lstFileWatch.AddItem doesit$(ACADWait$, "1")
lstFileWatch.AddItem doesit$(ACADIncome$, "1")
lstFileWatch.AddItem doesit$(ACADCH$, "0")
lstFileWatch.AddItem doesit$(ACADReply$, "1")
'
lstFileWatch.AddItem doesit$(PROEComplete$, "1")
lstFileWatch.AddItem doesit$(PROEWait$, "1")
lstFileWatch.AddItem doesit$(PROEIncome$, "1")
lstFileWatch.AddItem doesit$(PROECH$, "0")
lstFileWatch.AddItem doesit$(PROEReply$, "1")
lstFileWatch.AddItem doesit$(PROERPCM$, "1")
End Sub
Private Sub Timer1_Timer()
For i = 0 To lstFileWatch.ListCount - 1
xx$ = lstFileWatch.List(i)
Call PARSE(xx$, stat$, "|", RC%)
Call PARSE(xx$, mode$, "|", RC%)
Call PARSE(xx$, ffl$, "|", RC%)
lstFileWatch.List(i) = doesit$(ffl$, mode$)
Next
End Sub
Function doesit$(fl$, mode$)
d$ = ""
Select Case mode$
Case "0"
If ExistsNew(fl$) Then
d$ = "Normal Exists" + "|" + mode$ + "|" + fl$
Else
d$ = "--Warn Not Exists" + "|" + mode$ + "|" + fl$
End If
Case "1"
If ExistsNew(fl$) Then
d$ = "--Warn Exists" + "|" + mode$ + "|" + fl$
Else
d$ = "Normal Not Exists" + "|" + mode$ + "|" + fl$
End If
Case "2"
If ExistsNew(fl$) Then
d$ = "ERROR Exists" + "|" + mode$ + "|" + fl$
Else
d$ = "Normal Not Exists" + "|" + mode$ + "|" + fl$
End If
Case "3"
If ExistsNew(fl$) Then
d$ = "Normal Exists" + "|" + mode$ + "|" + fl$
Else
d$ = "ERROR Not Exists" + "|" + mode$ + "|" + fl$
End If
Case Else
End Select
doesit$ = d$
End Function

1885
oldCMNDPROC.BAS Normal file

File diff suppressed because it is too large Load Diff

469
pdfMod.bas Normal file
View File

@ -0,0 +1,469 @@
Attribute VB_Name = "pdfMod"
Global PlaceFile$, ConfigFile$, Steps%, Processing%, cntlTask As Variant, KeyWait%, taskname$, useAPIFocus
Global adminUser$, adminPass$, userUser$, userPass$, Program$, ListDocFile$, UserNameFile$, userFullName$
Public Const NoOfData = 2
'Windows desktop virtual folder at the root of the name space
Public Const CSIDL_DESKTOP = &H0
'File system directory that contains the
'user's program groups (which are also file
'system directories)
Public Const CSIDL_PROGRAMS = &H2
'Control Panel - virtual folder containing
'icons for the control panel applications
Public Const CSIDL_CONTROLS = &H3
'Printers folder - virtual folder containing
'installed printers.
Public Const CSIDL_PRINTERS = &H4
'File system directory that serves as a
'common repository for documents (Documents folder)
Public Const CSIDL_PERSONAL = &H5
'File system directory that contains the
'user's favorite Internet Explorer URLs
Public Const CSIDL_FAVORITES = &H6
'File system directory that corresponds to the
'user's Startup program group
Public Const CSIDL_STARTUP = &H7
'File system directory that contains the
'user's most recently used documents (Recent folder)
Public Const CSIDL_RECENT = &H8
'File system directory that contains
'Send To menu items
Public Const CSIDL_SENDTO = &H9
'Recycle bin file system directory containing file
'objects in the user's recycle bin. The location of
'this directory is not in the registry; it is marked
'with the hidden and system attributes to prevent the
'user from moving or deleting it.
Public Const CSIDL_BITBUCKET = &HA
'File system directory containing Start menu items
Public Const CSIDL_STARTMENU = &HB
'File system directory used to physically store
'file objects on the desktop (not to be confused
'with the desktop folder itself).
Public Const CSIDL_DESKTOPDIRECTORY = &H10
'My Computer - virtual folder containing everything
'on the local computer: storage devices, printers,
'and Control Panel. The folder may also contain
'mapped network drives.
Public Const CSIDL_DRIVES = &H11
'Network Neighborhood - virtual folder representing
'the top level of the network hierarchy
Public Const CSIDL_NETWORK = &H12
'File system directory containing objects that
'appear in the network neighborhood
Public Const CSIDL_NETHOOD = &H13
'Virtual folder containing fonts
Public Const CSIDL_FONTS = &H14
'File system directory that serves as a
'common repository for document templates
'(ShellNew folder.)
Public Const CSIDL_TEMPLATES = &H15
'application folder
Public Const CSIDL_APPLIC = &H1A
'
' Public Constants
Public Const VFT_UNKNOWN = &H0&
Public Const VFT_APP = &H1&
Public Const VFT_DLL = &H2&
Public Const VFT_DRV = &H3&
Public Const VFT_FONT = &H4&
Public Const VFT_VXD = &H5&
Public Const VFT_STATIC_LIB = &H7&
Public Type VS_FIXEDFILEINFO
dwSignature As Long
dwStrucVersion As Long ' e.g. 0x00000042 = "0.42"
dwFileVersionMS As Long ' e.g. 0x00030075 = "3.75"
dwFileVersionLS As Long ' e.g. 0x00000031 = "0.31"
dwProductVersionMS As Long ' e.g. 0x00030010 = "3.10"
dwProductVersionLS As Long ' e.g. 0x00000031 = "0.31"
dwFileFlagsMask As Long ' = 0x3F for version "0.42"
dwFileFlags As Long ' e.g. VFF_DEBUG Or VFF_PRERELEASE
dwFileOS As Long ' e.g. VOS_DOS_WINDOWS16
dwFileType As Long ' e.g. VFT_DRIVER
dwFileSubtype As Long ' e.g. VFT2_DRV_KEYBOARD
dwFileDateMS As Long ' e.g. 0
dwFileDateLS As Long ' e.g. 0
End Type
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Public Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAborted As Boolean
hNameMaps As Long
sProgress As String
End Type
'Public Const HKEY_CLASSES_ROOT = &H80000000
'Public Const HKEY_CURRENT_USER = &H80000001
'Public Const HKEY_LOCAL_MACHINE = &H80000002
'Public Const HKEY_USERS = &H80000003
'Public Const HKEY_PERFORMANCE_DATA = &H80000004
'Public Const SYNCHRONIZE = &H100000
'Public Const STANDARD_RIGHTS_READ = &H20000
'Public Const STANDARD_RIGHTS_WRITE = &H20000
'Public Const STANDARD_RIGHTS_EXECUTE = &H20000
'Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
'Public Const STANDARD_RIGHTS_ALL = &H1F0000
'Public Const KEY_QUERY_VALUE = &H1
'Public Const KEY_SET_VALUE = &H2
'Public Const KEY_CREATE_SUB_KEY = &H4
'Public Const KEY_ENUMERATE_SUB_KEYS = &H8
'Public Const KEY_NOTIFY = &H10
'Public Const KEY_CREATE_LINK = &H20
'Public Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
'Public Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
'Public Const KEY_EXECUTE = (KEY_READ)
'Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
'Public Const ERROR_SUCCESS = 0&
'-------------------------------------------------
'
' Public Variables
'
' We changed this to Byte to prevent the string
' mangling of the buffer
Public Const FO_MOVE = &H1
Public Const FO_RENAME = &H4
Public Const FOF_SILENT = &H4
Public Const FOF_NOCONFIRMATION = &H10
Public Const FOF_FILESONLY = &H80
Public Const FOF_SIMPLEPROGRESS = &H100
Public Const FOF_NOCONFIRMMKDIR = &H200
Public Const SHARD_PATH = &H2&
Public Const VER_PLATFORM_WIN32_NT = 2
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1
Public Const ERROR_NOT_ALL_ASSIGNED = 1300
Public Const SE_PRIVILEGE_ENABLED = 2
Public Const TOKEN_QUERY = &H8
Public Const TOKEN_ADJUST_PRIVILEGES = &H20
Type DEVMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Type LUID
lowpart As Long
highpart As Long
End Type
Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type
Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges As LUID_AND_ATTRIBUTES
End Type
Declare Function GetFocus& Lib "user32" ()
Declare Function GetForegroundWindow& Lib "user32" ()
Declare Function SetForegroundWindow& Lib "user32" (ByVal hwnd As Long)
Declare Function GetParent& Lib "user32" (ByVal hwnd As Long)
Declare Function GetTopWindow& Lib "user32" (ByVal hwnd As Long)
Declare Function SetActiveWindow& Lib "user32" (ByVal hwnd As Long)
Declare Function SetFocusAPI& Lib "user32" Alias "SetFocus" (ByVal hwnd As Long)
Declare Function GetWindowText& Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal jnk As String, ByVal cch As Long)
Declare Function FINDWINDOW& Lib "user32" Alias "FindWindowA" (ByVal lpclass As String, ByVal lpwin As String)
Declare Function FindWindowEx& Lib "user32" Alias "FindWindowExA" (ByVal lpWinPar As Long, ByVal lpCA As Long, ByVal stclass As String, ByVal stWinNam As String)
Declare Function IsWindow& Lib "user32" (ByVal hwnd As Long)
Declare Function IsWindowEnabled& Lib "user32" (ByVal hwnd As Long)
Declare Function IsWindowVisible& Lib "user32" (ByVal hwnd As Long)
Declare Function GetWindow& Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long)
Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As Any, ByVal dwFlags As Long) As Long
Declare Function ExitWindowsEx Lib "user32" (ByVal uflags As Long, ByVal dwreserved As Long) As Long
Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPriv As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As Any, ByVal lpName As String, lpUid As LUID) As Long
Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public verbuf() As Byte ' Version buffer
Public Filename$ ' Current file to examine
Public Declare Function SHAddToRecentDocs Lib "shell32.dll" (ByVal dwFlags As Long, ByVal dwData As String) As Long
Public Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
Function QuoteAway$(X$)
y$ = Mid$(X$, 2): y$ = left$(y$, Len(y$) - 1)
QuoteAway$ = y$
End Function
Public Function winFindSubWindow&(MainApp&, ChildApp$, RC%)
RC% = False: Fw& = 0
' Call diag("Main " + Str$(MainApp&))
If MainApp& <> 0 Then
ca& = 0
Do
Nxt& = FindWindowEx(MainApp&, ca&, vbNullString, vbNullString)
Buffer$ = WindowName$(Nxt&)
' Call diag("Buffer " + Str$(Nxt&) + " - " + Buffer$)
' Call diag("ChildApp " + ChildApp$)
If Buffer$ = ChildApp$ Then
Fw& = Nxt&
RC% = True
Exit Do
End If
If Nxt& = 0 Then
Exit Do
End If
ca& = Nxt&
Loop
End If
winFindSubWindow& = Fw&
End Function
Public Function WindowName$(wnd&)
If wnd& <> 0 Then
Buffer$ = Space(300)
winlen& = GetWindowText(wnd&, Buffer$, 250)
Buffer$ = left$(Buffer$, winlen&)
WindowName$ = Buffer$
End If
End Function
Public Function FindTheNextWindow&(Nxt&, WindName$)
hdx& = 0
hdl& = Nxt&
Do
hdl& = FindWindowEx&(0&, hdl&, vbNullString, vbNullString)
wn$ = WindowName$(hdl&)
If hdl& = 0 Then Exit Do
If WindName$ = left$(wn$, Len(WindName$)) Then
hdx& = hdl&
Exit Do
End If
Loop
FindTheNextWindow& = hdx&
End Function
Public Sub findalllevel(lvl&, WindowString$, List1 As ListBox)
'
xxt& = lvl&
hdl& = 0
Do
hdl& = FindWindowEx&(xxt&, hdl&, vbNullString, vbNullString)
If WindowString$ = "" Then
List1.AddItem Str(hdl&)
Else
wn$ = left(WindowName$(hdl&), Len(WindowString$))
If wn$ = WindowString$ Then
List1.AddItem Str(hdl&)
End If
End If
If hdl& = 0 Then Exit Do
Loop
End Sub
Public Function searchChildren&(WindowString$, List1 As ListBox)
'
' This routine parses a windowstring formated as follows:
' RootWindowName|ChildName|ChildofChildName...
' requires a listbox (it may be invisible)
'
' returning the window number of the first child meeting the requirements
' returns 0 if none are apply
List1.Clear
a$ = "0|" + WindowString$ + "~"
List1.AddItem a$
ListCountr = 0
Do
b$ = List1.List(0)
List1.RemoveItem (0)
Call PARSE(b$, a$, "~", RC%)
Parent$ = b$
Call PARSE(a$, WindowNumber$, "|", RC%)
Call PARSE(a$, searchWindow$, "|", RC%)
Rest$ = a$ + Parent$
Rt& = Val(WindowNumber$)
If searchWindow$ = "" Then
'
' search is done
'
List1.Clear
List1.AddItem Parent$
searchChildren = Rt&
Exit Function
End If
If searchWindow$ = " " Then searchWindow$ = ""
ct& = 0
Do
ct& = winFindSubWindow2&(Rt&, ct&, searchWindow$)
If ct& <> 0 Then
wn$ = WindowName$(ct&)
List1.AddItem Trim$(Str$(ct&)) + Rest$ + wn$ + "|"
End If
Loop Until ct& = 0
Loop Until List1.ListCount = 0
End Function
Public Function winFindSubWindow2&(Root&, Nxt&, WindName$)
hdx& = 0
hdl& = Nxt&
Do
hdl& = FindWindowEx&(Root&, hdl&, vbNullString, vbNullString)
wn$ = WindowName$(hdl&)
If hdl& = 0 Then Exit Do
If WindName$ = left$(wn$, Len(WindName$)) Then
hdx& = hdl&
Exit Do
End If
Loop
winFindSubWindow2& = hdx&
End Function
Private Function GetSpecialFolder(CSIDL As Long) As String
'a few local variables needed
Dim r As Long
Dim sPath As String
Dim pidl As Long
Const NOERROR = 0
Const MAX_LENGTH = 260
'fill pidl with the specified folder item
r = SHGetSpecialFolderLocation(Form1.hwnd, CSIDL, pidl)
If r = NOERROR Then
'Of the structure is filled, initialize and
'retrieve the path from the id list, and return
'the folder with a trailing slash appended.
sPath = Space$(MAX_LENGTH)
r = SHGetPathFromIDList(ByVal pidl, ByVal sPath)
If r Then
GetSpecialFolder = left$(sPath, _
InStr(sPath, Chr$(0)) - 1) & "\"
End If
End If
End Function
Private Sub ShellRenameFile(sOldName As String, sNewName As String)
'set some working variables
Dim SHFileOp As SHFILEOPSTRUCT
Dim r As Long
'add a pair of terminating nulls to each string
sOldName = sOldName & Chr$(0) & Chr$(0)
sNewName = sNewName & Chr$(0) & Chr$(0)
'set up the options
With SHFileOp
.wFunc = FO_RENAME
.pFrom = sOldName
.pTo = sNewName
.fFlags = FOF_SILENT Or FOF_NOCONFIRMATION
End With
'and rename the file
r = SHFileOperation(SHFileOp)
End Sub
'--end block--'

62
tstPROC.VBP Normal file
View File

@ -0,0 +1,62 @@
Type=Exe
Reference=*\G{56BF9020-7A2F-11D0-9482-00A0C91110ED}#1.0#0#C:\WINDOWS\system32\MSBIND.DLL#Microsoft Data Binding Collection
Reference=*\G{00000205-0000-0010-8000-00AA006D2EA4}#2.5#0#C:\Program Files\Common Files\system\ado\msado25.tlb#Microsoft ActiveX Data Objects 2.5 Library
Reference=*\G{420B2830-E718-11CF-893D-00A0C9054228}#1.0#0#C:\WINDOWS\system32\scrrun.dll#Microsoft Scripting Runtime
Object={BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0; TABCTL32.OCX
Object={67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0; MSADODC.OCX
Object={CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0; MSDatGrd.ocx
Form=Cmdproc-3.frm
Module=Main; CMNDPROC.BAS
Module=MyFunctions; ..\..\vbsubs\Myfunc.bas
Form=Cmdproc-4.frm
Form=Cmdproc-1.frm
Form=Cmdproc-2.frm
Class=dwPortInfo; DWPORT.CLS
Class=dwPrinterInfo; DWPRINFO.CLS
Class=dwPrintMonitor; DWPRMON.CLS
Class=dwSpool; DWSPOOL.CLS
Form=SPOOLER1.FRM
Module=APIGuide32; APIGID32.BAS
Module=PrinterConstants; SPPRINT.BAS
Module=dwTypes; SPTYPES.BAS
Form=filewatch.frm
Form=Cmdproc-5.frm
Form=Cmdproc-6.frm
Class=ClearBOM; ClearBom.cls
Form=Pdf.frm
Object={19B7F2A2-1610-11D3-BF30-1AF820524153}#1.1#0; ccrpftv6.ocx
Object={6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0; COMCTL32.OCX
IconForm="frmMain"
Startup="frmStart"
HelpFile=""
Title="Cmndproc"
ExeName32="Cmndproc17OCT2012.exe"
Path32="\\Fm1\eng\USERS\286\CMNDPROC"
Command32=""
Name="CommandProcessor"
HelpContextID="0"
CompatibleMode="0"
MajorVer=4
MinorVer=0
RevisionVer=122
AutoIncrementVer=1
ServerSupportFiles=0
VersionCompanyName="Enterprise Computing Services, Inc."
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1

19
tstPROC.vbw Normal file
View File

@ -0,0 +1,19 @@
frmStart = 0, 0, 0, 0, C, 0, 0, 0, 0, C
Main = 0, 0, 0, 0, C
MyFunctions = 0, 0, 0, 0, C
frmCheckAssembly = 0, 0, 0, 0, C, 22, 29, 524, 519, C
frmMain = 0, 0, 0, 0, C, 0, 0, 0, 0, C
frmQueHandler = 0, 0, 0, 0, C, 0, 0, 0, 0, C
dwPortInfo = 0, 0, 0, 0, C
dwPrinterInfo = 0, 0, 0, 0, C
dwPrintMonitor = 0, 0, 0, 0, C
dwSpool = 0, 0, 0, 0, C
frmPSSpooler = 0, 0, 0, 0, C, 0, 0, 0, 0, C
APIGuide32 = 0, 0, 0, 0, C
PrinterConstants = 0, 0, 0, 0, C
dwTypes = 0, 0, 0, 0, C
frmFileWatch = 0, 0, 0, 0, C, 0, 0, 0, 0, C
frmBOM = 0, 0, 0, 0, C, 0, 0, 0, 0, C
frmFolderCopy = 0, 0, 0, 0, C, 0, 0, 0, 0, C
ClearBOM = 0, 0, 0, 0, C
frmPDF = 0, 0, 0, 0, C, 0, 0, 0, 0, C