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/Source/History/frmMain.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

1027 lines
30 KiB
Plaintext
Raw Permalink Blame History

VERSION 5.00
Object = "{09E60688-07A2-11CF-BD27-10005AE6AFFA}#1.0#0"; "rrw32.ocx"
Begin VB.Form frmMain
Caption = "Main Menu"
ClientHeight = 8265
ClientLeft = 165
ClientTop = 735
ClientWidth = 11880
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
ScaleHeight = 8265
ScaleWidth = 11880
StartUpPosition = 3 'Windows Default
Begin RrocxLib.RRReport rrHistory
Left = 8610
Top = -30
_Version = 65536
_ExtentX = 847
_ExtentY = 847
_StockProps = 0
WindowControlBox= 0 'False
WindowBorderStyle= 0
WindowTitle = ""
Destination = 1
PrintFileName = ""
ReportName = "C:\CMSWIN70\SWJData\Oe00005xc.rrw"
ReportLibrary = ""
MemoFileName = "?"
Printer = ""
Port = ""
MasterTable = "C:\CMSWIN70\SWJData\Swjpshis.dbf"
Filter = ""
RelatedTables = ""
Query = 2
WindowParentHandle= 0
DataDirectory = ""
ReportDirectory = ""
ImageDirectory = ""
LastErrorCode = 0
LastErrorString = ""
LastErrorPage = 0
SuppressTitle = 0 'False
Parameters = ""
DBContainer = ""
SortFields = ""
GroupFields = ""
ReportSortFields= "+PSHID->PSHDINVNO;+PSHIS->PSHIREC;+PSHID->Group2"
ReportGroupFields= "PSHIS->PSHIREC;PSHID->Group2"
ControlFile = ""
SuitableGroupFields= $"frmMain.frx":08CA
SuitableSortFields= $"frmMain.frx":1D2B
ReportsRTString = "OESHI=Swjoeshi.dbf,swjOESHI.MDX,OESHCODE;PSHID=Swjpshid.dbf,SWJPSHID.MDX,PSHDREC;"
RelatedTablesString= ""
ParametersString= ""
ReportParametersString= "InvNo=;RI_FIELD1=;RI_FIELD2=;RI_FIELD3=;RI_FIELD4=;RI_FLAG2=;RI_FIELD5=;RI_FIELD6=;RI_FLAG6=;RI_FLAG7=;"
StatusFileName = ""
MasterIndex = ""
Scope = 2
LowScope = ""
HighScope = ""
IndexExtension = 0
PageSize = ""
End
Begin VB.ComboBox cboARCode
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 11040
Style = 2 'Dropdown List
TabIndex = 6
TabStop = 0 'False
Top = 105
Width = 735
End
Begin VB.ListBox lstDetail
Height = 3960
Left = 75
Sorted = -1 'True
TabIndex = 4
TabStop = 0 'False
Top = 4200
Width = 11775
End
Begin VB.ListBox lstInvoice
Height = 3375
Left = 5820
Sorted = -1 'True
TabIndex = 3
TabStop = 0 'False
Top = 480
Width = 5985
End
Begin VB.ListBox lstCustomer
Height = 3375
Left = 60
Sorted = -1 'True
TabIndex = 0
Top = 480
Width = 5655
End
Begin VB.Label lblMessage
Alignment = 2 'Center
BackColor = &H0080FFFF&
Caption = "Creating List - Please Wait!"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 300
Left = 1740
TabIndex = 8
Top = 150
Visible = 0 'False
Width = 3735
End
Begin VB.Label lblARCode
Alignment = 1 'Right Justify
Caption = "AR Code:"
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 255
Left = 9720
TabIndex = 7
Top = 210
Width = 1260
End
Begin VB.Label lblDetail
AutoSize = -1 'True
Caption = "Invoice Detail"
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 120
TabIndex = 5
Top = 3960
Width = 1440
End
Begin VB.Label lblInvList
AutoSize = -1 'True
Caption = "Customer Invoice List"
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 5820
TabIndex = 2
Top = 225
Width = 2220
End
Begin VB.Label lblCustomer
AutoSize = -1 'True
Caption = "Customer List"
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 60
TabIndex = 1
Top = 225
Width = 1410
End
Begin VB.Menu mnuPrint
Caption = "&Print Form"
End
Begin VB.Menu mnuInvoice
Caption = "Print I&nvoice"
End
Begin VB.Menu mnuSwitch
Caption = "&Inventory"
End
Begin VB.Menu mnuARCode
Caption = "AR &Code"
End
Begin VB.Menu mnuExit
Caption = "E&xit"
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mstrCUSTOMER As String * 20, mstrINVOICE As String * 15
Dim mlngINVOICE As Long, mstrCUSTOMER2 As String * 20
Dim mintPOS As Integer
Dim mstrCUSTNO As String, mstrCUSTNAME As String
Dim moRSINVOICE As ADODB.Recordset
Dim moRSDETAIL As ADODB.Recordset
Private Sub cboARCode_Click()
If cboARCode.ListIndex = -1 Then
Exit Sub
End If
Call ButtonReset
lstInvoice.Clear
lstDetail.Clear
Me.MousePointer = vbHourglass
gstrARCODE = cboARCode.Text
Call CustomerLoad
Me.MousePointer = vbDefault
Call ButtonReset
cboARCode.Enabled = False
End Sub
Private Sub cmdExit_Click()
Unload Me
End Sub
Private Sub CustomerFind()
Dim oSTATUS As Long
Dim strSQL As String, strSQLL As String
Dim strLINE As String, strCode As String, strCompany As String
Dim strNAME As String, strCUST As String, lngRECORD As Long
Dim lngNAME As Long
'TAG4 pointers
Dim lngCustTag As Long
On Error GoTo Error_EH
strSQL = gstrCOMPANY & "ARMSD"
db2 = d4open(cb, fPath + strSQL)
lngCustTag = d4tag(db2, "AR_CUST")
' codeTag = d4tag(db, "CODE_TAG")
rc2 = d4seek(db2, mstrCUSTOMER2)
' If d4top(db2) = r4success Then
If rc2 = r4success Then
oSTATUS = d4deleted(db2)
If oSTATUS = 0 Then
lngRECORD = d4field(db2, "AR_CUST")
mstrCUSTNO = f4str(lngRECORD)
lngNAME = d4field(db2, "AR_NAME")
mstrCUSTNAME = f4str(lngNAME)
End If
End If
rc = d4close(db2)
Exit Sub
Error_EH:
gstrMODULE = "Form Main - Module CustomerFind"
Call ErrorHandler2
gstrMODULE = ""
Exit Sub
End Sub
Private Sub CustomerLoad()
Dim oSTATUS As Long
Dim strSQL As String, strSQLL As String
Dim strLINE As String, strCode As String, strCompany As String
Dim strNAME As String, strCUST As String
Dim lngRET As Long, aTabs(2) As Long, lngRECORD As Long
Dim lngNAME As Long, lngCUST As Long
'TAG4 pointers
Dim lngCustTag As Long
On Error GoTo Error_EH
aTabs(0) = 100
aTabs(1) = 120
aTabs(2) = 200
strSQL = gstrCOMPANY & "ARMSD"
db = d4open(cb, fPath + strSQL)
lngRET = SendMessage(lstCustomer.hWnd, LB_SETTABSTOPS, 3, aTabs(0))
strSQLL = cboARCode.Text
rc = d4top(db)
lstCustomer.Clear
If d4top(db) = r4success Then
Do
oSTATUS = d4deleted(db)
If oSTATUS = 0 Then
' lngRECORD = d4field(db, "AR_CODE")
' strCode = f4str(lngRECORD)
' If strCode = strSQLL Then
With lstCustomer
lngNAME = d4field(db, "AR_NAME")
lngCUST = d4field(db, "AR_CUST")
strNAME = f4str(lngNAME)
strCUST = f4str(lngCUST)
.AddItem RTrim$(strCUST) & vbTab & Trim$(strNAME)
End With
' End If
End If
rc = d4skip(db, 1)
Loop While rc = r4success
End If
rc = d4close(db)
If lstCustomer.ListCount Then
lstCustomer.ListIndex = 0
Else
MsgBox "No Customers Were Found For That AR Code", vbInformation + vbOKOnly, "No Customers"
End If
Exit Sub
Error_EH:
gstrMODULE = "Form Main - Module CustomerLoad"
Call ErrorHandler2
gstrMODULE = ""
Exit Sub
End Sub
Private Sub InventoryLoad()
Dim oSTATUS As Long
Dim strSQL As String, strSQLL As String
Dim strLINE As String, strCode As String, strCompany As String
Dim strNAME As String, strCUST As String
Dim lngRET As Long, aTabs(2) As Long, lngRECORD As Long
Dim lngNAME As Long, lngCUST As Long
'TAG4 pointers
Dim lngCustTag As Long
On Error GoTo Error_EH
aTabs(0) = 100
aTabs(1) = 120
aTabs(2) = 200
strSQL = gstrCOMPANY & "INMAS"
db = d4open(cb, fPath + strSQL)
lngRET = SendMessage(lstCustomer.hWnd, LB_SETTABSTOPS, 3, aTabs(0))
strSQLL = cboARCode.Text
rc = d4top(db)
lstCustomer.Clear
If d4top(db) = r4success Then
Do
oSTATUS = d4deleted(db)
If oSTATUS = 0 Then
' lngRECORD = d4field(db, "AR_CODE")
' strCode = f4str(lngRECORD)
' If strCode = strSQLL Then
With lstCustomer
lngNAME = d4field(db, "IN_STOCK")
lngCUST = d4field(db, "IN_DES")
strNAME = f4str(lngNAME)
strCUST = f4str(lngCUST)
.AddItem RTrim$(strNAME) & vbTab & Trim$(strCUST)
End With
' End If
End If
rc = d4skip(db, 1)
Loop While rc = r4success
End If
rc = d4close(db)
If lstCustomer.ListCount Then
lstCustomer.ListIndex = 0
Else
MsgBox "No Inventory Items Were Found For That AR Code", vbInformation + vbOKOnly, "No Customers"
End If
Exit Sub
Error_EH:
gstrMODULE = "Form Main - Module CustomerLoad"
Call ErrorHandler2
gstrMODULE = ""
Exit Sub
End Sub
Private Sub cmdSwitch_Click()
lblMessage.Visible = True
If mnuSwitch.caption = "&Inventory" Then
' lblMessage.Visible = True
Call ButtonReset
DoEvents
lstCustomer.Clear
lstDetail.Clear
lstInvoice.Clear
cboARCode.ListIndex = -1
lstInvoice.Visible = False
lblInvList.Visible = False
cboARCode.Visible = False
lblARCode.Visible = False
' lstDetail.Sorted = False
lblCustomer.caption = "Inventory Items"
lblDetail.caption = "Item Sales History"
mnuSwitch.caption = "&Invoices"
gboolTYPE = False
Call InventoryLoad
Call ButtonReset
lstCustomer.SetFocus
lblMessage.Visible = False
Exit Sub
End If
If mnuSwitch.caption = "&Invoices" Then
Call ButtonReset
DoEvents
' lblMessage.Visible = True
lstCustomer.Clear
lstDetail.Clear
lstInvoice.Clear
cboARCode.ListIndex = 0
lstInvoice.Visible = True
lblInvList.Visible = True
cboARCode.Visible = True
lblARCode.Visible = True
' lstDetail.Sorted = True
lblCustomer.caption = "Customer List"
lblDetail.caption = "Invoice Detail"
mnuSwitch.caption = "&Inventory"
gboolTYPE = True
Call ButtonReset
lblMessage.Visible = False
Exit Sub
End If
End Sub
Private Sub Form_Load()
Dim oRS As Recordset, strSQL As String, strFILE As String
' gstrCOMPANY = "LVT"
gstrCOMPANY = "SWJ"
' gstrCOMPANY = "JHD"
' gstrCOMPANY = "DMO"
' gstrCOMPANY = "PSI"
' gstrCOMPANY = "ACE"
' gstrCOMPANY = "201"
' gstrCOMPANY = "202"
' gstrCOMPANY = "200"
' gstrCOMPANY = "RMX"
' gstrCOMPANY = "TSS"
gboolTYPE = True
fPath = App.Path + "\"
Call ARCodeLoad
End Sub
Private Sub ARCodeLoad()
Dim ARCode As Long, oSTATUS As Long
Dim strSQL As String, strFILE As String
strFILE = gstrCOMPANY & "ARCOD.DBF"
db = d4open(cb, fPath + strFILE)
cboARCode.Clear
If d4top(db) = r4success Then
Do
oSTATUS = d4deleted(db)
If oSTATUS = 0 Then
With cboARCode
ARCode = d4field(db, "ARCOCODE")
.AddItem f4str(ARCode)
End With
End If
rc = d4skip(db, 1)
Loop While rc = r4success
End If
rc = d4close(db)
cboARCode.ListIndex = 0
End Sub
Private Sub InvoiceLoad()
Dim strSQL As String, oSTATUS As Long
Dim strLINE As String
Dim lngRET As Long, aTabs(4) As Long, strAmount As String * 12
'FIELD4 pointers
Dim lngNAME As Long, lngCUST As Long, lngINVTOT As Long
Dim lngINVNO As Long, lngINVDATE As Long, lngINVPOA As Long
Dim lngRECORD As Long
'TAG4 pointers
Dim lngCustTag As Long
'INDEX4 pointers
Dim ind1 As Long
'Field value holders
Dim dblINVTOT As Double, dblINVPOA As Double, dblAMOUNT As Double
Dim strNAME As String, strCUST As String, lngPSHIREC As Long
Dim strINVNO As String, strINVDATE As String, strNEWDATE As String
Dim lngSPC As Long, lngTERMS As Long
Dim strSPC As String, strTERMS As String
'Others
Dim fldArray As Long, tagArray As Long
Dim FileName As String, db2 As Long
Dim save1 As Integer, save2 As Integer, save3 As Integer, save4 As Integer, save5 As Integer
Dim rc1 As Integer, rc2 As Integer
On Error GoTo Error_EH
cb = code4init
aTabs(0) = 70
aTabs(1) = 130
aTabs(2) = 190
aTabs(3) = 230
lngRET = SendMessage(lstInvoice.hWnd, LB_SETTABSTOPS, 5, aTabs(0))
strSQL = gstrCOMPANY & "PSHIS"
db = d4open(cb, fPath + strSQL)
lngCustTag = d4tag(db, "PSHINUM")
Call d4tagSelect(db, lngCustTag)
rc = d4seek(db, mstrCUSTOMER)
lstInvoice.Clear
Do Until rc <> r4success
oSTATUS = d4deleted(db)
If oSTATUS = 0 Then
With lstInvoice
lngINVTOT = d4field(db, "PSHITOT")
lngINVPOA = d4field(db, "PSHIPOA")
lngINVDATE = d4field(db, "PSHIDATE")
lngINVNO = d4field(db, "PSHIINVNO")
lngRECORD = d4field(db, "PSHIREC")
lngSPC = d4field(db, "PSHISPC")
lngTERMS = d4field(db, "PSHITERM")
dblINVTOT = f4double(lngINVTOT)
dblINVPOA = f4double(lngINVPOA)
strINVDATE = f4str(lngINVDATE)
Call date4format(strINVDATE, strNEWDATE, "MM/DD/CCYY")
strINVNO = f4str(lngINVNO)
lngPSHIREC = f4long(lngRECORD)
strSPC = f4str(lngSPC)
strTERMS = f4str(lngTERMS)
If dblINVTOT > 0 Then
RSet strAmount = FormatCurrency(dblINVTOT, 2)
ElseIf dblINVPOA > 0 Then
RSet strAmount = FormatCurrency((dblINVPOA * -1), 2)
Else
RSet strAmount = FormatNumber(0, 2)
End If
strLINE = strINVNO & vbTab & strNEWDATE & vbTab & strAmount & vbTab & strSPC & vbTab & strTERMS
.AddItem strLINE
.ItemData(.NewIndex) = lngPSHIREC
End With
End If
rc = d4seekNext(db, mstrCUSTOMER)
Loop
If lstInvoice.ListCount Then
lstInvoice.ListIndex = 0
Else
MsgBox "No Invoice Information Found For The Selected Customer", vbOKOnly, "No Invoices"
End If
rc = d4close(db)
Exit Sub
Error_EH:
gstrMODULE = "Form Main - Module CustomerLoad"
Call ErrorHandler2
gstrMODULE = ""
Exit Sub
End Sub
Private Sub HistoryLoad()
Dim strSQL As String, oSTATUS As Long, strINDEX As String
Dim strLINE As String, strLINE2 As String
Dim lngRET As Long, aTabs(7) As Long, strAmount As String * 12
'FIELD4 pointers
Dim lngNAME As Long, lngCUST As Long, lngINVTOT As Long
Dim lngINVNO As Long, lngINVDATE As Long, lngTYPE As Long
Dim lngRECORD As Long, lngQTY As Long, lngPRICE As Long
Dim lngDOC As Long, lngSTOCK As Long
'TAG4 pointers
Dim lngCustTag As Long
'INDEX4 pointers
Dim ind1 As Long
'Field value holders
Dim dblINVTOT As Double, dblTYPE As Double, dblAMOUNT As Double
Dim strNAME As String, strCUST As String, lngPSHIREC As Long
Dim strINVNO As String, strINVDATE As String, strNEWDATE As String
Dim dblQTY As Double, dblPRICE As Double, strDOC As String, strSTOCK As String
Dim strTYPE As String, lngCOST As Long, dblCOST As Double, strCOST As String * 12
'Others
Dim fldArray As Long, tagArray As Long
Dim FileName As String, db2 As Long
Dim save1 As Integer, save2 As Integer, save3 As Integer, save4 As Integer, save5 As Integer
Dim rc1 As Integer, rc2 As Integer
Dim indexInfo() As TAG4INFO
On Error GoTo Error_EH
cb = code4init
aTabs(0) = 50
aTabs(1) = 200
aTabs(2) = 300
aTabs(3) = 330
aTabs(4) = 360
aTabs(5) = 380
aTabs(6) = 410
aTabs(7) = 450
lngRET = SendMessage(lstDetail.hWnd, LB_SETTABSTOPS, 8, aTabs(0))
strSQL = gstrCOMPANY & "INHIS"
' ReDim indexInfo(1) As TAG4INFO
' indexInfo(1).name = "INDESDATE"
' indexInfo(1).expression = "UPPER(INHISTOCK) + DTOS(INHIDATE)"
' indexInfo(1).descending = r4descending
db = d4open(cb, fPath + strSQL)
' strINDEX = fPath + "INHIX"
' ind1 = i4open(db, strINDEX) ', indexInfo())
' ind1 = i4create(db, strINDEX, indexInfo())
' rc = i4reindex(ind1)
' On Error GoTo Error_EH
' i4close (ind1)
lngCustTag = d4tag(db, "INHISTOCK")
' lngCustTag = i4tag(ind1, "INDESDATE")
Call d4tagSelect(db, ind1)
rc = d4seek(db, mstrCUSTOMER)
lstDetail.Clear
Do Until rc <> r4success
oSTATUS = d4deleted(db)
mstrCUSTOMER2 = ""
If oSTATUS = 0 Then
With lstDetail
lngNAME = d4field(db, "INHICV")
lngDOC = d4field(db, "INHIDOC")
lngINVDATE = d4field(db, "INHIDATE")
lngINVNO = d4field(db, "INHISOURCE")
lngRECORD = d4field(db, "INHIUNIQ")
lngTYPE = d4field(db, "INHITYPE")
lngPRICE = d4field(db, "INHIPRICE")
lngQTY = d4field(db, "INHIQTY")
lngCOST = d4field(db, "INHICOST")
strDOC = f4str(lngDOC)
strNAME = f4str(lngNAME)
If strNAME <> "" Then
If strNAME <> mstrCUSTNO Then
mstrCUSTNO = ""
mstrCUSTNAME = ""
mstrCUSTOMER2 = strNAME
Call CustomerFind
End If
Else
mstrCUSTNO = ""
mstrCUSTNAME = ""
End If
strINVDATE = f4str(lngINVDATE)
Call date4format(strINVDATE, strNEWDATE, "CCYY/MM/DD")
dblPRICE = f4double(lngPRICE)
RSet strAmount = FormatCurrency(dblPRICE, 2)
strINVNO = f4str(lngINVNO)
lngPSHIREC = f4long(lngRECORD)
dblTYPE = f4double(lngTYPE)
dblQTY = f4double(lngQTY)
dblCOST = f4double(lngCOST)
If dblQTY > 0 Then
dblCOST = dblCOST / dblQTY
End If
RSet strCOST = FormatCurrency(dblCOST, 2)
If dblTYPE = 0 Then
strTYPE = "ADD"
ElseIf dblTYPE = 1 Then
strTYPE = "SUB"
Else
strTYPE = "TRANS"
End If
strLINE = strNEWDATE & vbTab & mstrCUSTNAME & vbTab & strDOC & vbTab & strTYPE & vbTab ' & strINVNO & vbTab & dblQTY & vbTab & strAmount & vbTab & strCOST
strLINE2 = strINVNO & vbTab & dblQTY & vbTab & strAmount & vbTab & strCOST
strLINE = strLINE & strLINE2
' strLINE = strNEWDATE & vbTab & mstrCUSTNAME & vbTab & strDOC & vbTab & strTYPE & vbTab & strINVNO & vbTab & dblQTY & vbTab & strAmount & vbTab & strCOST
' strLINE = strINVNO & vbTab & strNEWDATE & vbTab & strAmount
.AddItem strLINE
.ItemData(.NewIndex) = lngPSHIREC
End With
End If
rc = d4seekNext(db, mstrCUSTOMER)
Loop
If lstDetail.ListCount Then
lstDetail.ListIndex = 0
Else
MsgBox "No Inventory History Information Found For The Selected Stock Item", vbOKOnly, "No Invoices"
End If
rc = d4close(db)
Exit Sub
Error_EH:
gstrMODULE = "Form Main - Module HistoryLoad"
Call ErrorHandler2
gstrMODULE = ""
Exit Sub
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
rc = code4initUndo(cb)
End Sub
Private Sub lstCustomer_Click()
lstInvoice.Clear
lstDetail.Clear
End Sub
Private Sub DetailLoad()
'FIELD4 pointers
Dim lngTYPE As Long, lngDETAIL As Long
Dim lngSTOCK As Long, lngDESC As Long, lngEXTTOT As Long
Dim lngQTY As Long
Dim lngRECORD As Long
'TAG4 pointers
Dim lngInvTag As Long
'INDEX4 pointers
Dim ind1 As Long
'Field value holders
Dim intTYPE As Integer, intDETAIL As Integer, dblEXTTOT As Double
Dim strSTOCK As String, strDESC As String, lngPSHDREC As Long
Dim strQTY As String, strDETAIL As String
'Others
Dim strSQL As String, strFILE As String, oSTATUS As Long
Dim strLINE As String, strCode As String, strCompany As String
Dim lngRET As Long, aTabs(4) As Long, strAmount As String * 12
On Error GoTo Error_EH
aTabs(0) = 20
aTabs(1) = 40
aTabs(2) = 120
aTabs(3) = 400
aTabs(4) = 450
lngRET = SendMessage(lstDetail.hWnd, LB_SETTABSTOPS, 5, aTabs(0))
mintPOS = InStr(1, lstInvoice.Text, (Chr(9))) ',vbTextCompare)
mstrINVOICE = Left(lstInvoice.Text, (mintPOS - 1))
strSQL = gstrCOMPANY & "PSHID"
lstDetail.Clear
db = d4open(cb, fPath + strSQL)
lngInvTag = d4tag(db, "PSHDINVNO")
Call d4tagSelect(db, lngInvTag)
rc = d4seek(db, mstrINVOICE)
Do Until rc <> r4success
oSTATUS = d4deleted(db)
If oSTATUS = 0 Then
With lstDetail
lngTYPE = d4field(db, "PSHDLTYPE")
lngDETAIL = d4field(db, "PSHDDETAIL")
lngSTOCK = d4field(db, "PSHDSTK")
lngDESC = d4field(db, "PSHDDES")
lngEXTTOT = d4field(db, "PSHDEXT")
lngQTY = d4field(db, "PSHDQTY")
dblEXTTOT = f4double(lngEXTTOT)
intTYPE = f4int(lngTYPE)
intDETAIL = f4int(lngDETAIL)
strDETAIL = Format(intDETAIL, "000")
strSTOCK = f4str(lngSTOCK)
strQTY = f4str(lngQTY)
strDESC = f4str(lngDESC)
RSet strAmount = FormatCurrency(dblEXTTOT, 2)
strLINE = strDETAIL & vbTab & intTYPE & vbTab & strSTOCK
strLINE = strLINE & vbTab & strDESC & vbTab & strQTY & vbTab & strAmount
.AddItem strLINE
End With
End If
rc = d4seekNext(db, mstrINVOICE)
Loop
rc = d4close(db)
If lstDetail.ListCount = 0 Then
MsgBox "No Detail Information Found For The Selected Invoice - THIS MAY BE A PAYMENT", vbOKOnly, "No Invoice Detail"
End If
Exit Sub
Error_EH:
gstrMODULE = "Form Main - Module DetailLoad"
Call ErrorHandler2
gstrMODULE = ""
Exit Sub
End Sub
Private Sub lstCustomer_DblClick()
On Error GoTo Error_EH
Me.MousePointer = vbHourglass
Call ButtonReset
If gboolTYPE = True Then
If lstCustomer.ListIndex <> -1 Then
mintPOS = InStr(1, lstCustomer.Text, (Chr(9))) ',vbTextCompare)
mstrCUSTOMER = Left(lstCustomer.Text, (mintPOS - 1))
Call InvoiceLoad
lstCustomer.SetFocus
End If
ElseIf gboolTYPE = False Then
If lstCustomer.ListIndex <> -1 Then
mintPOS = InStr(1, lstCustomer.Text, (Chr(9))) ',vbTextCompare)
mstrCUSTOMER = Left(lstCustomer.Text, (mintPOS - 1))
Call HistoryLoad
lstCustomer.SetFocus
End If
End If
Call ButtonReset
Me.MousePointer = vbDefault
Exit Sub
Error_EH:
gstrMODULE = "Form Main - Module lstCustomer_DblClick"
Call ErrorHandler2
gstrMODULE = ""
Call ButtonReset
Me.MousePointer = vbDefault
Exit Sub
End Sub
Private Sub lstInvoice_Click()
On Error GoTo Error_EH
Me.MousePointer = vbHourglass
If gboolTYPE = True Then
lstDetail.Clear
DoEvents
Call DetailLoad
lstCustomer.SetFocus
End If
Me.MousePointer = vbDefault
Exit Sub
Error_EH:
gstrMODULE = "Form Main - Module lstInvoice_Click"
Call ErrorHandler2
gstrMODULE = ""
Me.MousePointer = vbDefault
Exit Sub
End Sub
Private Sub cmdPrint_Click()
Me.PrintForm
End Sub
Private Sub ARMasLoad()
Dim oRS As Recordset, strSQL As String, strFILE As String
Dim oRSS As Recordset, strSQL2 As String
On Error Resume Next
strFILE = gstrCOMPANY & "ARMSD.DBF"
strSQL = "SELECT * from " & strFILE
Set oRS = New Recordset
oRS.Open strSQL, goConn2, adOpenForwardOnly, adLockReadOnly
strSQL2 = "DELETE * FROM tblarMSD"
goConn.Execute strSQL2
strSQL2 = "SELECT * FROM tblARMSD"
Set oRSS = New Recordset
oRSS.Open strSQL2, goConn, adOpenDynamic, adLockOptimistic
Do Until oRS.EOF
With oRSS
oRSS.AddNew
oRSS!AR_CUST = Field2Str(oRS!AR_CUST)
oRSS!ar_code = Field2Str(oRS!ar_code)
oRSS!AR_TYPE = Field2Str(oRS!AR_TYPE)
oRSS!AR_NAME = Field2Str(oRS!AR_NAME)
oRSS!AR_TERMS = Field2Str(oRS!AR_TERMS)
oRSS!AR_MISC = Field2Str(oRS!AR_MISC)
oRSS.Update
oRS.MoveNext
End With
Loop
oRS.Close
oRSS.Close
On Error GoTo 0
Exit Sub
Error_EH:
gstrMODULE = "Form Main - Module ARMAS Load"
Call ErrorHandler2
gstrMODULE = ""
Exit Sub
End Sub
Private Sub ButtonReset()
' cmdExit.Enabled = Not cmdExit.Enabled
' cmdSwitch.Enabled = Not cmdSwitch.Enabled
' cmdPrint.Enabled = Not cmdPrint.Enabled
mnuExit.Enabled = Not mnuExit.Enabled
mnuSwitch.Enabled = Not mnuSwitch.Enabled
mnuPrint.Enabled = Not mnuPrint.Enabled
End Sub
Private Sub mnuARCode_Click()
cboARCode.Enabled = Not cboARCode.Enabled
End Sub
Private Sub mnuExit_Click()
Call cmdExit_Click
End Sub
Private Sub mnuInvoice_Click()
Dim strSQL As String, strINVOICE As String, lngLENGTH As Long, strSQL2 As String
Dim strTABLE As String, strINDEX As String, strRELATE1 As String, strRELATE2 As String
lngLENGTH = InStr(1, lstInvoice.Text, vbTab, vbTextCompare)
strINVOICE = Trim$(Mid$(lstInvoice.Text, 1, (lngLENGTH - 1)))
strTABLE = App.Path & "\" & gstrCOMPANY & "PSHIS.DBF"
strINDEX = App.Path & "\" & gstrCOMPANY & "PSHIS.MDX"
strRELATE1 = "OESHI = " & App.Path & "\" & gstrCOMPANY & "OESHI.DBF, " & App.Path & "\" & gstrCOMPANY & "OESHI.MDX, OESHCODE"
strRELATE2 = "PSHID = " & App.Path & "\" & gstrCOMPANY & "PSHID.DBF, " & App.Path & "\" & gstrCOMPANY & "PSHID.MDX, PSHDREC"
rrHistory.ReportName = App.Path & "\OE00005xc.rrw"
rrHistory.RelatedTables(0) = strRELATE1
rrHistory.RelatedTables(1) = strRELATE2
' rrHistory.RelatedTables(0) = App.Path & "\" & gstrCOMPANY & "OESHI.DBF"
' rrHistory.Scope = 2
' rrHistory.Query = 2
strSQL = "PSHIS->PSHIINVNO = '" & strINVOICE '& "'"
' strSQL = "PSHIS->PSHIINVNO is equal to '" & strINVOICE & "'"
' strSQL = "PSHIS->PSHIREC is equal to PSHID->PSHDREC and PSHIS->PSHIINVNO is equal to '" & strINVOICE
strSQL = strSQL & "' and PSHIS->PSHISOURCE = 'OE'"
rrHistory.MasterTable = strTABLE
rrHistory.MasterIndex = strINDEX
' rrHistory.MasterIndex
' rrHistory.Scope = 2
' rrHistory.LowScope = strINVOICE
' rrHistory.HighScope = strINVOICE
rrHistory.Query = 2
rrHistory.filter = strSQL
' strSQL2 = "InvNo = '" & strINVOICE & "'"
' rrHistory.ParametersString = strSQL2
' rrHistory.printer = "HP OfficeJet G Series"
rrHistory.printer = "?"
rrHistory.RunReport (1)
End Sub
Private Sub mnuPrint_Click()
Call cmdPrint_Click
End Sub
Private Sub mnuSwitch_Click()
Call cmdSwitch_Click
End Sub
Reference in New Issue View Git Blame Copy Permalink