azcomputerguru/claudetools
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
main
claudetools/clients/valleywide/app-modernization/source-code/Full-Project/VWP_Current/frmPrint.frm
Mike Swanson 5359e7c49e feat(valleywide): recover VWP Orders VB6 source from D: backup drive 
Recovered Darv's VB6 source for the Valley Wide Plastering Orders
application from the D: backup drive (label "Backup", 8 TB, 5.3 TB used).
This is the first time we've had the actual source — prior session only
had a single frmPayroll.frm from the AD server.

Three project variants identified across two snapshots:
- Full-Project/   (2,129 files, 124 MB) — D:\Office-Estimates\Darv\Full\Project\
- Kingston-Project/ (2,189 files, 130 MB) — D:\Office-Estimates\Darv\Kingston\Project\
- Source/         (170 files, 559 MB)   — D:\Office-Estimates\Darv\Source\ wholesale
- SOURCE-HOLD/    (3 files, 1 MB)       — D:\Office-Estimates\Darv\SOURCE HOLD\

Latest ORDERS_C.vbp date is 2020-06-09 (Kingston snapshot). Production
Orders_10A.exe was live as of April 2024 — open question whether newer
source exists on other backup drives Mike will scan next.

Also includes per-category and per-keyword analysis CSVs from a WizTree
file-list export, plus the analyzer script that produced them
(re-runnable for the next drive's CSV).

VMs (VWIN7-DW.vdi 8.3 GB + XP-for-ORDERS_copy.vdi 2.8 GB), the live
VWP.mdb, and the 393 MB raw WizTree CSV stay on disk only — gitignored.

Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com>
2026-05-16 17:36:27 -07:00

824 lines
25 KiB
Plaintext
Raw Permalink Blame History

VERSION 5.00
Object = "{00025600-0000-0000-C000-000000000046}#5.2#0"; "Crystl32.OCX"
Begin VB.Form frmPrint
Caption = "Print Orders"
ClientHeight = 4650
ClientLeft = 60
ClientTop = 345
ClientWidth = 4440
KeyPreview = -1 'True
LinkTopic = "Form1"
ScaleHeight = 4650
ScaleWidth = 4440
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtJobCost
Height = 285
Left = 3540
TabIndex = 21
Top = 2580
Visible = 0 'False
Width = 495
End
Begin VB.TextBox txtNotes
Height = 1095
Left = 60
MultiLine = -1 'True
ScrollBars = 2 'Vertical
TabIndex = 6
Top = 2940
Width = 4275
End
Begin VB.TextBox txtSupplier
Height = 285
Left = 2280
TabIndex = 19
Top = 2340
Visible = 0 'False
Width = 1095
End
Begin VB.TextBox txtCopy
Height = 315
Left = 1200
TabIndex = 5
Top = 2280
Visible = 0 'False
Width = 315
End
Begin VB.TextBox txtHeader
Alignment = 2 'Center
BeginProperty Font
Name = "MS Sans Serif"
Size = 18
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 285
Left = 3000
TabIndex = 17
Top = 1980
Visible = 0 'False
Width = 735
End
Begin VB.PictureBox picFoam
AutoRedraw = -1 'True
AutoSize = -1 'True
Height = 1215
Left = 2640
ScaleHeight = 1155
ScaleWidth = 1095
TabIndex = 16
Top = 645
Visible = 0 'False
Width = 1155
End
Begin Crystal.CrystalReport crPrint
Left = 1215
Top = 4155
_ExtentX = 741
_ExtentY = 741
_Version = 348160
PrintFileLinesPerPage= 60
End
Begin VB.TextBox txtDelivery
Height = 315
Left = 1200
TabIndex = 4
Top = 1920
Visible = 0 'False
Width = 1275
End
Begin VB.CheckBox chkPreOrder
Caption = "PreOrder"
Height = 375
Left = 1200
TabIndex = 3
Top = 1440
Visible = 0 'False
Width = 1335
End
Begin VB.TextBox txtPO
Height = 315
Left = 3840
TabIndex = 14
Top = 2160
Visible = 0 'False
Width = 495
End
Begin VB.TextBox txtDFlag
Height = 345
Left = 3900
TabIndex = 13
Top = 1740
Visible = 0 'False
Width = 375
End
Begin VB.TextBox txtOrderDate
Height = 315
Left = 1200
MaxLength = 10
TabIndex = 1
Top = 660
Width = 1275
End
Begin VB.CommandButton cmdCancel
Caption = "&Cancel"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 3300
TabIndex = 8
Top = 4140
Width = 1035
End
Begin VB.CommandButton cmdPrint
Caption = "&Print"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 60
TabIndex = 7
Top = 4125
Width = 1035
End
Begin VB.TextBox txtMFlag
Height = 285
Left = 3900
TabIndex = 12
Top = 1320
Visible = 0 'False
Width = 375
End
Begin VB.TextBox txtPONum
Height = 285
Left = 120
TabIndex = 11
Top = 1320
Visible = 0 'False
Width = 375
End
Begin VB.ComboBox cboSupplier
Height = 315
Left = 1200
Sorted = -1 'True
Style = 2 'Dropdown List
TabIndex = 2
Top = 1020
Width = 2295
End
Begin VB.Label lblNotes
AutoSize = -1 'True
Caption = "Notes to Print On PO:"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 195
Left = 120
TabIndex = 20
Top = 2700
Width = 1860
End
Begin VB.Label lblCopy
Alignment = 1 'Right Justify
AutoSize = -1 'True
Caption = "Copies:"
Height = 195
Left = 600
TabIndex = 18
Top = 2340
Visible = 0 'False
Width = 525
End
Begin VB.Label lblDelivery
Alignment = 1 'Right Justify
AutoSize = -1 'True
Caption = "Foam Cut Date:"
Height = 195
Left = 15
TabIndex = 15
Top = 1980
Visible = 0 'False
Width = 1110
End
Begin VB.Label lblTitle
Alignment = 2 'Center
Caption = "Lath Order"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 435
Left = 60
TabIndex = 10
Top = 120
Width = 4335
End
Begin VB.Label lblSupplier
Alignment = 1 'Right Justify
AutoSize = -1 'True
Caption = "Supplier:"
Height = 195
Left = 510
TabIndex = 9
Top = 1080
Width = 615
End
Begin VB.Label lblOrderDate
Alignment = 1 'Right Justify
AutoSize = -1 'True
Caption = "Delivery Date:"
Height = 195
Left = 120
TabIndex = 0
Top = 720
Width = 1005
End
End
Attribute VB_Name = "frmPrint"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mboolJPG As Boolean
Dim moRSOrders As Recordset
'Dim moRS As Recordset
Private Sub SupplierLoad()
Dim oRS As Recordset
Dim strSQL As String, strFLAG As String
On Error GoTo Error_EH
'If needed to load suppliers for Wrap, changes will need to be done here
If gstrTYPE = "Y" Then
strFLAG = "L"
ElseIf gstrTYPE = "S" Then
strFLAG = "S"
ElseIf gstrTYPE = "A" Then
strFLAG = "A"
End If
If gstrTYPE = "Y" And strFLAG = "L" And Not gstrFLAG = "P" Then
gstrTYPE = "S"
End If
strSQL = "SELECT * FROM tblSupplier where type = '" & strFLAG & "'"
Set oRS = New Recordset
oRS.Open strSQL, goConn, _
adOpenForwardOnly, adLockReadOnly
Do Until oRS.EOF
cboSupplier.AddItem oRS!supplier
cboSupplier.ItemData(cboSupplier.NewIndex) = Field2Long(oRS!sup_no)
oRS.MoveNext
Loop
oRS.Close
Exit Sub
Error_EH:
gstrMODULE = "Form Print - Module SupplierLoad"
Call ErrorHandler2
gstrMODULE = ""
Exit Sub
End Sub
Private Sub cboSupplier_Change()
If cboSupplier.ListIndex = -1 Then
Exit Sub
End If
If gstrFLAG = "P" And (cboSupplier.ItemData(cboSupplier.ListIndex) = 16 Or cboSupplier.ItemData(cboSupplier.ListIndex) = 15) Then
chkPreOrder.Visible = True
lblDelivery.Visible = True
txtDelivery.Visible = True
End If
If cboSupplier.ItemData(cboSupplier.ListIndex) = 18 Then
chkPreOrder.Visible = True
lblDelivery.Visible = True
txtDelivery.Visible = True
End If
End Sub
Private Sub cboSupplier_Click()
If cboSupplier.ListIndex = -1 Then
Exit Sub
End If
If gstrFLAG = "P" And (cboSupplier.ItemData(cboSupplier.ListIndex) = 16 Or cboSupplier.ItemData(cboSupplier.ListIndex) = 15) Then
chkPreOrder.Visible = True
lblDelivery.Visible = True
txtDelivery.Visible = True
Else
chkPreOrder.Visible = False
lblDelivery.Visible = False
txtDelivery.Visible = False
chkPreOrder = vbUnchecked
txtDelivery = ""
End If
' If cboSupplier.ItemData(cboSupplier.ListIndex) = 18 Then
' chkPreOrder.Visible = True
' lblDelivery.Visible = True
' txtDelivery.Visible = True
' Else
' chkPreOrder.Visible = False
' lblDelivery.Visible = False
' txtDelivery.Visible = False
' chkPreOrder = vbUnchecked
' txtDelivery = ""
' End If
End Sub
Private Sub cboSupplier_LostFocus()
If cboSupplier.ListIndex = -1 Then
Exit Sub
End If
If gstrFLAG = "P" And (cboSupplier.ItemData(cboSupplier.ListIndex) = 16 Or cboSupplier.ItemData(cboSupplier.ListIndex) = 15) Then
chkPreOrder.Visible = True
lblDelivery.Visible = True
txtDelivery.Visible = True
Else
chkPreOrder.Visible = False
lblDelivery.Visible = False
txtDelivery.Visible = False
chkPreOrder = vbUnchecked
txtDelivery = ""
End If
End Sub
Private Sub chkPreOrder_Click()
If chkPreOrder = vbChecked Then
lblDelivery.Visible = False
txtDelivery.Visible = False
End If
End Sub
Private Sub chkPreOrder_LostFocus()
If chkPreOrder = vbChecked Then
lblDelivery.Visible = False
txtDelivery.Visible = False
End If
End Sub
Private Sub cmdCancel_Click()
gboolPRINT = False
Unload Me
End Sub
Private Sub cmdPrint_Click()
On Error GoTo Error_EH
If Not IsDate(txtOrderDate) Then
MsgBox "The Date You Entered is not Valid - ReEnter"
txtOrderDate.SetFocus
Exit Sub
End If
Call FormSave
If cboSupplier.ListIndex <> -1 Then
If gstrFLAG = "P" And (cboSupplier.ItemData(cboSupplier.ListIndex) = 16 Or cboSupplier.ItemData(cboSupplier.ListIndex) = 15) Then
' If gintCOCODE = 0 Then
Call FoamPrint
' ElseIf gintCOCODE = 1 Then
' Call FoamPrint
' End If
' moRS!y_flg = "P"
' moRS.Update
gboolPRINT = False
Unload Me
Exit Sub
End If
If cboSupplier.ItemData(cboSupplier.ListIndex) = 18 Or cboSupplier.ItemData(cboSupplier.ListIndex) = 17 Then
Call YardPrint
' moRS!y_flg = "P"
' moRS.Update
gboolPRINT = False
Unload Me
Exit Sub
End If
End If
Unload Me
Exit Sub
Error_EH:
gstrMODULE = gstrMODULE & " Form Print - Module cmdPrint"
Call ErrorHandler2
gstrMODULE = ""
' cmdExit.Enabled = True
Exit Sub
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub
Private Sub Form_Load()
If gstrFLAG = "A" Then
lblTitle.Caption = "SAND ORDER"
ElseIf gstrFLAG = "T" Then
lblTitle.Caption = "TEXTURE ORDER"
ElseIf gstrFLAG = "S" Then
lblTitle.Caption = "SCRATCH ORDER"
ElseIf gstrFLAG = "B" Then
lblTitle.Caption = "BROWN ORDER"
ElseIf gstrFLAG = "P" Then
lblTitle.Caption = "MATERIALS PREORDER"
ElseIf gstrFLAG = "V" Then
lblTitle.Caption = "STONE VENEER ORDER"
ElseIf gstrFLAG = "R" Then
lblTitle.Caption = "SPECIAL PURCHASE ORDER"
ElseIf gstrFLAG = "W" Then
lblTitle.Caption = "WRAP ORDER"
ElseIf gstrFLAG = "E" Then
lblTitle.Caption = "SYNTHETIC ORDER"
ElseIf gstrFLAG = "Z" Then
lblTitle.Caption = "PRE-CAST ORDER"
End If
txtCopy = gintCOPY
Call SupplierLoad
If gstrPO <> "L" Then 'Need to decide if this needs to address W also
cboSupplier.Visible = False
lblSupplier.Visible = False
lblCopy.Visible = True
txtCopy.Visible = True
End If
End Sub
Private Sub FormSave()
Dim strSQL As String, mdblORDAMT As Double, strSELECT As String
Dim oRS As Recordset, oRSS As Recordset
Dim strPRICE As String, strDate As String
On Error GoTo Error_EH
gstrPONUM = ""
If txtMFlag = "Z" Then
strPRICE = "SELECT lot_id, Inv_no, Price from tblLotMatrl WHERE lot_id = " & gintLOTID & " and d_flag = 'Y' and M_Type = '" & Str2Field(txtMFlag) & "'"
Else
strPRICE = "SELECT lot_id, Inv_no, Price from tblLotMatrl WHERE lot_id = " & gintLOTID & " and d_flag = 'S' and M_Type = '" & Str2Field(txtMFlag) & "'"
End If
Set oRSS = New Recordset
oRSS.Open strPRICE, goConn, adOpenKeyset, adLockOptimistic
If Not oRSS.EOF Then
If Not cboSupplier.ListIndex = -1 Then
strSQL = "SELECT inv_no, price, sup_no FROM tblINVPrice WHERE Sup_no = " & cboSupplier.ItemData(cboSupplier.ListIndex)
Set oRS = New Recordset
oRS.Open strSQL, goConn, adOpenKeyset, adLockOptimistic
If Not oRS.EOF Then
Do Until oRSS.EOF
strSELECT = "inv_no = " & Field2Integer(oRSS!inv_no)
oRS.MoveFirst
oRS.Find strSELECT
If Not oRS.EOF Then
oRSS!price = Str2Field(oRS!price)
oRSS.Update
End If
oRSS.MoveNext
Loop
End If
oRS.Close
End If
End If
oRSS.Close
strSELECT = "SELECT SUM(qty*price) as SUMORDER FROM tblLotMatrl WHERE lot_id = " & gintLOTID & " and d_flag = 'S' and M_Type = '" & Str2Field(txtMFlag) & "'"
Set oRS = New Recordset
oRS.Open strSELECT, goConn, adOpenForwardOnly, adLockReadOnly
mdblORDAMT = Field2Str2(oRS!sumorder)
strSQL = "SELECT * FROM tblOrders WHERE lot_id = 1"
Set moRSOrders = New Recordset
moRSOrders.Open strSQL, goConn, adOpenKeyset, adLockOptimistic
moRSOrders.AddNew
moRSOrders!Lot_ID = gintLOTID
If gstrPO = "L" Then
moRSOrders!supplier = Str2Field(cboSupplier.List(cboSupplier.ListIndex))
ElseIf gstrPO = "W" Then
moRSOrders!supplier = "SUPERWALL INC."
Else
moRSOrders!supplier = Field2Str(txtSupplier)
End If
moRSOrders!order_date = Str2Field(txtOrderDate)
If moRSOrders!PrintDate = "01/01/2000" Or IsNull(moRSOrders!PrintDate) Then
strDate = Date
moRSOrders!PrintDate = Date
End If
If gstrFLAG = "L" Then
moRSOrders!Print = vbChecked
End If
moRSOrders!M_Type = gstrFLAG
If gstrFLAG = "Z" Then
moRSOrders!d_flag = "Y"
Else
moRSOrders!d_flag = Str2Field(txtDFlag)
End If
moRSOrders!PO_Num = Str2Field(txtPONum)
moRSOrders!ponum = Str2Field(txtPO)
moRSOrders!orderamt = Format(Round(mdblORDAMT, 2), "#,#.00")
moRSOrders!notes = Str2Field(txtNotes)
moRSOrders!percentage = gintPERCENT
moRSOrders!jobcost = Field2Str(txtJobCost)
If chkPreOrder Then
moRSOrders!preorder = vbChecked
moRSOrders!foam = vbChecked
End If
If IsDate(txtDelivery) Then
moRSOrders!cut_date = Str2Field(txtDelivery)
End If
moRSOrders.Update
gstrPONUM = Str2Field(txtPONum)
strSELECT = "SELECT MAX(Order_id) as MAXORDER FROM tblOrders" ' WHERE lot_id = " & gintLOTID & " and d_flag = 'S' and M_Type = '" & Str2Field(txtMFlag) & "'"
Set oRS = New Recordset
oRS.Open strSELECT, goConn, adOpenForwardOnly, adLockReadOnly
glngORDERID = Field2Str2(oRS!MAXOrder)
Exit Sub
Error_EH:
Call ErrorHandler(moRSOrders.ActiveConnection)
Exit Sub
End Sub
Private Sub picFoam_Change()
mboolJPG = True
End Sub
Private Sub txtCopy_GotFocus()
Call FieldSelect(txtCopy)
End Sub
Private Sub txtCopy_LostFocus()
gintCOPY = Field2Integer(txtCopy)
End Sub
Private Sub txtDelivery_GotFocus()
Call FieldSelect(txtDelivery)
End Sub
Private Sub txtDelivery_LostFocus()
If IsDate(txtDelivery) Then
Exit Sub
End If
If Len(txtDelivery) > 0 Then
txtDelivery = Format(txtDelivery, "00/##/####")
If Not IsDate(txtDelivery) Then
MsgBox "The Date You Entered is not Valid - ReEnter"
txtDelivery.SetFocus
ElseIf CDate(txtDelivery) < Date Then
MsgBox "The Date You Entered is Earlier Than Today - ReEnter"
txtDelivery.SetFocus
End If
End If
End Sub
Private Sub txtNotes_LostFocus()
txtNotes = UCase(txtNotes)
End Sub
Private Sub txtOrderDate_GotFocus()
Call FieldSelect(txtOrderDate)
End Sub
Private Sub txtOrderDate_LostFocus()
If IsDate(txtOrderDate) Then
Exit Sub
End If
If Len(txtOrderDate) > 0 Then
txtOrderDate = Format(txtOrderDate, "00/##/####")
If Not IsDate(txtOrderDate) Then
MsgBox "The Date You Entered is not Valid - ReEnter"
txtOrderDate.SetFocus
ElseIf CDate(txtOrderDate) < Date Then
MsgBox "The Date You Entered is Earlier Than Today - ReEnter"
txtOrderDate.SetFocus
End If
End If
End Sub
Private Sub FoamPrint()
Dim strSQL As String
Dim strSELECT As String, oRSS As Recordset
On Error GoTo Error_EH:
If gintCOCODE = 0 Then
If txtPO = 0 Then
crPrint.ReportFileName = App.Path & "\FoamPreOrder.rpt"
strSQL = "{tblLOTMATRL.LOT_ID} = " & gintLOTID
Else
crPrint.ReportFileName = App.Path & "\FoamPreOrder2.rpt"
strSQL = "{tblPOrder.PONum} = " & CInt(txtPO)
End If
ElseIf gintCOCODE = 1 Then
If txtPO = 0 Then
crPrint.ReportFileName = App.Path & "\FoamPreOrderM.rpt"
strSQL = "{tblLOTMATRL.LOT_ID} = " & gintLOTID
Else
crPrint.ReportFileName = App.Path & "\FoamPreOrder2M.rpt"
strSQL = "{tblPOrder.PONum} = " & CInt(txtPO)
End If
End If
crPrint.ReplaceSelectionFormula (strSQL)
crPrint.CopiesToPrinter = 1
' crPrint.Destination = crptToWindow
crPrint.Destination = crptToPrinter
If chkPreOrder Then
crPrint.Formulas(0) = "datestring = 'DATE TO CUT: '"
crPrint.Formulas(1) = "datevalue = 'PREORDER'"
crPrint.Formulas(2) = "PO = '" & gstrPONUM & "'"
crPrint.Formulas(3) = "title = 'FOAM CUT SHEET'"
Else
crPrint.Formulas(0) = "datestring = 'DATE TO CUT: '"
crPrint.Formulas(1) = "datevalue = '" & txtDelivery & "'"
crPrint.Formulas(2) = "PO = '" & gstrPONUM & "'"
crPrint.Formulas(3) = "title = 'FOAM CUT SHEET'"
End If
crPrint.Action = 1
crPrint.Reset
If gintCOCODE = 0 Then
If txtPO = 0 Then
crPrint.ReportFileName = App.Path & "\FoamPreOrder.rpt"
strSQL = "{tblLOTMATRL.LOT_ID} = " & gintLOTID
Else
crPrint.ReportFileName = App.Path & "\FoamPreOrder2.rpt"
strSQL = "{tblPOrder.PONum} = " & CInt(txtPO)
End If
ElseIf gintCOCODE = 1 Then
If txtPO = 0 Then
crPrint.ReportFileName = App.Path & "\FoamPreOrderM.rpt"
strSQL = "{tblLOTMATRL.LOT_ID} = " & gintLOTID
Else
crPrint.ReportFileName = App.Path & "\FoamPreOrder2M.rpt"
strSQL = "{tblPOrder.PONum} = " & CInt(txtPO)
End If
End If
' If txtPO = 0 Then
' crPrint.ReportFileName = App.Path & "\FoamPreOrder.rpt"
' Else
' crPrint.ReportFileName = App.Path & "\FoamPreOrder2.rpt"
' End If
' crPrint.ReportFileName = App.Path & "\FoamPreOrder.rpt"
crPrint.ReplaceSelectionFormula (strSQL)
crPrint.CopiesToPrinter = 1
' crPrint.Destination = crptToWindow
crPrint.Destination = crptToPrinter
crPrint.Formulas(0) = "datestring = 'DATE TO DELIVER: '"
crPrint.Formulas(1) = "datevalue = ' '"
crPrint.Formulas(2) = "PO = '" & gstrPONUM & "'"
crPrint.Formulas(3) = "title = 'FOAM DELIVERY SHEET'"
crPrint.Action = 1
' PrintJPG
If txtPO <> 0 Then
strSELECT = "SELECT * FROM tblPOrder WHERE PONum = " & CInt(txtPO) ' & " and p_flg <> 'P'"
Set oRSS = New Recordset
oRSS.Open strSELECT, goConn, adOpenKeyset, adLockOptimistic
oRSS!p_flg = "P"
oRSS.Update
End If
Exit Sub
Error_EH:
gstrMODULE = "Form Print - Module FoamPrint"
Call ErrorHandler2
gstrMODULE = ""
Exit Sub
End Sub
Private Sub YardPrint()
Dim strSQL As String, mdblORDAMT As Double, strSELECT As String
Dim oRS As Recordset, oRSS As Recordset
Dim strPRICE As String
Dim strYARD As String
On Error GoTo Error_EH:
strSELECT = "SELECT * FROM tblYardOrder WHERE Lot_ID = 1"
Set oRS = New Recordset
oRS.Open strSELECT, goConn, adOpenKeyset, adLockOptimistic
strYARD = "SELECT * FROM tblPOrdMat WHERE ponum = " & CInt(txtPO)
Set oRSS = New Recordset
oRSS.Open strYARD, goConn, adOpenForwardOnly, adLockReadOnly
Do Until oRSS.EOF
oRS.AddNew
oRS!Lot_ID = gintLOTID
oRS!inv_no = Field2Str(oRSS!inv_no)
oRS!Desc = Field2Str(oRSS!Desc)
oRS!qty = Field2Str2(oRSS!qty)
oRS!qtyIssue = Field2Str2(oRSS!qty)
oRS!price = Field2Str2(oRSS!price)
oRS!PO_Num = gstrPONUM
oRS!createuser = gstrLOGIN
oRS!UpdateUser = gstrLOGIN
oRS.Update
oRSS.MoveNext
Loop
oRS.Close
oRSS.Close
If gintCOCODE = 0 Then
crPrint.ReportFileName = App.Path & "\POYard.rpt"
ElseIf gintCOCODE = 1 Then
crPrint.ReportFileName = App.Path & "\POYardM.rpt"
End If
strSQL = "{tblPOrder.PONum} = " & CInt(txtPO)
crPrint.ReplaceSelectionFormula (strSQL)
crPrint.CopiesToPrinter = 1
' crPrint.Destination = crptToWindow
crPrint.Destination = crptToPrinter
crPrint.Action = 1
crPrint.Reset
If txtPO <> 0 Then
strSELECT = "SELECT * FROM tblPOrder WHERE PONum = " & CInt(txtPO) ' & " and p_flg <> 'P'"
Set oRSS = New Recordset
oRSS.Open strSELECT, goConn, adOpenKeyset, adLockOptimistic
oRSS!p_flg = "P"
oRSS.Update
End If
Exit Sub
Error_EH:
gstrMODULE = "Form Print - Module YardPrint"
Call ErrorHandler2
gstrMODULE = ""
Exit Sub
End Sub
Private Sub PrintJPG()
Dim strSQL As String, oRS As Recordset, strFile As String
' On Error GoTo Error_EH:
' mboolJPG = False
' If txtPO = 0 Then
' strSQL = "SELECT Inv_No, Lot_ID, d_flag, m_type FROM tblLotMatrl WHERE D_Flag = 'Y' and M_Type = 'P' and Lot_Id = " & gintLOTID
' Set oRS = New Recordset
' oRS.Open strSQL, goConn, adOpenForwardOnly, adLockReadOnly
' Else
' strSQL = "SELECT Inv_No, d_flag, m_type, PONum FROM tblPOrdMat where D_Flag = 'Y' and M_Type = 'P' and PONum = " & Field2Integer(txtPO)
' Set oRS = New Recordset
' oRS.Open strSQL, goConn, adOpenForwardOnly, adLockReadOnly
' End If
' Do Until oRS.EOF
' strFile = "\pictures\" & Field2Str(oRS!inv_no) & ".JPG"
' If Not mboolJPG Then
' MsgBox "No Foam Diagram File Found", vbOKOnly, "No File"
' Exit Sub
' End If
' picFoam.Picture = LoadPicture(App.Path & strFile)
' txtHeader = "FOAM SHAPE " & Field2Str(oRS!inv_no)
' epFoam.Margin(epTop) = 1.5
' Set epFoam.HeaderText = txtHeader
' Set epFoam.PictureSource = picFoam
' epFoam.epPrint
' oRS.MoveNext
' Loop
' Exit Sub
'Error_EH:
' gstrMODULE = "Form Print - Module PrintJPG"
' Call ErrorHandler2
' gstrMODULE = ""
' Exit Sub
End Sub
Reference in New Issue View Git Blame Copy Permalink