|
This is one of the method but i did in vb.net
here is the link to change the vb code to c code
http://www.google.com.bh/search?hl=en&source=hp&q=code+converter+vb+to+c&btnG=Google+Search&meta=&aq=2&oq=code+convert[^]
public void CrearPDF(DataSet ds, string nombrearchivopdf)
{
StrongTypedReport cr = new StrongTypedReport();
cr.SetDataSource(ds);
Stream input = cr.ExportToStream(
CrystalDecisions.Shared.ExportFormatType.PortableDocFormat);
FileStream output = new FileStream(nombrearchivopdf,
FileMode.Create);
const int size = 4096;
byte[] bytes = new byte[4096];
int numBytes;
while((numBytes = input.Read(bytes, 0, size)) > 0)
output.Write(bytes, 0, numBytes);
output.Close();
Best Of Regards,
SOFTDEV
Sad like books with torn pages, sad like unfinished stories ...
|
|
|
|
|
That is excellent. I can do the same with some of the software that I have.
But it ain't free is it?  This was one of the requirements of the OP.
The link to conversion the software search was a good idea, I don't need it personally, but others might find it useful.
Henry Minute
Do not read medical books! You could die of a misprint. - Mark Twain
Girl: (staring) "Why do you need an icy cucumber?"
“I want to report a fraud. The government is lying to us all.”
|
|
|
|
|
Hello everybody,
in a partial task of my project I read from file and displayed a non-GDI picture (10-bit linear-RGB DPX file). In a former approach, this took around 580 ms for a single picture. Hoping to increase the performance, I split the reading of the file and the display of the picture into 2 separate functions - which has been resulting in an immense loss of performance (7500 ms per picture now). I can't understand why  and how to avoid that? Maybe someone around here could recognize my blind spot and help me out?
In the newer approach, the file reading is performed by a background worker while the first picture displays. The BGW puts header and image data (as array of UInt) into a special 'dpx' class, a particular number of which are stored in a 'frames' class. This part still seems to work fine. The dpx class reads the file like
Public Function read_Image() As Array
fsh = New FileStream(Me.FileToRead.FullName, FileMode.Open)
brh = New BinaryReader(fsh)
'Set the position to the proper position of the files stream.
fsh.Position = Me.DPXOffset
ReDim DPXPixelArray(((Me.FileToRead.Length - fsh.Position) / 4) - 1)
For i As UInteger = 0 To Me.DPXPixelArray.GetUpperBound(0)
Me.DPXPixelArray(i) = SwapDWORD(brh.ReadUInt32)
Next
fsh.Close()
brh = Nothing
Return DPXPixelArray
End Function
Before, all of this was part of the displaying process: read the file, swap the bytes properly, then get RGB out of the 10-bit-data into a RGB byte array (i.e. convert) and display the bitmap. Now that the DPXPixelArray holds the raw data stored in the class in order to do what ever with it, I expected to have much lesser than 580 ms for the display process, since the class only (?) has to convert the array of UInt to a bitmap. This is done with
Public Sub DisplayImage()
If gch.IsAllocated Then gch.Free()
Dim arrayImage() As Byte = dpx.RGBArrayFromRawArray(dpx.DPXPixelArray)
gch = GCHandle.Alloc(arrayImage, GCHandleType.Pinned)
Dim pBuf As IntPtr = gch.AddrOfPinnedObject
Dim Width As Integer = dpx.DPXWidth
Dim Height As Integer = dpx.DPXHeight
Dim stride As Integer = Width * 3
PictureBox1.SizeMode = PictureBoxSizeMode.Zoom
PictureBox1.Image = New Bitmap(Width, Height, stride, Imaging.PixelFormat.Format24bppRgb, pBuf)
End Sub
Public Function RGBArrayFromRawArray(ByVal RawArray) As Array
Dim j As Integer
Dim RGBArray(CInt(RawArray.Length * 3) - 1) As Byte
For i = 0 To (RawArray.Length - 1)
j = i * 3
Dim buff As UInteger = RawArray(i)
' bit-shifting operation
RGBArray(j) = (buff And &HFFC) >> 4 ' Blue
RGBArray(j + 1) = (buff And &H3FFFFC) >> 14 ' Green
RGBArray(j + 2) = (buff And &HFFFFFFFC) >> 24 ' Red
Next i
Return RGBArray
End Function
Measuring the elapsed time, the RGBArrayFromRawArray function alone takes more than 7 seconds now! What's wrong here? The function seems to be almost identical to what I had before...
Any hints and advice extremely welcome!
Thank
Mick
|
|
|
|
|
I was able to solve the problem myself with the change of just a few lines of code, in particular taking care of proper VB syntax:
Public Function RGBArrayFromRawArray(ByVal RawArray() As UInteger) As Array '<----- change
Dim j As Integer
Dim RGBArray(CInt(RawArray.Length * 3) - 1) As Byte
For i As Integer = 0 To (RawArray.Length - 1)
j = i * 3
Dim buff As UInteger = RawArray(i) '<----- change
' bit-shifting operation
RGBArray(j) = (buff And &HFFC) >> 4 ' Blue
RGBArray(j + 1) = (buff And &H3FFFFC) >> 14 ' Green
RGBArray(j + 2) = (buff And &HFFFFFFFC) >> 24 ' Red
Next i
Return RGBArray
End Function
Each picture displays from the DPXPixelArray within 65 ms now!
Quite a good lesson for me how taking a nap and then remember proper syntax can make a huge difference...
|
|
|
|
|
I need help learning how to use activelock from could someone help me?
please email me at timnboys@gmail.com or email me on this site, to help me with activelock, I am using visual basic 2008 express edition
|
|
|
|
|
If you go to their home page (the address you give in your post), you will see that there is a navigation link to 'Forum'. That is where you should ask your question. They know more about their product than anyone here is likely to.
Henry Minute
Do not read medical books! You could die of a misprint. - Mark Twain
Girl: (staring) "Why do you need an icy cucumber?"
“I want to report a fraud. The government is lying to us all.”
|
|
|
|
|
you do realize you've just sent away a new CP customer?
Chris wants you to be much nicer. We're in the middle of a crisis, we can't afford to loose business like that.
|
|
|
|
|
Sorry! 
Won't do it again.
Henry Minute
Do not read medical books! You could die of a misprint. - Mark Twain
Girl: (staring) "Why do you need an icy cucumber?"
“I want to report a fraud. The government is lying to us all.”
|
|
|
|
|
Actually, it was the correct thing to do. He was being sarcastic. 
It's amazing how many people out there think that we know everything about the thousands of libraries out there. Apparently, the manufacturer of a library is the last people you ask when you have questions about it.
|
|
|
|
|
Dave Kreskowiak wrote: Actually, it was the correct thing to do. He was being sarcastic.
I knew that, but that Luc is such a bully. Just cos he has a sea to hide behind, he thinks he's safe. One day though, one day........
Henry Minute
Do not read medical books! You could die of a misprint. - Mark Twain
Girl: (staring) "Why do you need an icy cucumber?"
“I want to report a fraud. The government is lying to us all.”
|
|
|
|
|
Hi,
I've got a problem with generating MustOverride Property.
My code looks like this:
Dim p1t1 As New CodeMemberProperty
p1t1.Name = "myProperty"
p1t1.Type = New CodeTypeReference(GetType(Integer))
p1t1.Attributes = MemberAttributes.Abstract Or _
MemberAttributes.Public
What I've got after GenerateCodeFromCompileUnit() is:
Public MustOverride Property myProperty() As Integer
End Property
It's not ok because in VB it should looks like this:
Public MustOverride Property myProperty() As Integer
When I'm doing the same with a method everything is ok.
My code:
Dim m1t1 As New CodeMemberMethod
m1t1.Name = "myMethod"
m1t1.ReturnType = New CodeTypeReference(GetType(System.Void))
m1t1.Attributes = MemberAttributes.Abstract Or _
MemberAttributes.Public
And generated code:
Public MustOverride Sub myMethod()
Of course I'm placing these members in a class declaration, that is
CodeTypeDeclaration object and of course this class declaration has attribute TypeAttributes.Abstract:
Dim t1 As New CodeTypeDeclaration
t1.Name = "Class1"
t1.IsClass = True
t1.TypeAttributes = Reflection.TypeAttributes.Abstract Or _
Reflection.TypeAttributes.Class Or _
Reflection.TypeAttributes.Public
Please help me.
Thanks in advance
|
|
|
|
|
Hi All,
I have developed an application in vb.net to access the system information of network PC. I have used Management Namespace for this. The application is running fine on Srever 2003 OS network but the application is unable to connect to XP machines. Even though i m providing proper password of the machine it is unable to connect to xp machine.
does any one know the reson for this? Do i need to write any spacial code for XP machine connection?
Please help me out?
Thanx in advance
Regards,
Paramhans
|
|
|
|
|
Without knowing the error that it's throwing, there's not a lot anyone can tell you that would be useful.
|
|
|
|
|
Hi Dave,
Thanx for your reply. I should have provided the error message earlier. I really apologize for that. It is giving me following Error Message.
The RPC server is unavailable. (Exception from HRESULT: 0x800706BA)
Can you help me to resolve it.
Thanx in Advance
Regards,
Paramhans
|
|
|
|
|
The WMI Services are either not running on your server machine, or not running on the target machine your're trying to connect to.
|
|
|
|
|
RPC is "Remote Procedure Call". I think the RPC service is not running or something of the like.
If everything was not true, would it be not true that everything is not true? So by saying everything is not true, you are automatically denying that everything is not true. Im so confused...
FreeDOS
- An open source modern
MS-DOS/PC-DOS replacement.
|
|
|
|
|
hi
please tell me how i can draw a diagram in form ?
if you are a link about component of chart please give me
thanks
|
|
|
|
|
Have you searched the CodeProject articles?
Here[^] is a popular one; I haven't used it myself, but I have seen many people referring to it.
|
|
|
|
|
Hello to All,
I am trying to execute application in Mobile by my windows application using cecreateprocess.
first two times it executes normally but third time it shows MissingMethodException.
Thanks
If you can think then I Can.
|
|
|
|
|
I have a treeview that was populated by using a recursive function to add nodes from an XML document to the tree. I want the user to be able to right-click on any node and get the xpath to that node (similar to the "Copy XPath" function in Altova XMLSpy.) At first I thought I could just use the XMLSpy API and call that function, but apparently it's not available.
Has anybody written a "GetXPath" function, or have an idea how to approach this problem?
By the way, using TreeView.SelectedNode.FullPath is not going to work in this case since it does not return a node index. For the example below, Treeview.SelectedNode.FullPath would simply return "/Report/Section/Content/Item/Title/Item", but I need "/Report/Section/Content/Item[3]/Title/Item"
<Report>
<Section>
<Title>
<Item>Header</Item>
</Title>
<Content>
<Item>
<Title>
<Item>Title 1</Item>
</Title>
</Item>
<Item>
<Title>
<Item>Title 2</Item>
</Title>
</Item>
<Item>
<Title>
<Item>Title 3</Item> <--- SELECTED NODE
</Title>
</Item>
<Item>
<Title>
<Item>Title 4</Item>
</Title>
</Item>
<Item>
<Title>
<Item>Title 5</Item>
</Title>
</Item>
</Content>
</Section>
</Report>
Thanks in advance for any help,
Sacha
|
|
|
|
|
What about storing navigation information, for instance some index, in the Tag property of the Node?
Regards: Didi
|
|
|
|
|
Thanks Didi,
That's almost exactly what I did, except I store the entire XPath in the Name property of the treenode.
Every time a treenode gets created, I call a function GetXPath(tvwNode, xmlNode) that stores the XPath for that node in the treeview node Name property.
Sacha
|
|
|
|
|
Good morning, I have used the following code to dynamically load an image into my crystal report (Windows Application Crystal report viewer), but when trying to print it I run out of memory after 20 pages (40 images) or so and the application breaks down. (background processing error)
Is there a way to free up the memory after I print a page or after the image is loaded?
Private Sub frmPhotoBook_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Me.DtPhotoBookTA.Fill(Me.DsRptPhotoBook.dtPhotoBook, myCaseId)
Dim cryRpt As New ReportDocument
cryRpt.Load(Windows.Forms.Application.StartupPath & "\rptPhotoBook.rpt")
For index As Int16 = 0 To (DsRptPhotoBook.Tables("dtPhotoBook").Rows.Count - 1) Step 1
If DsRptPhotoBook.Tables("dtPhotoBook").Rows(index).Item("txtPictureId").ToString <> "" Then
If System.IO.File.Exists(DsRptPhotoBook.Tables("dtPhotoBook").Rows(index).Item("txtPicPath") & DsRptPhotoBook.Tables("dtPhotoBook").Rows(index).Item("txtPictureId")) Then
LoadImage(DsRptPhotoBook.Tables("dtPhotoBook").Rows(index), "img", DsRptPhotoBook.Tables("dtPhotoBook").Rows(index).Item("txtPicPath") & DsRptPhotoBook.Tables("dtPhotoBook").Rows(index).Item("txtPictureId"))
End If
End If
Next
cryRpt.DataSourceConnections(0).SetConnection("xxxxxx", "xxxxxx", "xxxxxx", "xxxxxx")
cryRpt.SetDataSource(DsRptPhotoBook)
Me.CrystalReportViewer1.ReportSource = cryRpt
Me.CrystalReportViewer1.Refresh()
Me.CrystalReportViewer1.Zoom(75)
End Sub
Private Sub LoadImage(ByVal objDataRow As DataRow, ByVal imageField As String, ByVal filePath As String)
Try
Dim fs As New System.IO.FileStream(filePath, IO.FileMode.Open, IO.FileAccess.Read)
Dim image(fs.Length) As Byte
fs.Read(image, 0, Convert.ToInt32(fs.Length))
fs.Close()
objDataRow(imageField) = image
fs.Dispose()
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
|
|
|
|
|
the code below is for an application through whose front end i update relevant info like agreement etc...The problem is when I am trying to enter an agreement the 'UPDATE' button is greyed out(Inactive).
The issue seems to be in Private Sub cmdUpdate0_Click()
The code below is for the whole form.
CODE STARTS
(
Option Explicit
Private m_objAgreement As CAgreement
Private m_objAgreeDetail As CAgreeDetail
Private m_objCode As CCode
Private m_objCompGroup As CCompGroup
Private m_objDivision As CDivision
Private m_objEmployee As CEmployee
Private m_objNegotiation As CNegotiation
Private m_objPart As CPart
Private m_objSupplier As CSupplier
Private m_frmSupSearch As frmSupSearch
Private m_rsNegCode As Recordset
Private m_rsAgreeNo As Recordset
Private m_frmAddCompGroup As frmAddCompGroup
Private m_blnInitialCall As Boolean
Private m_blnBeenOnTab0 As Boolean
Private m_blnBeenOnTab1 As Boolean
Private m_blnBeenOnTab2 As Boolean
Private m_blnBeenOnTab3 As Boolean
Private m_intInValidCnt As Integer ' Required fields only
Private m_frmParent As Form 'Ref to FMenuHost Parent form
Private m_blnCallFromMenu As Boolean
Private m_strAgree0 As String
Private m_strAgree1 As String
Private m_strAgree2 As String
Private m_strAgree3 As String
Private m_strCommitmentType As String
Private m_strPrevNegCode As String
Private Enum idxMaint
idxMaintCommitmentType = 0
idxMaintAgreementType = 1
idxMaintNegotiatedCurrency = 2
idxMaintAgreeStatus = 3
idxMaintStartDate = 4
idxMaintEndDate = 5
idxMaintFinalShipDate = 6
idxMaintPercentShare = 7
idxMaintScope = 8
idxMaintPreferredUOM = 9
idxMaintDiscountPercent = 10
idxMaintDiscountDays = 11
idxMaintNetDays = 12
idxMaintReturnAuthorization = 13
idxMaintAgreeComments = 14
End Enum
Private Enum tabIndex
tabMaint = 0
tabAddPart = 1
tabPrice = 2
tabCopy = 3
End Enum
Private Enum lvlLevel
lvlAgreement = 1
lvlCompGroup = 2
lvlPart = 3
lvlDivision = 4
End Enum
Private Const NegCodeMaxLength = 4
Private Const AgreeNoMaxLength = 8
Private Const CopyAgreeJobId = "m4110"
Private Sub Form_Load()
On Error GoTo ERR_ROUTINE
Set m_objAgreement = New CAgreement
Set m_objAgreeDetail = New CAgreeDetail
Call PopulateNeg
m_blnCallFromMenu = True
FMain.MousePointer = vbNormal 'Parent set to hourglass before load
Exit Sub
ERR_ROUTINE:
Set m_objAgreement = Nothing
Set m_objAgreeDetail = Nothing
FMain.MousePointer = vbNormal
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set m_rsNegCode = Nothing
Set m_rsAgreeNo = Nothing
Set m_objAgreeDetail = Nothing
Set m_objAgreement = Nothing
End Sub
Private Sub Form_Activate()
Call m_frmParent.ZOrder(0) 'Makes sure the Parent is on top
End Sub
'Public Display function called by FMenuHost to show form
'Parameters:
' frmParent Parent FMenuHost form.
' intTab Optional. Tab to display.
'
Public Sub Display(frmParent As Form, Optional intTab As Integer)
On Error GoTo ERR_ROUTINE
m_blnInitialCall = True
tabTab.Tab = intTab
Set m_frmParent = frmParent
m_frmParent.Caption = "Agreement"
Set m_frmParent.ChildForm = Me
Me.Show
m_blnInitialCall = False
Select Case intTab
Case tabMaint
Call PopulateMaint
Case tabAddPart
Call PopulateAddPart
Case tabPrice
Call PopulatePrice
Case tabPrice
'cmdClear3
End Select
cboNeg.SetFocus
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
'This is the form's queryunload event modified so that it is public and returns the
'cancel value. This event can then be called from the FMenuHost form's queryunload
'event.
'
'Parameters:
' Cancel Set to True if you want to cancel the unload
' UnloadMode See VB documentation for modes
'
'Return:
' Integer Cancel value raised to calling QueryUnload
'
Public Function QueryUnload(Cancel As Integer, UnloadMode As Integer) As Integer
Dim strMessage As String
QueryUnload = Cancel
Call m_frmParent.ZOrder(0) 'Make sure the parent screen is on top
End Function
'This is the form's unload event modified so that it is public and returns the
'cancel value. This event can then be called from the FMenuHost form's queryunload
'event.
'
'Parameters:
' Cancel Set to True if you want to cancel the unload
' UnloadMode See VB documentation for modes
'
'Return:
' Integer Cancel value raised to calling QueryUnload
'
Public Function Unload(Cancel As Integer) As Integer
Unload = Cancel
End Function
Private Sub Form_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub cboCombo0_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
End Sub
Private Sub fraDivision1_click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub Frame4_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub Frame5_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub Frame8_click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub fraPrice2_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub Label1_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub Label2_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub lblCompGroup2_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub lblDiv2_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub lblFieldLabel_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
End Sub
Private Sub lblLabel0_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
End Sub
Private Sub lblLabel1_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
End Sub
Private Sub lblLabel2_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
End Sub
Private Sub lblLabel3_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
End Sub
Private Sub lblLevel2_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub lblPart2_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub Picture1_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtAgreeStatus0_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtCommitmentType0_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtCompGroup0_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtCompGroup1_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtCompGroupCode1_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtDiv1_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtDiv2_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtPart1_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtPart2_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtSupName_Click()
Call m_frmParent.ZOrder(0)
End Sub
Private Sub datDate0_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtText0_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
End Sub
Private Sub txtText2_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
End Sub
Private Sub tabTab_Click(PreviousTab As Integer)
On Error GoTo ERR_ROUTINE
Dim intCurrentTab As Integer
'Call m_frmParent.ZOrder(0)
If m_blnInitialCall = True Then
Exit Sub
End If
If PreviousTab = tabMaint Then
m_strPrevNegCode = cboNeg.Value
End If
intCurrentTab = tabTab.Tab
Select Case intCurrentTab
Case tabMaint
Call PopulateMaint
Case tabAddPart
Call PopulateAddPart
Case tabPrice
Call PopulatePrice
End Select
If m_blnCallFromMenu = True Then
m_blnCallFromMenu = False
Else
cboNeg.SetFocus
End If
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub PopulateNeg()
On Error GoTo ERR_ROUTINE
Me.MousePointer = vbHourglass
Set m_objNegotiation = New CNegotiation
Set m_rsNegCode = m_objNegotiation.RETRIEVE(boNegRetNegCodeList)
With cboNeg
Set .DataSourceList = m_rsNegCode
.DataFieldList = m_rsNegCode.Fields(0).Name
.Value = ""
End With
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Me.MousePointer = vbNormal
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub cboNeg_InitColumnProps()
cboNeg.Columns(0).Visible = True 'Negotiation
cboNeg.Columns(0).Width = 500
cboNeg.Columns(1).Visible = True 'Neg Name
cboNeg.Columns(2).Visible = False 'Created_by
cboNeg.Columns(3).Visible = False 'Comp Group Code
cboNeg.Columns(4).Visible = False 'Comp Group Name
End Sub
Private Sub cboNeg_Validate(Cancel As Boolean)
On Error GoTo ERR_ROUTINE
' Call ValidateNegCodeCombo
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub cboNeg_Click()
On Error GoTo ERR_ROUTINE
Call m_frmParent.ZOrder(0)
ValidateNegCodeCombo
Exit Sub
ERR_ROUTINE:
m_rsNegCode.MoveFirst
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub cboNeg_KeyPress(KeyAscii As Integer)
On Error GoTo ERR_ROUTINE
If KeyAscii = 13 Then
Call cboNeg.DoClick
' m_rsNegCode.MoveFirst
End If
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub cboNeg_KeyUp(KeyCode As Integer, Shift As Integer)
On Error GoTo ERR_ROUTINE
If Len(cboNeg.Text) > NegCodeMaxLength Then
cboNeg.Text = Mid(cboNeg.Text, 1, NegCodeMaxLength)
End If
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Function ValidateNegCodeCombo() As Boolean
On Error GoTo ERR_ROUTINE
Dim strNegCode As String
Dim blnFound As Boolean
Dim vntFoundRow As Variant
Dim intIndex As Integer
txtNegName.Text = ""
txtCompGroup0.Text = ""
Select Case tabTab.Tab
Case tabMaint
cmdClear0_Click
Case tabAddPart
cmdClear1_Click
Case tabPrice
cmdClear2_Click
End Select
With cboNeg
strNegCode = .Text
.ToolTipText = ""
.ForeColor = vbBlack
End With
lblNeg.ForeColor = vbBlack
With m_rsNegCode
.MoveFirst
Do While Not .EOF
If StrComp(strNegCode, Trim(.Fields(0).Value), vbBinaryCompare) = 0 Then
Call cboNeg.RowBookmark(.Bookmark)
blnFound = True
Exit Do
End If
.MoveNext
Loop
End With
If blnFound = False Then
Err.Raise boNegErrValidation, "Neg Code Validation", "Negotiation Code is invalid"
Else
With cboNeg
.Value = m_rsNegCode.Fields(0).Value
txtNegName = .Columns(1).Value
txtCompGroup0 = .Columns(4).Value
End With
Call PopulateAgree
cboAgree.Text = ""
txtSupName = ""
End If
ValidateNegCodeCombo = True
Exit Function
ERR_ROUTINE:
m_rsNegCode.MoveFirst
If Err.Number = boNegErrValidation Or Err.Number = boNegErrRequired Then
lblNeg.ForeColor = vbRed
With cboNeg
.SetFocus
.ForeColor = vbRed
.ToolTipText = Err.Description
End With
cboNeg.SetFocus
With cboAgree
.Value = ""
.ForeColor = vbBlack
End With
lblAgree.ForeColor = vbBlack
txtSupName.Text = ""
Else
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End If
End Function
Private Sub PopulateAgree()
On Error GoTo ERR_ROUTINE
Me.MousePointer = vbHourglass
If cboNeg.Text = "" Then
Exit Sub
End If
'Populate Agreement Combo
Set m_rsAgreeNo = m_objAgreement.RETRIEVE(boAgreeRetForGeneralUseAllStatus, , cboNeg.Text)
With cboAgree
Set .DataSourceList = m_rsAgreeNo
.DataFieldList = m_rsAgreeNo.Fields(0).Name
.Value = ""
End With
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Me.MousePointer = vbNormal
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub cboAgree_InitColumnProps()
cboAgree.Columns(0).Visible = True 'Agree No
cboAgree.Columns(0).Width = 650
cboAgree.Columns(1).Visible = True 'Sup Code
cboAgree.Columns(1).Width = 650
cboAgree.Columns(2).Visible = True 'Sup Name
cboAgree.Columns(2).Width = 2400
cboAgree.Columns(3).Visible = True 'Sup Status
cboAgree.Columns(3).Width = 300
cboAgree.Columns(4).Visible = False 'Created By
'cboAgree.Columns(5).Visible = False 'Commitment Type
End Sub
Private Sub cboAgree_Click()
On Error GoTo ERR_ROUTINE
Call m_frmParent.ZOrder(0)
m_strCommitmentType = cboAgree.Columns(5).Value
If ValidateAgreeNoCombo = False Then
GoTo ERR_ROUTINE
End If
Exit Sub
ERR_ROUTINE:
If m_rsAgreeNo Is Nothing Then
Else
If Not (m_rsAgreeNo.BOF Or m_rsAgreeNo.EOF) Then
m_rsAgreeNo.MoveFirst
End If
End If
If Not (Err.Number = boAgreeErrValidation Or Err.Number = boAgreeErrRequired) Then
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End If
End Sub
Private Sub cboAgree_KeyPress(KeyAscii As Integer)
On Error GoTo ERR_ROUTINE
If KeyAscii = 13 Then
Call cboAgree.DoClick
End If
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub cboAgree_KeyUp(KeyCode As Integer, Shift As Integer)
On Error GoTo ERR_ROUTINE
If Len(cboAgree.Text) > AgreeNoMaxLength Then
cboAgree.Text = Mid(cboAgree.Text, 1, AgreeNoMaxLength)
End If
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Function ValidateAgreeNoCombo() As Boolean
On Error GoTo ERR_ROUTINE
Dim strMessage As String
Dim blnFound As Boolean
Dim vntFoundRow As Variant
Dim intIndex As Integer
Dim adoRS As Recordset
Dim strAgree As String
Me.MousePointer = vbHourglass
Select Case tabTab.Tab
Case tabMaint
ClearFields0
Case tabAddPart
cmdClear1_Click
Case tabPrice
cmdClear2_Click
End Select
If cboAgree.Text = "" Then
Err.Raise boAgreeErrRequired, "Agreement Validation", "Agreement is required"
Else
With cboAgree
strAgree = Trim(.Text)
.ToolTipText = ""
.ForeColor = vbBlack
End With
lblAgree.ForeColor = vbBlack
End If
txtSupName.Text = ""
With cboNeg
.ToolTipText = ""
.ForeColor = vbBlack
End With
lblNeg.ForeColor = vbBlack
Set adoRS = m_objAgreement.RETRIEVE(boAgreeRetForAgreementUIOnly, strAgree)
If (adoRS.BOF And adoRS.EOF) Then
Err.Raise boAgreeErrValidation, "Agree Code Validation", "Agreement is invalid"
End If
With m_rsNegCode
.MoveFirst
Do While Not .EOF
If StrComp(adoRS.Fields(3).Value, .Fields(0).Value, 1) = 0 Then
Call cboNeg.RowBookmark(.Bookmark)
Exit Do
End If
.MoveNext
Loop
End With
cboNeg.Value = adoRS.Fields(3).Value
txtNegName = cboNeg.Columns(1).Value
txtCompGroup0.Text = cboNeg.Columns(4).Value
Call PopulateAgree
With m_rsAgreeNo
.MoveFirst
Do While Not .EOF
If StrComp(Trim(strAgree), Trim(.Fields(0).Value), vbBinaryCompare) = 0 Then
Call cboAgree.RowBookmark(.Bookmark)
Exit Do
End If
.MoveNext
Loop
End With
cboAgree.Value = m_rsAgreeNo.Fields(0).Value
Call Err.Clear 'because Err.description may still contains prev err message
txtSupName.Text = m_rsAgreeNo.Fields(2).Value
Select Case tabTab.Tab
Case tabMaint
Call PopulateMaint
Case tabAddPart
Call PopulateAddPart
Case tabPrice
Call PopulatePrice
End Select
Set adoRS = Nothing
Me.MousePointer = vbNormal
ValidateAgreeNoCombo = True
Exit Function
ERR_ROUTINE:
Set adoRS = Nothing
Me.MousePointer = vbNormal
ValidateAgreeNoCombo = False
If m_rsAgreeNo Is Nothing Then
Else
If Not (m_rsAgreeNo.BOF Or m_rsAgreeNo.EOF) Then
m_rsAgreeNo.MoveFirst
End If
End If
If Err.Number = boAgreeErrValidation Or Err.Number = boAgreeErrRequired Then
lblAgree.ForeColor = vbRed
With cboAgree
.SetFocus
.ForeColor = vbRed
.ToolTipText = Err.Description
End With
txtSupName.Text = ""
cboAgree.SetFocus
Else
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End If
End Function
Private Sub PopulateMaint()
On Error GoTo ERR_ROUTINE
Dim txt As TextBox
If m_blnBeenOnTab0 = False Then
m_blnBeenOnTab0 = True
Call PopulateCombos0
For Each txt In txtText0
txt.MaxLength = CallByName(m_objAgreement, "MaxLength", VbMethod, txt.Tag)
Next
End If
If cboAgree.Value = "" Then
ClearFields0
m_strAgree0 = Trim(cboAgree.Value)
Exit Sub
End If
m_objAgreement.AgreeNo = cboAgree.Value
' 'this portion has been changed. make if statement. 11/12/99
' If StrComp(Trim(m_strAgree0), Trim(cboAgree.Value), vbBinaryCompare) <> 0 Then
m_strAgree0 = Trim(cboAgree.Value)
Call GetData0
' End If
Call SetButtons0
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub SetButtons0()
On Error GoTo ERR_ROUTINE
Dim strAgreeStatus As String
strAgreeStatus = txtText0(idxMaintAgreeStatus).Text
If strAgreeStatus = "U" Then
cmdUpdate0.Enabled = True
cmdDelete0.Enabled = True
cmdFinalizeDownload0.Enabled = True
cmdFinalizeDownload0.Caption = "&Finalize"
Else
If strAgreeStatus = "A" Then
cmdUpdate0.Enabled = True
cmdDelete0.Enabled = False
cmdFinalizeDownload0.Enabled = True
cmdFinalizeDownload0.Caption = "Down&Load"
Else
If strAgreeStatus = "E" Then
cmdUpdate0.Enabled = False
cmdDelete0.Enabled = False
cmdFinalizeDownload0.Enabled = False
cmdFinalizeDownload0.Caption = "Down&Load"
End If
End If
End If
If Trim(g_objApp.User.EmployeeCode) = Trim(m_objAgreement.CreatedBy) _
Or g_objApp.User.EmployeeCode = "77777777" Then
'do nothing
Else
cmdUpdate0.Enabled = False
cmdDelete0.Enabled = False
cmdFinalizeDownload0.Enabled = False
cmdFinalizeDownload0.Caption = "Down&Load"
End If
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub cboCombo0_InitColumnProps(Index As Integer)
Select Case Index
Case idxMaintAgreementType
cboCombo0(1).Columns(0).Visible = False
cboCombo0(1).Columns(1).Visible = True
cboCombo0(1).Columns(1).Width = 2775
cboCombo0(1).Columns(2).Visible = False
Case idxMaintNegotiatedCurrency
cboCombo0(2).Columns(0).Visible = False
cboCombo0(2).Columns(1).Visible = True
cboCombo0(2).Columns(1).Width = 2555
cboCombo0(2).Columns(2).Visible = False
Case idxMaintPreferredUOM
cboCombo0(9).Columns(0).Visible = True
cboCombo0(9).Columns(1).Visible = False
cboCombo0(9).Columns(0).Width = 750
cboCombo0(9).Columns(2).Visible = False
End Select
End Sub
Private Sub PopulateCombos0() 'Populate all combo boxes
On Error GoTo ERR_ROUTINE
Me.MousePointer = vbHourglass
Dim adoRS As New Recordset
Set m_objCode = New CCode
'Populate Agreement Type Combo
Set adoRS = m_objCode.RETRIEVE(boCodeRetAgreementType)
Set cboCombo0(1).DataSourceList = adoRS
cboCombo0(1).DataFieldList = adoRS.Fields(0).Name
cboCombo0(1).DataFieldToDisplay = adoRS.Fields(1).Name
Set adoRS = Nothing
'Populate Negotiated Currency Combo
Set adoRS = m_objCode.RETRIEVE(boCodeRetCurrency)
Set cboCombo0(2).DataSourceList = adoRS
cboCombo0(2).DataFieldList = adoRS.Fields(0).Name
cboCombo0(2).DataFieldToDisplay = adoRS.Fields(1).Name
Set adoRS = Nothing
'Populate Preferred UOM Combo
Set adoRS = m_objCode.RETRIEVE(boCodeRetUOM, boCodeSortByCode)
Set cboCombo0(9).DataSourceList = adoRS
cboCombo0(9).DataFieldList = adoRS.Fields(0).Name
cboCombo0(9).DataFieldToDisplay = adoRS.Fields(0).Name
Set adoRS = Nothing
Set m_objCode = Nothing
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Me.MousePointer = vbNormal
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub cmdClear0_Click()
On Error GoTo ERR_ROUTINE
Call m_frmParent.ZOrder(0)
Me.MousePointer = vbHourglass
FMain.staMain.Panels(1).Text = ""
With cboNeg
.ForeColor = vbBlack
.ToolTipText = ""
End With
lblNeg.ForeColor = vbBlack
With cboAgree
.ForeColor = vbBlack
.ToolTipText = ""
End With
lblAgree.ForeColor = vbBlack
Call ClearFields0
ENDSUB:
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Me.MousePointer = vbNormal
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub ClearFields0()
Dim txt As TextBox
Dim cbo As SSOleDBCombo
Dim dat As SSDateCombo
Dim lbl As Label
On Error GoTo ERR_ROUTINE
For Each txt In txtText0
txt.Text = ""
txt.ForeColor = vbBlack
txt.ToolTipText = ""
Next
For Each cbo In cboCombo0
cbo.ToolTipText = ""
cbo.ForeColor = vbBlack
cbo.Value = ""
Next
For Each dat In datDate0
dat.ToolTipText = ""
dat.ForeColor = vbBlack
dat.Date = ""
Next
For Each lbl In lblLabel0
lbl.ForeColor = vbBlack
Next
txtAgreeStatus0 = ""
txtCommitmentType0 = ""
cboCombo0(idxMaintAgreementType).SetFocus
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub GetData0()
Dim txt As TextBox
Dim cbo As SSOleDBCombo
Dim dat As SSDateCombo
Dim strAgreeStatus As String
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
On Error GoTo ERR_TXT
For Each txt In txtText0
txt.Text = CallByName(m_objAgreement, txt.Tag, VbGet)
Next
If txtText0(0) = "P" Then
txtCommitmentType0 = "Percent Share"
Else
txtCommitmentType0 = "Quantity Based"
End If
Select Case txtText0(3)
Case "A"
txtAgreeStatus0 = "Active"
Case "E"
txtAgreeStatus0 = "Expired"
Case "U"
txtAgreeStatus0 = "Under Negotiation"
End Select
'Set Combo boxes to read values
On Error GoTo ERR_COMBO
For Each cbo In cboCombo0
cbo.Value = CallByName(m_objAgreement, cbo.Tag, VbGet)
Next
On Error GoTo ERR_DATE
For Each dat In datDate0
dat.Date = CallByName(m_objAgreement, dat.Tag, VbGet)
Next
strAgreeStatus = txtText0(idxMaintAgreeStatus).Text
If strAgreeStatus = "A" Then
m_objAgreement.DoFullEdits = "Y"
Else
m_objAgreement.DoFullEdits = "N"
End If
Call ValidateAll0
cboCombo0(idxMaintAgreementType).SetFocus
Exit Sub
ERR_RETRIEVE:
cboCombo0(idxMaintAgreementType).SetFocus
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
Exit Sub
ERR_TXT:
Resume Next
ERR_COMBO:
Resume Next
ERR_DATE:
Resume Next
End Sub
Private Sub cmdUpdate0_Click()
Dim strAgreeStatus As String
Call m_frmParent.ZOrder(0)
strAgreeStatus = txtText0(idxMaintAgreeStatus).Text
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
On Error GoTo ERR_ROUTINE
Me.MousePointer = vbHourglass
If strAgreeStatus = "A" Then
m_objAgreement.DoFullEdits = "Y"
Else
m_objAgreement.DoFullEdits = "N"
End If
FMain.staMain.Panels(1).Text = ""
DoEvents
If ValidateAll0 > 0 Then
FMain.staMain.Panels(1).Text = "Unable to Update. Check fields in red."
GoTo SUBEND
End If
DoEvents
If m_objAgreement.Update < 1 Then
Call MsgBox("Agreement not found. " & vbCrLf & _
"", vbExclamation & vbOKOnly, "Unable to Update.")
Else
cboCombo0(idxMaintAgreementType).SetFocus
FMain.staMain.Panels(1).Text = "Update Successful."
End If
SUBEND:
cboCombo0(idxMaintAgreementType).SetFocus
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
If Err.Number = boAgreeErrRequired Then
Call MsgBox("Unable to Update. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Required Data Missing")
ElseIf Err.Number = boAgreeErrValidation Then
Call MsgBox("Unable to Update. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Data Validation Error")
Else
Call MsgBox("Unable to Update. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Error")
End If
Me.MousePointer = vbNormal
End Sub
Private Sub cmdDelete0_Click()
Dim strMessage As String
Call m_frmParent.ZOrder(0)
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
On Error GoTo ERR_ROUTINE
FMain.staMain.Panels(1).Text = ""
Me.MousePointer = vbHourglass
If ValidateKeys0 > 0 Then
FMain.staMain.Panels(1).Text = "Unable to Delete. Check fields in red."
GoTo ENDSUB
End If
strMessage = "Are you sure you want to delete " & vbCrLf & vbCrLf & _
"Agreement : " & m_objAgreement.AgreeNo & "?" & vbCrLf & vbCrLf
If MsgBox(strMessage, vbYesNo, "Confirm Delete") = vbNo Then GoTo ENDSUB
If m_objAgreement.Delete() = 0 Then
Call MsgBox("Agreement not found.", _
vbExclamation & vbOKOnly, "Unable to Delete")
Else
DoEvents
ClearFields0
cboAgree.Text = ""
txtSupName = ""
m_strAgree0 = ""
PopulateAgree
'cboCombo0(idxMaintAgreementType).SetFocus
FMain.staMain.Panels(1).Text = "Delete Successful."
End If
ENDSUB:
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Call MsgBox("Unable to Delete. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Error")
Me.MousePointer = vbNormal
End Sub
Private Sub cmdFinalizeDownload0_Click()
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
On Error GoTo ERR_ROUTINE
Dim strAgreeStatus As String
Call m_frmParent.ZOrder(0)
strAgreeStatus = txtText0(idxMaintAgreeStatus).Text
If strAgreeStatus = "U" Then
Finalize
Else
If strAgreeStatus = "A" Then
Download
End If
End If
Exit Sub
ERR_ROUTINE:
Me.MousePointer = vbNormal
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub Finalize()
On Error GoTo ERR_ROUTINE
Me.MousePointer = vbHourglass
m_objAgreement.DoFullEdits = "Y"
FMain.staMain.Panels(1).Text = ""
DoEvents
If ValidateAll0 > 0 Then
FMain.staMain.Panels(1).Text = "Unable to Finalize. Check fields in red."
GoTo SUBEND
End If
DoEvents
If m_objAgreement.Finalize < 1 Then
Call MsgBox("Agreement not found. " & vbCrLf & _
"", vbExclamation & vbOKOnly, "Unable to Finalize.")
Else
cboCombo0(idxMaintAgreementType).SetFocus
FMain.staMain.Panels(1).Text = "Finalize Successful."
PopulateAgree
m_strAgree0 = ""
PopulateMaint
End If
SUBEND:
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
Me.MousePointer = vbNormal
End Sub
Private Sub Download()
Dim strAgreeStatus As String
strAgreeStatus = txtText0(idxMaintAgreeStatus).Text
If strAgreeStatus <> "A" Then
Call MsgBox("Agreement must be active to download. " & vbCrLf & _
"", vbExclamation & vbOKOnly, "Unable to Download.")
GoTo SUBEND
End If
On Error GoTo ERR_ROUTINE
Me.MousePointer = vbHourglass
m_objAgreement.DoFullEdits = "Y"
FMain.staMain.Panels(1).Text = ""
DoEvents
If ValidateAll0 > 0 Then
FMain.staMain.Panels(1).Text = "Unable to Download. Check fields in red."
GoTo SUBEND
End If
DoEvents
If m_objAgreement.Download < 1 Then
Call MsgBox("Agreement not found. " & vbCrLf & _
"", vbExclamation & vbOKOnly, "Unable to Download.")
Else
cboCombo0(idxMaintAgreementType).SetFocus
FMain.staMain.Panels(1).Text = "Download Successful."
End If
SUBEND:
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
Me.MousePointer = vbNormal
End Sub
Private Function ValidateAll0() As Integer
Dim txt As TextBox
Dim cbo As SSOleDBCombo
Dim dat As SSDateCombo
Dim lbl As Label
Dim intInvalidCount As Integer
Dim objFirstInvalid As Control
For Each txt In txtText0
txt.ForeColor = vbBlack
txt.ToolTipText = ""
Next
For Each cbo In cboCombo0
cbo.ToolTipText = ""
cbo.ForeColor = vbBlack
Next
For Each dat In datDate0
dat.ToolTipText = ""
dat.ForeColor = vbBlack
Next
For Each lbl In lblLabel0
lbl.ForeColor = vbBlack
Next
On Error GoTo ERR_TXT
For Each txt In txtText0
Call CallByName(m_objAgreement, txt.Tag, VbLet, txt.Text)
Next
On Error GoTo ERR_CBO
For Each cbo In cboCombo0
Call CallByName(m_objAgreement, cbo.Tag, VbLet, cbo.Value)
Next
On Error GoTo ERR_DAT
For Each dat In datDate0
Call CallByName(m_objAgreement, dat.Tag, VbLet, dat.Date)
Next
ValidateAll0 = intInvalidCount
'Set focus to first invalid control
If Not objFirstInvalid Is Nothing Then
objFirstInvalid.SetFocus
End If
Exit Function
ERR_TXT:
'Validation error routine for text boxes.
If Err.Number = boAgreeErrValidation _
Or Err.Number = boAgreeErrRequired Then
'Set tool tip and text red.
txt.ToolTipText = Err.Description
txt.ForeColor = vbRed
lblLabel0(txt.Index).ForeColor = vbRed
intInvalidCount = intInvalidCount + 1
If objFirstInvalid Is Nothing Then
Set objFirstInvalid = txt
Else
If txt.tabIndex < objFirstInvalid.tabIndex Then
Set objFirstInvalid = txt
End If
End If
Else
Call Err.Raise(VBA.Err.Number, VBA.Err.Source, VBA.Err.Description)
End If
Err.Clear
Resume Next
ERR_CBO:
'Validation error routine for combo boxes.
If Err.Number = boAgreeErrValidation _
Or Err.Number = boAgreeErrRequired Then
'Set tool tip and text red.
cbo.ToolTipText = Err.Description
cbo.ForeColor = vbRed
lblLabel0(cbo.Index).ForeColor = vbRed
intInvalidCount = intInvalidCount + 1
If objFirstInvalid Is Nothing Then
Set objFirstInvalid = cbo
Else
If cbo.tabIndex < objFirstInvalid.tabIndex Then
Set objFirstInvalid = cbo
End If
End If
Else
Call Err.Raise(VBA.Err.Number, VBA.Err.Source, VBA.Err.Description)
End If
Err.Clear
Resume Next
ERR_DAT:
'Validation error routine for combo boxes.
If Err.Number = boAgreeErrValidation _
Or Err.Number = boAgreeErrRequired Then
'Set tool tip and text red.
dat.ToolTipText = Err.Description
dat.ForeColor = vbRed
lblLabel0(dat.Index).ForeColor = vbRed
intInvalidCount = intInvalidCount + 1
If objFirstInvalid Is Nothing Then
Set objFirstInvalid = dat
Else
If dat.tabIndex < objFirstInvalid.tabIndex Then
Set objFirstInvalid = dat
End If
End If
Else
Call Err.Raise(VBA.Err.Number, VBA.Err.Source, VBA.Err.Description)
End If
Err.Clear
Resume Next
End Function
Private Function ValidateKeys0() As Integer
On Error GoTo ERR_TEXT
Dim intInvalidCount As Integer
m_objAgreement.AgreeNo = m_strAgree0
Exit Function
ERR_TEXT:
ValidateKeys0 = 1
If Err.Number = boAgreeErrValidation _
Or Err.Number = boAgreeErrRequired Then
intInvalidCount = intInvalidCount + 1
Else
Call Err.Raise(VBA.Err.Number, VBA.Err.Source, VBA.Err.Description)
End If
End Function
Private Sub PopulateAddPart()
On Error GoTo ERR_ROUTINE
Dim strAgree As String
Dim strPart As String
If m_blnBeenOnTab1 = False Then
m_blnBeenOnTab1 = True
txtPart1.MaxLength = CallByName(m_objAgreeDetail, "MaxLength", VbMethod, txtPart1.Tag)
txtDiv1.MaxLength = CallByName(m_objAgreeDetail, "MaxLength", VbMethod, txtDiv1.Tag)
End If
strAgree = cboAgree.Text
If strAgree = "" Then
ClearFields1
m_strAgree1 = strAgree
Exit Sub
End If
m_objAgreement.AgreeNo = cboAgree.Text
strPart = txtPart1.Text
If strAgree <> m_strAgree1 Then
m_strAgree1 = strAgree
ClearFields1
SetButtons1
End If
If strPart <> "" Then
txtPart1 = strPart
Call cmdGetData1_Click
End If
txtPart1.SetFocus
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub SetButtons1()
On Error GoTo ERR_ROUTINE
If Trim(g_objApp.User.EmployeeCode) = Trim(m_objAgreement.CreatedBy) _
Or g_objApp.User.EmployeeCode = "77777777" Then
cmdAddPart1.Enabled = True
cmdDeletePart1.Enabled = True
cmdAddDiv1.Enabled = True
fraDivision1.Enabled = True
Else
cmdAddPart1.Enabled = False
cmdDeletePart1.Enabled = False
cmdAddDiv1.Enabled = False
fraDivision1.Enabled = False
End If
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub cmdClear1_Click()
On Error GoTo ERR_ROUTINE
Call m_frmParent.ZOrder(0)
Me.MousePointer = vbHourglass
FMain.staMain.Panels(1).Text = ""
Call ClearFields1
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Me.MousePointer = vbNormal
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub ClearFields1()
On Error GoTo ERR_ROUTINE
Dim txt As TextBox
Dim cbo As SSOleDBCombo
Dim lbl As Label
txtPart1.Text = ""
txtPart1.ForeColor = vbBlack
txtPart1.ToolTipText = ""
txtDiv1.Text = ""
txtDiv1.ForeColor = vbBlack
txtDiv1.ToolTipText = ""
txtCompGroupCode1.Text = ""
txtCompGroup1.Text = ""
grdForecast1.Rows = 1
grdContract1.Rows = 1
For Each lbl In lblLabel1
lbl.ForeColor = vbBlack
Next
fraDivision1.Visible = False
txtPart1.SetFocus
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub txtpart1_KeyPress(KeyAscii As Integer)
On Error GoTo ERR_ROUTINE
If KeyAscii = 13 Then
cmdGetData1_Click
End If
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub cmdGetData1_Click()
Call m_frmParent.ZOrder(0)
Dim adoRS As New Recordset
Dim strAgreeStatus As String
Dim strSQL As String
fraDivision1.Visible = False
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
On Error GoTo ERR_RETRIEVE
If ValidatePart1 > 0 Then
FMain.staMain.Panels(1).Text = "Unable to Get Data. Check required fields in red."
GoTo SUBEND
End If
Set adoRS = m_objAgreeDetail.RETRIEVE(boADRetDetailByAgreePart, _
m_objAgreeDetail.AgreeNo, , _
m_objAgreeDetail.PartNo)
If adoRS.RecordCount = 0 Then
Set adoRS = Nothing
If cmdAddPart1.Enabled = True Then
cmdAddPart1.SetFocus
MsgBox "This part is not on this agreement. Press 'Add Part' button to add it."
Else
MsgBox "This part is not on this agreement."
End If
Exit Sub
End If
m_objAgreeDetail.CompGroupCode = adoRS.Fields("comp_group_code")
txtCompGroupCode1 = adoRS.Fields("comp_group_code")
If IsNull(adoRS.Fields("comp_group_name")) Then
txtCompGroup1 = ""
Else
txtCompGroup1 = adoRS.Fields("comp_group_name")
End If
LoadForecast
LoadAwards
txtPart2.Text = m_objAgreeDetail.PartNo
txtDiv2.Text = ""
fraDivision1.Visible = True
grdForecast1.SetFocus
SUBEND:
Me.MousePointer = vbNormal
Exit Sub
ERR_RETRIEVE:
Set adoRS = Nothing
If Err.Number = boADErrorRequired Then
Call MsgBox(Err.Description, vbOKOnly, "Required Data Missing")
ElseIf Err.Number = boADErrorValidation Then
Call MsgBox("Unable to Get Data. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Data Validation Error")
ElseIf Err.Number = dbErrDuplicate Then
Call MsgBox("Unable to Get Data. " & vbCrLf & vbCrLf & "The Part already exists and cannot be duplicated.", vbOKOnly, "Duplicate Division")
ElseIf Err.Number = boADErrorNoCompGroup Then
Call MsgBox("Unable to Get Data. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "No Comp Group")
Else
Call MsgBox("Unable to Get Data. " & vbCrLf & vbCrLf & VBA.Err.Description, vbOKOnly, "Error")
End If
Me.MousePointer = vbNormal
txtPart1.SetFocus
End Sub
Private Sub LoadForecast()
On Error GoTo ERR_ROUTINE
Dim strKey As String
Dim adoRS As New Recordset
Me.MousePointer = vbHourglass
Set adoRS = m_objAgreeDetail.RETRIEVE(boADRetPartDivForecast, _
m_objAgreeDetail.AgreeNo, , _
m_objAgreeDetail.PartNo)
Set grdForecast1.DataSource = adoRS
grdForecast1.ColWidth(0) = 1000
'grdForecast1.ColWidth(1) = 1100
grdForecast1.TextMatrix(0, 0) = "Div Code"
grdForecast1.TextMatrix(0, 1) = "Forecast"
grdForecast1.Cell(flexcpFontBold, 0, 0, 0, 1) = True
Set adoRS = Nothing
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Set adoRS = Nothing
Me.MousePointer = vbNormal
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub LoadAwards()
On Error GoTo ERR_ROUTINE
Dim strKey As String
Dim adoRS As New Recordset
Me.MousePointer = vbHourglass
Set adoRS = m_objAgreeDetail.RETRIEVE(boADRetPartDivAwards, _
m_objAgreeDetail.AgreeNo, , _
m_objAgreeDetail.PartNo)
Set grdContract1.DataSource = adoRS
grdContract1.ColWidth(0) = 1000
'grdContract1.ColWidth(1) = 1100
grdContract1.TextMatrix(0, 0) = "Div Code"
grdContract1.TextMatrix(0, 1) = "Award Qty"
grdContract1.Cell(flexcpFontBold, 0, 0, 0, 1) = True
Set adoRS = Nothing
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Set adoRS = Nothing
Me.MousePointer = vbNormal
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub grdForecast1_Click()
Dim strTemp As String
Call m_frmParent.ZOrder(0)
FMain.staMain.Panels(1).Text = ""
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
If (grdForecast1.Row = 0 Or grdForecast1.Rows <= 1) Then
Exit Sub
End If
Me.MousePointer = vbHourglass
On Error GoTo ERR_ROUTINE
m_objAgreeDetail.Level = boADPartDivLevel
m_objAgreeDetail.NegCode = cboNeg.Text
m_objAgreeDetail.AgreeNo = cboAgree.Text
m_objAgreeDetail.PartNo = txtPart1
m_objAgreeDetail.SupCode = cboAgree.Columns(1).Text
m_objAgreeDetail.CompGroupCode = txtCompGroupCode1
m_objAgreeDetail.DivCode = grdForecast1.TextMatrix(grdForecast1.Row, 0)
If m_objAgreeDetail.Create = 0 Then
FMain.staMain.Panels(1).Text = "Unable to Add Division"
Exit Sub
End If
strTemp = grdForecast1.TextMatrix(grdForecast1.Row, 0) & _
vbTab & _
grdForecast1.TextMatrix(grdForecast1.Row, 1)
grdForecast1.RemoveItem (grdForecast1.Row)
With grdContract1
.AddItem strTemp
.Select 0, 0
.ColSort(0) = flexSortGenericAscending
.Sort = flexSortUseColSort
End With
txtDiv2.Text = m_objAgreeDetail.DivCode
FMain.staMain.Panels(1).Text = "Add Division Successful"
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Call MsgBox("Unable to Add Division. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Error")
Me.MousePointer = vbNormal
End Sub
Private Sub grdContract1_Click()
Dim strTemp As String
Call m_frmParent.ZOrder(0)
FMain.staMain.Panels(1).Text = ""
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
If (grdContract1.Row = 0 Or grdContract1.Rows <= 1) Then
Exit Sub
End If
On Error GoTo ERR_ROUTINE
Me.MousePointer = vbHourglass
m_objAgreeDetail.Level = boADPartDivLevel
m_objAgreeDetail.AgreeNo = cboAgree.Text
m_objAgreeDetail.PartNo = txtPart1
m_objAgreeDetail.DivCode = grdContract1.TextMatrix(grdContract1.Row, 0)
If m_objAgreeDetail.Delete = 0 Then
FMain.staMain.Panels(1).Text = "Unable to Delete Division"
Exit Sub
End If
strTemp = grdContract1.TextMatrix(grdContract1.Row, 0) & _
vbTab & _
grdContract1.TextMatrix(grdContract1.Row, 1)
grdContract1.RemoveItem (grdContract1.Row)
With grdForecast1
.AddItem strTemp
.Select 0, 0
.ColSort(0) = flexSortGenericAscending
.Sort = flexSortUseColSort
End With
txtDiv2.Text = ""
FMain.staMain.Panels(1).Text = "Delete Division Successful"
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Call MsgBox("Unable to Delete Division. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Error")
Me.MousePointer = vbNormal
End Sub
Private Sub cmdAddDiv1_Click()
Dim strDiv As String
Dim strTemp As String
Call m_frmParent.ZOrder(0)
FMain.staMain.Panels(1).Text = ""
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
Me.MousePointer = vbHourglass
On Error GoTo ERR_ROUTINE
strDiv = txtDiv1
If strDiv = "" Then
Call MsgBox("Division Code is required. " & vbCrLf & _
"", vbExclamation & vbOKOnly, "AddDiv1")
Me.MousePointer = vbNormal
Exit Sub
End If
m_objAgreeDetail.Level = boADPartDivLevel
m_objAgreeDetail.NegCode = cboNeg.Text
m_objAgreeDetail.AgreeNo = cboAgree.Text
m_objAgreeDetail.PartNo = txtPart1
m_objAgreeDetail.SupCode = cboAgree.Columns(1).Text
m_objAgreeDetail.CompGroupCode = txtCompGroupCode1
m_objAgreeDetail.DivCode = strDiv
If m_objAgreeDetail.Create = 0 Then
FMain.staMain.Panels(1).Text = "Unable to Add Division"
Exit Sub
End If
strTemp = strDiv & vbTab & "0"
With grdContract1
.AddItem strTemp
.Select 0, 0
.ColSort(0) = flexSortGenericAscending
.Sort = flexSortUseColSort
End With
txtDiv2.Text = m_objAgreeDetail.DivCode
FMain.staMain.Panels(1).Text = "Add Division Successful"
txtDiv1.Text = ""
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
If Err.Number = boADErrorRequired Then
Call MsgBox("Unable to Add Division. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Required Data Missing")
ElseIf Err.Number = boADErrorValidation Then
Call MsgBox("Unable to Add Division. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Data Validation Error")
ElseIf Err.Number = dbErrDuplicate Then
Call MsgBox("Unable to Add Division. " & vbCrLf & vbCrLf & "The Division already exists and cannot be duplicated.", vbOKOnly, "Duplicate Division")
Else
Call MsgBox("Unable to Add Division. " & vbCrLf & vbCrLf & VBA.Err.Description, vbOKOnly, "Error")
End If
Me.MousePointer = vbNormal
End Sub
Private Sub cmdAddPart1_Click()
Dim strMessage As String
Dim strSelcode As String
Dim strPassSelcode As String
Dim strCompSelcode As String
Dim strCompGroupCode As String
Dim strCompGroupName As String
Dim strCompGroupSelcode As String
Dim strNewItem As String
Dim Match As Boolean
Dim count As Integer
Dim i As Integer
Dim j As Integer
Dim adoRS As New Recordset
Dim strSQL As String
Call m_frmParent.ZOrder(0)
ADD_PART:
On Error GoTo ERR_PART
Me.MousePointer = vbHourglass
FMain.staMain.Panels(1).Text = ""
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
If ValidatePart1 > 0 Then
FMain.staMain.Panels(1).Text = "Unable to Add. Check required fields in red."
GoTo SUBEND
End If
DoEvents
m_objAgreeDetail.Level = boADPartLevel
Call m_objAgreeDetail.Create
DoEvents
FMain.staMain.Panels(1).Text = "Add Successful."
cmdGetData1_Click
GoTo SUBEND
ADD_COMP_GROUP:
strMessage = "No matching Component Group on this Agreement for this part." & vbCrLf & vbCrLf & _
"Do you want to add a Component Group?" & vbCrLf & vbCrLf
If MsgBox(strMessage, vbYesNo, "Add Component Group") = vbNo Then
GoTo SUBEND
End If
On Error GoTo ERR_COMP_GROUP
Set m_objPart = New CPart
Set adoRS = m_objPart.RETRIEVE(boPartByPart, txtPart1)
Set m_objPart = Nothing
If adoRS.RecordCount = 0 Then
Call MsgBox("That is not a valid part. " & vbCrLf & _
"", vbExclamation & vbOKOnly, "AddPart1")
GoTo SUBEND
End If
strSelcode = Left(adoRS.Fields("selcode") & " ", 20)
Set m_frmAddCompGroup = New frmAddCompGroup
m_frmAddCompGroup.AgreeNo = cboAgree.Text
m_frmAddCompGroup.Selcode = strSelcode
m_frmAddCompGroup.Show (vbModal)
strCompGroupCode = m_frmAddCompGroup.CompGroupCode
strCompGroupName = m_frmAddCompGroup.CompGroupName
Set m_frmAddCompGroup = Nothing
If strCompGroupCode = "" Then
Call MsgBox("Component Group is required. " & vbCrLf & _
"", vbExclamation & vbOKOnly, "AddPart1")
GoTo SUBEND
End If
txtCompGroup1.Text = strCompGroupName
GoTo ADD_PART
SUBEND:
Me.MousePointer = vbNormal
Exit Sub
ERR_PART:
If Err.Number = boADErrorRequired Then
Call MsgBox("Unable to Add Part. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Required Data Missing")
ElseIf Err.Number = boADErrorValidation Then
Call MsgBox("Unable to Add Part. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Data Validation Error")
ElseIf Err.Number = dbErrDuplicate Then
Call MsgBox("Unable to Add Part. " & vbCrLf & vbCrLf & "The Part already exists and cannot be duplicated.", vbOKOnly, "Duplicate Part")
ElseIf Err.Number = boADErrorNoCompGroup Then
GoTo ADD_COMP_GROUP
Else
Call MsgBox("Unable to Add Part. " & vbCrLf & vbCrLf & VBA.Err.Description, vbOKOnly, "Error")
End If
Me.MousePointer = vbNormal
Exit Sub
ERR_COMP_GROUP:
Set m_objCompGroup = Nothing
If Err.Number = boADErrorRequired Then
Call MsgBox("Unable to Add Comp Group. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Required Data Missing")
ElseIf Err.Number = boADErrorValidation Then
Call MsgBox("Unable to Add Comp Group. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Data Validation Error")
ElseIf Err.Number = dbErrDuplicate Then
Call MsgBox("Unable to Add Comp Group. " & vbCrLf & vbCrLf & "The Comp Group already exists and cannot be duplicated.", vbOKOnly, "Duplicate Component Group")
Else
Call MsgBox("Unable to Add Comp Group. " & vbCrLf & vbCrLf & VBA.Err.Description, vbOKOnly, "Error")
End If
Me.MousePointer = vbNormal
End Sub
Private Sub cmdDeletePart1_Click()
Dim strMessage As String
Call m_frmParent.ZOrder(0)
On Error GoTo ERR_ROUTINE
FMain.staMain.Panels(1).Text = ""
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
Me.MousePointer = vbHourglass
If ValidatePart1 > 0 Then
FMain.staMain.Panels(1).Text = "Unable to Delete."
GoTo ENDSUB
End If
strMessage = "Are you sure you want to delete " & vbCrLf & vbCrLf & _
"Part : " & m_objAgreeDetail.PartNo & "?" & vbCrLf & vbCrLf
If MsgBox(strMessage, vbYesNo, "Confirm Delete") = vbNo Then GoTo ENDSUB
m_objAgreeDetail.Level = boADPartLevel
If m_objAgreeDetail.Delete = 0 Then
Call MsgBox("Proc Team Code not found.", _
vbExclamation & vbOKOnly, "Unable to Delete")
Else
DoEvents
Call ClearFields1
Call cmdClear2_Click
FMain.staMain.Panels(1).Text = "Delete Successful."
End If
ENDSUB:
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Call MsgBox("Unable to Delete. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Error")
Me.MousePointer = vbNormal
End Sub
Private Function ValidatePart1() As Integer
Dim lbl As Label
Dim intInvalidCount As Integer
Dim objFirstInvalid As Control
txtPart1.ForeColor = vbBlack
txtPart1.ToolTipText = ""
For Each lbl In lblLabel1
lbl.ForeColor = vbBlack
Next
On Error GoTo ERR_TXT
m_objAgreeDetail.AgreeNo = cboAgree
m_objAgreeDetail.Level = boADPartLevel
m_objAgreeDetail.PartNo = txtPart1
ValidatePart1 = intInvalidCount
Exit Function
ERR_TXT:
'Validation error routine for text boxes.
If Err.Number = boADErrorValidation _
Or Err.Number = boADErrorRequired Then
'Set tool tip and text red.
txtPart1.ToolTipText = Err.Description
txtPart1.ForeColor = vbRed
lblLabel1(0).ForeColor = vbRed
intInvalidCount = intInvalidCount + 1
Else
Call Err.Raise(VBA.Err.Number, VBA.Err.Source, VBA.Err.Description)
End If
Err.Clear
Resume Next
End Function
'
' Code for Contract Data Tab (2)
'
Private Sub PopulatePrice()
Dim txt As TextBox
Dim strAgree As String
Dim strCompGroup As String
Dim strPart As String
Dim strDiv As String
Dim strLevel As String
If m_blnBeenOnTab2 = False Then
m_blnBeenOnTab2 = True
PopulateLevel2
txtPart2.MaxLength = CallByName(m_objAgreeDetail, "MaxLength", VbMethod, txtPart2.Tag)
txtDiv2.MaxLength = CallByName(m_objAgreeDetail, "MaxLength", VbMethod, txtDiv2.Tag)
For Each txt In txtText2
txt.MaxLength = CallByName(m_objAgreeDetail, "MaxLength", VbMethod, txt.Tag)
Next
End If
strAgree = cboAgree.Text
If strAgree = "" Then
cmdClear2_Click
m_strAgree2 = strAgree
Exit Sub
End If
m_objAgreement.AgreeNo = cboAgree.Text
strLevel = cboLevel2.Value
strCompGroup = cboCompGroup2.Columns(0).Value
strPart = txtPart2
strDiv = txtDiv2
If strAgree <> m_strAgree2 Then
m_strAgree2 = strAgree
ClearBottom2
SetButtons2
PopulateCompGroup2 (strAgree)
End If
If strLevel = "" Then
GoTo SUBEND
End If
Select Case strLevel
Case lvlAgreement
cmdGetData2_Click
Case lvlCompGroup
If strCompGroup <> "" Then
cmdGetData2_Click
Else
ClearBottom2
End If
Case lvlPart
If strPart <> "" Then
cmdGetData2_Click
End If
Case lvlDivision
If strPart <> "" Then
If strDiv <> "" Then
cmdGetData2_Click
Else
ClearBottom2
End If
Else
ClearBottom2
End If
End Select
SUBEND:
If strLevel = "" Then
cboLevel2.SetFocus
Else
Select Case strLevel
Case lvlAgreement
cboLevel2.SetFocus
Case lvlCompGroup
cboCompGroup2.SetFocus
Case lvlPart
txtPart2.SetFocus
Case lvlDivision
If strPart <> "" Then
txtDiv2.SetFocus
Else
txtPart2.SetFocus
End If
End Select
End If
End Sub
Private Sub PopulateLevel2()
Dim adoRS As New Recordset
'Populate Level Combo
Set adoRS = m_objAgreeDetail.RetrieveLevels
Set cboLevel2.DataSource = adoRS
Set cboLevel2.DataSourceList = adoRS
cboLevel2.DataFieldList = adoRS.Fields(0).Name
cboLevel2.DataFieldToDisplay = adoRS.Fields(1).Name
cboLevel2.Value = ""
Set adoRS = Nothing
End Sub
Private Sub cboLevel2_InitColumnProps()
cboLevel2.Columns(0).Visible = True 'Agreement Levels
cboLevel2.Columns(1).Visible = True
cboLevel2.Columns(0).Width = 275
cboLevel2.Columns(1).Width = 1750
End Sub
Private Sub cboLevel2_Click()
On Error GoTo ERR_ROUTINE
Dim strAgree As String
Dim strCompGroup As String
Dim strPart As String
Dim strDiv As String
Dim strLevel As String
Call m_frmParent.ZOrder(0)
strLevel = cboLevel2.Columns(0).Value
m_objAgreeDetail.Level = strLevel
strCompGroup = cboCompGroup2.Value
strPart = txtPart2
strDiv = txtDiv2
ClearBottom2
Select Case strLevel
Case lvlAgreement
lblCompGroup2.Visible = False
lblPart2.Visible = False
lblDiv2.Visible = False
cboCompGroup2.Visible = False
txtPart2.Visible = False
txtDiv2.Visible = False
lblLabel2(0).Visible = False 'Price
txtText2(0).Visible = False 'Price
lblLabel2(5).Caption = "Percent Share"
txtText2(5).Enabled = True
txtText2(6).Visible = False
txtText2(7).Visible = False
txtText2(8).Visible = False
txtText2(9).Visible = False
lblLabel2(6).Visible = False
txtText2(13).Visible = False
cmdGetData2_Click
'txtText2(1).SetFocus
Case lvlCompGroup
lblCompGroup2.Visible = True
lblPart2.Visible = False
lblDiv2.Visible = False
cboCompGroup2.Visible = True
txtPart2.Visible = False
txtDiv2.Visible = False
lblLabel2(0).Visible = True 'Price
txtText2(0).Visible = True 'Price
lblLabel2(5).Caption = "Percent Share"
txtText2(5).Enabled = True
txtText2(6).Visible = False
txtText2(7).Visible = False
txtText2(8).Visible = False
txtText2(9).Visible = False
lblLabel2(6).Visible = False
txtText2(13).Visible = False
If strCompGroup <> "" Then
cmdGetData2_Click
Else
cboCompGroup2.SetFocus
End If
Case lvlPart
lblCompGroup2.Visible = False
lblPart2.Visible = True
lblDiv2.Visible = False
cboCompGroup2.Visible = False
txtPart2.Visible = True
txtDiv2.Visible = False
lblLabel2(0).Visible = True 'Price
txtText2(0).Visible = True 'Price
lblLabel2(5).Caption = "Percent Share"
txtText2(5).Enabled = True
txtText2(6).Visible = False
txtText2(7).Visible = False
txtText2(8).Visible = False
txtText2(9).Visible = False
lblLabel2(6).Visible = False
txtText2(13).Visible = False
If strPart <> "" Then
cmdGetData2_Click
Else
txtPart2.SetFocus
End If
Case lvlDivision
lblCompGroup2.Visible = False
lblPart2.Visible = True
lblDiv2.Visible = True
cboCompGroup2.Visible = False
txtPart2.Visible = True
txtDiv2.Visible = True
lblLabel2(0).Visible = True 'Price
txtText2(0).Visible = True 'Price
lblLabel2(5).Caption = "Award Percent"
txtText2(5).Enabled = False
txtText2(6).Visible = True
txtText2(7).Visible = True
txtText2(8).Visible = True
txtText2(9).Visible = True
If strPart <> "" Then
If strDiv <> "" Then
cmdGetData2_Click
Else
txtDiv2.SetFocus
ClearBottom2
End If
Else
txtPart2.SetFocus
End If
If StrComp(m_strCommitmentType, "Q", vbBinaryCompare) = 0 Then
lblLabel2(6).Visible = True
txtText2(13).Visible = True
Else
lblLabel2(6).Visible = False
txtText2(13).Visible = False
End If
End Select
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub PopulateCompGroup2(strAgree As String)
Dim adoRS As New Recordset
If strAgree = "" Then
Exit Sub
End If
'Populate Component Group Combo
Set adoRS = m_objAgreeDetail.RETRIEVE(boADRetCompGroupByAgreeNo, strAgree)
Set cboCompGroup2.DataSourceList = adoRS
cboCompGroup2.DataFieldList = adoRS.Fields(0).Name
cboCompGroup2.DataFieldToDisplay = adoRS.Fields(1).Name
Set adoRS = Nothing
End Sub
Private Sub cboCompGroup2_InitColumnProps()
cboCompGroup2.Columns(0).Visible = False 'Component Group Code
cboCompGroup2.Columns(1).Visible = True 'Comp Group Name
cboCompGroup2.Columns(1).Width = 3100
End Sub
Private Sub cboCompGroup2_Click()
Call m_frmParent.ZOrder(0)
If cboCompGroup2.Value <> "" Then
cmdGetData2_Click
End If
End Sub
Private Sub SetButtons2()
If Trim(g_objApp.User.EmployeeCode) = Trim(m_objAgreement.CreatedBy) _
Or g_objApp.User.EmployeeCode = "77777777" Then
cmdUpdate2.Enabled = True
fraPrice2.Enabled = True
Else
cmdUpdate2.Enabled = False
cmdUpdate2.Enabled = False
End If
End Sub
Private Sub cmdClear2_Click()
On Error GoTo ERR_ROUTINE
Call m_frmParent.ZOrder(0)
Me.MousePointer = vbHourglass
Call ClearTop2
Call ClearBottom2
cboLevel2.Value = ""
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Me.MousePointer = vbNormal
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub ClearTop2()
On Error GoTo ERR_ROUTINE
Dim txt As TextBox
Dim lbl As Label
Dim opt As OptionButton
FMain.staMain.Panels(1).Text = ""
cboCompGroup2.Value = ""
txtPart2.Text = ""
txtDiv2.Text = ""
lblNeg.ForeColor = vbBlack
lblAgree.ForeColor = vbBlack
lblLevel2.ForeColor = vbBlack
lblCompGroup2.ForeColor = vbBlack
lblPart2.ForeColor = vbBlack
lblDiv2.ForeColor = vbBlack
cboNeg.ToolTipText = ""
cboAgree.ToolTipText = ""
cboLevel2.ToolTipText = ""
cboCompGroup2.ToolTipText = ""
txtPart2.ToolTipText = ""
txtDiv2.ToolTipText = ""
cboNeg.ForeColor = vbBlack
cboAgree.ForeColor = vbBlack
cboLevel2.ForeColor = vbBlack
cboCompGroup2.ForeColor = vbBlack
txtPart2.ForeColor = vbBlack
txtDiv2.ForeColor = vbBlack
lblCompGroup2.Visible = False
lblPart2.Visible = False
lblDiv2.Visible = False
cboCompGroup2.Visible = False
txtPart2.Visible = False
txtDiv2.Visible = False
cboLevel2.SetFocus
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub ClearBottom2()
On Error GoTo ERR_ROUTINE
Dim txt As TextBox
Dim lbl As Label
Dim opt As OptionButton
FMain.staMain.Panels(1).Text = ""
fraPrice2.Visible = False
For Each txt In txtText2
txt.Text = ""
txt.ForeColor = vbBlack
txt.ToolTipText = ""
Next
For Each lbl In lblLabel2
lbl.ForeColor = vbBlack
Next
For Each opt In optLeadTimeUOM
opt.Value = False
Next
For Each opt In optMinUOM
opt.Value = False
Next
For Each opt In optMultUOM
opt.Value = False
Next
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub txtPart2_KeyPress(KeyAscii As Integer)
On Error GoTo ERR_ROUTINE
If KeyAscii = 13 Then
cmdGetData2_Click
End If
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub txtdiv2_KeyPress(KeyAscii As Integer)
On Error GoTo ERR_ROUTINE
If KeyAscii = 13 Then
cmdGetData2_Click
End If
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub cmdGetData2_Click()
Dim strLevel As String
Dim strLevelText As String
Call m_frmParent.ZOrder(0)
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
lblCompGroup2.ForeColor = vbBlack
With cboCompGroup2
.ForeColor = vbBlack
.ToolTipText = Err.Description
End With
lblPart2.ForeColor = vbBlack
With txtPart2
.ForeColor = vbBlack
.ToolTipText = Err.Description
End With
lblDiv2.ForeColor = vbBlack
With txtDiv2
.ForeColor = vbBlack
.ToolTipText = Err.Description
End With
strLevelText = cboLevel2.Text
If strLevelText = "" Then
cboLevel2.SetFocus
Err.Raise boADerrornoLevel, "Level Validation", "Level is required"
End If
ClearBottom2
On Error GoTo ERR_RETRIEVE
strLevel = cboLevel2.Columns(0).Value
Select Case strLevel
Case lvlAgreement
GetAgreement2
Case lvlCompGroup
GetCompGroup2
Case lvlPart
GetPart2
Case lvlDivision
GetDivision2
End Select
DisplayUOMs
fraPrice2.Visible = True
SUBEND:
Me.MousePointer = vbNormal
Exit Sub
ERR_LEVEL:
If Err.Number = boADerrornoLevel Then
lblLevel2.ForeColor = vbRed
With cboLevel2
.SetFocus
.ForeColor = vbRed
.ToolTipText = Err.Description
End With
cboLevel2.SetFocus
Else
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End If
Me.MousePointer = vbNormal
cboNeg.SetFocus
Exit Sub
ERR_RETRIEVE:
If Err.Number = boADErrorRequired _
Or Err.Number = boADErrorValidation Then
Select Case strLevel
Case lvlAgreement
lblAgree.ForeColor = vbRed
With cboAgree
.SetFocus
.ForeColor = vbRed
.ToolTipText = Err.Description
End With
Case lvlCompGroup
lblCompGroup2.ForeColor = vbRed
With cboCompGroup2
.SetFocus
.ForeColor = vbRed
.ToolTipText = Err.Description
End With
Case lvlPart
lblPart2.ForeColor = vbRed
With txtPart2
.SetFocus
.ForeColor = vbRed
.ToolTipText = Err.Description
End With
Case lvlDivision
lblPart2.ForeColor = vbRed
With txtPart2
.SetFocus
.ForeColor = vbRed
.ToolTipText = Err.Description
End With
lblDiv2.ForeColor = vbRed
With txtDiv2
.SetFocus
.ForeColor = vbRed
.ToolTipText = Err.Description
End With
End Select
Else
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End If
Me.MousePointer = vbNormal
End Sub
Private Sub DisplayUOMs()
If txtText2(10) = "W" Then
optLeadTimeUOM(0).Value = True
End If
If txtText2(10) = "D" Then
optLeadTimeUOM(1).Value = True
End If
If Left(txtText2(11), 1) = "P" Then
optMinUOM(0).Value = True
End If
If Left(txtText2(11), 1) = "$" Then
optMinUOM(1).Value = True
End If
If Left(txtText2(12), 1) = "P" Then
optMultUOM(0).Value = True
End If
If Left(txtText2(12), 1) = "$" Then
optMultUOM(1).Value = True
End If
End Sub
Private Sub GetAgreement2()
On Error GoTo ERR_RETRIEVE
Dim txt As TextBox
Dim adoRS As New Recordset
Set adoRS = m_objAgreeDetail.RETRIEVE(boADRetDetailByAgreeNo, m_objAgreeDetail.AgreeNo)
If adoRS.RecordCount = 0 Then
Set adoRS = Nothing
MsgBox "Agreement not found."
Exit Sub
End If
For Each txt In txtText2
txt.Text = CallByName(m_objAgreeDetail, txt.Tag, VbGet)
Next
Set adoRS = Nothing
Me.MousePointer = vbNormal
Exit Sub
ERR_RETRIEVE:
Set adoRS = Nothing
Me.MousePointer = vbNormal
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub GetCompGroup2()
On Error GoTo ERR_RETRIEVE
Dim txt As TextBox
Dim adoRS As New Recordset
m_objAgreeDetail.CompGroupCode = cboCompGroup2.Columns(0).Value
Set adoRS = m_objAgreeDetail.RETRIEVE(boADRetDetailByAgreeCompGroup, _
m_objAgreeDetail.AgreeNo, _
m_objAgreeDetail.CompGroupCode)
If adoRS.RecordCount = 0 Then
Set adoRS = Nothing
MsgBox "That Component Group was not found for this Agreement."
Exit Sub
End If
For Each txt In txtText2
txt.Text = CallByName(m_objAgreeDetail, txt.Tag, VbGet)
Next
Set adoRS = Nothing
Me.MousePointer = vbNormal
Exit Sub
ERR_RETRIEVE:
Set adoRS = Nothing
Me.MousePointer = vbNormal
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub GetPart2()
On Error GoTo ERR_RETRIEVE
Dim txt As TextBox
Dim adoRS As New Recordset
m_objAgreeDetail.PartNo = txtPart2.Text
txtPart1.Text = txtPart2.Text
Set adoRS = m_objAgreeDetail.RETRIEVE(boADRetDetailByAgreePart, _
m_objAgreeDetail.AgreeNo, , _
m_objAgreeDetail.PartNo)
If adoRS.RecordCount = 0 Then
Set adoRS = Nothing
MsgBox "That Part was not found for this Agreement."
Exit Sub
End If
For Each txt In txtText2
txt.Text = CallByName(m_objAgreeDetail, txt.Tag, VbGet)
Next
Set adoRS = Nothing
Me.MousePointer = vbNormal
Exit Sub
ERR_RETRIEVE:
Set adoRS = Nothing
Me.MousePointer = vbNormal
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub GetDivision2()
On Error GoTo ERR_RETRIEVE
Dim txt As TextBox
Dim adoRS As New Recordset
m_objAgreeDetail.PartNo = txtPart2.Text
m_objAgreeDetail.DivCode = txtDiv2.Text
txtPart1.Text = txtPart2.Text
Set adoRS = m_objAgreeDetail.RETRIEVE(boADRetDetailByAgreePartDiv, _
m_objAgreeDetail.AgreeNo, , _
m_objAgreeDetail.PartNo, _
m_objAgreeDetail.DivCode)
If adoRS.RecordCount = 0 Then
Set adoRS = Nothing
MsgBox "That Part/Division was not found for this Agreement."
Exit Sub
End If
For Each txt In txtText2
txt.Text = CallByName(m_objAgreeDetail, txt.Tag, VbGet)
Next
Set adoRS = Nothing
Me.MousePointer = vbNormal
Exit Sub
ERR_RETRIEVE:
Set adoRS = Nothing
Me.MousePointer = vbNormal
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub cmdUpdate2_Click()
Dim strLevel As String
Dim vntPrice As Variant
Dim vntLeadTime As Variant
Dim strLeadTimeUOM As String
Dim strComments As String
Dim strMessage As String
Dim vntAwardQty As Variant
Call m_frmParent.ZOrder(0)
If Edit_Neg > 0 Then
Exit Sub
End If
If Edit_Agree > 0 Then
Exit Sub
End If
On Error GoTo ERR_ROUTINE
Me.MousePointer = vbHourglass
FMain.staMain.Panels(1).Text = ""
strLevel = m_objAgreeDetail.Level
vntPrice = txtText2(0)
If (vntPrice <> "" And vntPrice <> " ") Then
If vntPrice > 100 Then
strMessage = "Price is greater than $100. Is that OK?"
If MsgBox(strMessage, vbYesNo, "Verify Price") = vbNo Then
GoTo SUBEND
End If
End If
End If
vntLeadTime = txtText2(1)
strLeadTimeUOM = txtText2(10)
If (vntLeadTime <> "" And vntLeadTime <> " ") Then
If (vntLeadTime > 26 And strLeadTimeUOM = "W") _
Or (vntLeadTime > 130 And strLeadTimeUOM = "D") Then
strMessage = "Lead Time is greater than 6 months. Is that OK?"
If MsgBox(strMessage, vbYesNo, "Verify Lead Time") = vbNo Then
GoTo SUBEND
End If
End If
End If
strComments = txtText2(4)
If (Len(strComments) > 30) _
And (strLevel <> "1") Then
strMessage = "Promis Comments will be truncated to 30 characters." & vbCrLf & _
" Only the first 15 characters will be downloaded. Is that OK?"
If MsgBox(strMessage, vbYesNo, "Verify Primis Comments") = vbNo Then
GoTo SUBEND
End If
End If
DoEvents
If ValidateAll2 > 0 Then
FMain.staMain.Panels(1).Text = "Unable to Update. Check fields in red."
GoTo SUBEND
End If
DoEvents
If m_objAgreeDetail.Update(boADUpdtDetailNormal) = 0 Then
Call MsgBox("Unable to Update. " & vbCrLf & _
"", vbExclamation & vbOKOnly, "Unable to Update.")
Else
cboLevel2.SetFocus
FMain.staMain.Panels(1).Text = "Update Successful."
End If
If strLevel = "4" Then
If StrComp(m_strCommitmentType, "Q", vbBinaryCompare) = 0 Then
If m_objAgreeDetail.Update(boADUpdtDetailAwardQty) = 0 Then
Call MsgBox("Unable to Update Award Qty. " & vbCrLf & _
"", vbExclamation & vbOKOnly, "Unable to Update.")
End If
End If
cmdGetData2_Click
FMain.staMain.Panels(1).Text = "Update Successful."
End If
SUBEND:
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
If Err.Number = boADErrorRequired Then
Call MsgBox("Unable to Update. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Required Data Missing")
ElseIf Err.Number = boADErrorValidation Then
Call MsgBox("Unable to Update. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Data Validation Error")
Else
Call MsgBox("Unable to Update. " & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Error")
End If
Me.MousePointer = vbNormal
End Sub
Private Function ValidateAll2() As Integer
Dim txt As TextBox
Dim opt As OptionButton
Dim lbl As Label
Dim intInvalidCount As Integer
Dim objFirstInvalid As Control
Dim strLevel As String
Dim strCompGroup As String
Dim strPart As String
Dim strDiv As String
Dim blnLevel4Error As Boolean
lblNeg.ForeColor = vbBlack
lblAgree.ForeColor = vbBlack
lblLevel2.ForeColor = vbBlack
lblCompGroup2.ForeColor = vbBlack
lblPart2.ForeColor = vbBlack
lblDiv2.ForeColor = vbBlack
cboNeg.ToolTipText = ""
cboAgree.ToolTipText = ""
cboLevel2.ToolTipText = ""
cboCompGroup2.ToolTipText = ""
txtPart2.ToolTipText = ""
txtDiv2.ToolTipText = ""
cboNeg.ForeColor = vbBlack
cboAgree.ForeColor = vbBlack
cboLevel2.ForeColor = vbBlack
cboCompGroup2.ForeColor = vbBlack
txtPart2.ForeColor = vbBlack
txtDiv2.ForeColor = vbBlack
strLevel = m_objAgreeDetail.Level
strCompGroup = cboCompGroup2.Value
strPart = txtPart2
strDiv = txtDiv2
For Each txt In txtText2
txt.ForeColor = vbBlack
txt.ToolTipText = ""
Next
For Each lbl In lblLabel2
lbl.ForeColor = vbBlack
Next
If strLevel = "" Then
cboLevel2.ToolTipText = "Please select a Level."
cboLevel2.ForeColor = vbRed
lblLevel2.ForeColor = vbRed
cboLevel2.SetFocus
ValidateAll2 = 1
Exit Function
Else
m_objAgreeDetail.Level = strLevel
End If
If strLevel = "2" Then
If strCompGroup = "" Then
cboCompGroup2.ToolTipText = "Please select a Component Group."
cboCompGroup2.ForeColor = vbRed
lblCompGroup2.ForeColor = vbRed
cboCompGroup2.SetFocus
ValidateAll2 = 1
Exit Function
Else
m_objAgreeDetail.CompGroupCode = cboCompGroup2.Columns(0).Value
End If
End If
If strLevel = "3" Then
If strPart = "" Then
txtPart2.ToolTipText = "Part Number is required."
txtPart2.ForeColor = vbRed
lblPart2.ForeColor = vbRed
txtPart2.SetFocus
ValidateAll2 = 1
Exit Function
Else
m_objAgreeDetail.PartNo = strPart
End If
End If
If strLevel = "4" Then
blnLevel4Error = False
If strDiv = "" Then
txtDiv2.ToolTipText = "Division is required."
txtDiv2.ForeColor = vbRed
lblDiv2.ForeColor = vbRed
txtDiv2.SetFocus
blnLevel4Error = True
Else
m_objAgreeDetail.DivCode = strDiv
End If
If strPart = "" Then
txtPart2.ToolTipText = "Part Number is required."
txtPart2.ForeColor = vbRed
lblPart2.ForeColor = vbRed
txtPart2.SetFocus
blnLevel4Error = True
Else
m_objAgreeDetail.PartNo = strPart
End If
If blnLevel4Error = True Then
ValidateAll2 = 1
Exit Function
End If
End If
On Error GoTo ERR_TXT
For Each txt In txtText2
Call CallByName(m_objAgreeDetail, txt.Tag, VbLet, txt.Text)
Next
ValidateAll2 = intInvalidCount
'Set focus to first invalid control
If Not objFirstInvalid Is Nothing Then
objFirstInvalid.SetFocus
End If
Exit Function
ERR_TXT:
If Err.Number = boADErrorValidation _
Or Err.Number = boADErrorRequired Then
'Set tool tip and text red.
txt.ToolTipText = Err.Description
txt.ForeColor = vbRed
lblLabel0(txt.Index).ForeColor = vbRed
intInvalidCount = intInvalidCount + 1
If objFirstInvalid Is Nothing Then
Set objFirstInvalid = txt
Else
If txt.tabIndex < objFirstInvalid.tabIndex Then
Set objFirstInvalid = txt
End If
End If
Else
Call Err.Raise(VBA.Err.Number, VBA.Err.Source, VBA.Err.Description)
End If
Err.Clear
Resume Next
End Function
Private Sub optLeadTimeUOM_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
If Index = 0 Then
txtText2(10) = "W"
Else
txtText2(10) = "D"
End If
End Sub
Private Sub optMinUOM_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
If Index = 0 Then
txtText2(11) = "PC/LI/SH"
Else
txtText2(11) = "$/LI/SH"
End If
End Sub
Private Sub optMultUOM_Click(Index As Integer)
Call m_frmParent.ZOrder(0)
If Index = 0 Then
txtText2(12) = "PC/LI/SH"
Else
txtText2(12) = "$/LI/SH"
End If
End Sub
Private Function Edit_Neg() As Integer
On Error GoTo ERR_NEG
Edit_Neg = 0
m_objAgreeDetail.NegCode = cboNeg.Text
m_objAgreement.NegCode = cboNeg.Text
Exit Function
ERR_NEG:
Edit_Neg = 1
If Err.Number = boADErrorRequired _
Or Err.Number = boADErrorValidation Then
lblNeg.ForeColor = vbRed
With cboNeg
.SetFocus
.ForeColor = vbRed
.ToolTipText = Err.Description
End With
cboNeg.SetFocus
Else
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End If
cboNeg.SetFocus
End Function
Private Function Edit_Agree() As Integer
On Error GoTo ERR_AGREE
Edit_Agree = 0
m_objAgreeDetail.AgreeNo = cboAgree.Text
m_objAgreement.AgreeNo = cboAgree.Text
lblAgree.ForeColor = vbBlack
With cboAgree
.ForeColor = vbBlack
.ToolTipText = Err.Description
End With
Exit Function
ERR_AGREE:
Edit_Agree = 1
If Err.Number = boADErrorRequired _
Or Err.Number = boADErrorValidation Then
lblAgree.ForeColor = vbRed
With cboAgree
.SetFocus
.ForeColor = vbRed
.ToolTipText = Err.Description
End With
Else
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End If
Me.MousePointer = vbNormal
cboAgree.SetFocus
End Function
Private Sub cmdClear3_Click()
On Error GoTo ERR_ROUTINE
Dim lbl As Label
FMain.staMain.Panels(1).Text = ""
With txtAgree3
.Text = ""
.ForeColor = vbBlack
.ToolTipText = ""
End With
With txtSup3
.Text = ""
.ForeColor = vbBlack
.ToolTipText = ""
End With
For Each lbl In lblLabel3
lbl.ForeColor = vbBlack
Next
lblLabel3(2).Caption = ""
Exit Sub
ERR_ROUTINE:
Err.Raise VBA.Err.Number, VBA.Err.Source, VBA.Err.Description
End Sub
Private Sub cmdCopy3_Click()
On Error GoTo ERR_ROUTINE
Dim obj_JobControl As CJobControl
Dim strOutFile As String
Dim strCmdString As String
Dim adoRS As Recordset
Dim strJobControlId As String
Dim strSupCode As String
DoEvents
Call m_frmParent.ZOrder(0)
Me.MousePointer = vbHourglass
If ValidateAll3 > 0 Then
FMain.staMain.Panels(1).Text = "Unable to Copy. Check fields in red."
Exit Sub
End If
Set obj_JobControl = New CJobControl
'Retrieve Output File
Set adoRS = obj_JobControl.RETRIEVE(boJobRetOutputFileByJobId, , CopyAgreeJobId)
strOutFile = adoRS.Fields(0)
strJobControlId = Left(strOutFile, 34)
If txtSup3.Text = "" Then
strSupCode = cboAgree.Columns(1).Value
Else
strSupCode = txtSup3.Text
End If
'Build Command string with parameters
strCmdString = "/macs/scripts/pic4110.job " & _
strOutFile & " '" & _
cboAgree.Text & "' '" & _
txtAgree3.Text & "' '" & _
strSupCode & "' &"
'Submit the Command and Tracking jobs
obj_JobControl.CommandString = strCmdString
obj_JobControl.JobId = CopyAgreeJobId
Call obj_JobControl.Create
FMain.staMain.Panels(1).Text = "Copy agreement job submitted successfully."
Me.MousePointer = vbNormal
EXITSUB:
Set obj_JobControl = Nothing
Me.MousePointer = vbNormal
Exit Sub
ERR_ROUTINE:
Me.MousePointer = vbNormal
Set obj_JobControl = Nothing
Call MsgBox("The Copy Agreement job was not successfully submitted. " & _
vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Unable to Submit Job")
End Sub
Private Sub cmdSearch3_Click()
On Error GoTo ERR_ROUTINE
Me.MousePointer = vbHourglass
Set m_frmSupSearch = New frmSupSearch
With m_frmSupSearch
.SupCode = txtSup3.Text
.Show vbModal, Me
txtSup3.Text = .SupCode
lblLabel3(2).Caption = .SupName
txtSup3.ToolTipText = ""
txtSup3.ForeColor = vbBlack
lblLabel3(2).ForeColor = vbBlack
End With
Set m_frmSupSearch = Nothing
Me.MousePointer = vbNormal
txtSup3.SetFocus
Exit Sub
ERR_ROUTINE:
Set m_frmSupSearch = Nothing
Me.MousePointer = vbNormal
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub txtAgree3_KeyPress(KeyAscii As Integer)
On Error GoTo ERR_ROUTINE
If KeyAscii = 13 Then
Call ValidateAll3
'txtSup3.SetFocus
End If
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Sub txtSup3_KeyPress(KeyAscii As Integer)
On Error GoTo ERR_ROUTINE
If KeyAscii = 13 Then
Call ValidateAll3
End If
Exit Sub
ERR_ROUTINE:
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Sub
Private Function ValidateAll3() As Integer
On Error GoTo ERR_ROUTINE
Dim adoRS As Recordset
lblLabel3(0).ForeColor = vbBlack
txtAgree3.ToolTipText = ""
txtAgree3.ForeColor = vbBlack
lblLabel3(0).ForeColor = vbBlack
lblLabel3(2).Caption = ""
txtSup3.ToolTipText = ""
txtSup3.ForeColor = vbBlack
lblLabel3(1).ForeColor = vbBlack
If Edit_Neg > 0 Then
Exit Function
End If
If Edit_Agree > 0 Then
Exit Function
End If
If txtAgree3.Text = "" Then
lblLabel3(0).ForeColor = vbRed
txtAgree3.ToolTipText = "New Agreement is required."
txtAgree3.ForeColor = vbRed
lblLabel3(0).ForeColor = vbRed
ValidateAll3 = 1
Else
Set adoRS = m_objAgreement.RETRIEVE(boAgreeRetForAgreementUIOnly, txtAgree3.Text)
If Not (adoRS.BOF And adoRS.EOF) Then
lblLabel3(0).ForeColor = vbRed
txtAgree3.ToolTipText = "New Agreement already exists."
txtAgree3.ForeColor = vbRed
lblLabel3(0).ForeColor = vbRed
txtAgree3.SetFocus
ValidateAll3 = 1
End If
Set adoRS = Nothing
End If
If txtSup3.Text <> "" Then
Set m_objSupplier = New CSupplier
Set adoRS = m_objSupplier.RETRIEVE(boSupplierCode, txtSup3.Text)
If Not (adoRS.BOF And adoRS.EOF) Then
lblLabel3(2).Caption = adoRS!sup_name
Else
lblLabel3(2).Caption = ""
txtSup3.ToolTipText = "Supplier is invalid."
txtSup3.ForeColor = vbRed
lblLabel3(1).ForeColor = vbRed
txtSup3.SetFocus
ValidateAll3 = 1
End If
Set adoRS = Nothing
Set m_objSupplier = Nothing
End If
Exit Function
ERR_ROUTINE:
Set adoRS = Nothing
Set m_objSupplier = Nothing
MsgBox VBA.Err.Description, vbOKOnly, VBA.Err.Source
End Function
_________________ CODE ENDS
|
|
|
|
|
Do you really expect someone to read all that code and try and help you?
Try posting only the relevant code.
|
|
|
|
|
General 
News 
Suggestion 
Question 
Bug 
Answer 
Joke 
Praise 
Rant 
Admin 
Submit an article or tip
![Badger | [badger,badger,badger,badger...]](https://www.codeproject.com/script/Forums/Images/badger.gif)
![Jig | [Dance]](https://www.codeproject.com/script/Forums/Images/jig.gif)
![Badger | [badger,badger,badger,badger...]](https://codeproject.global.ssl.fastly.net/script/Forums/Images/badger.gif)
![Jig | [Dance]](https://codeproject.global.ssl.fastly.net/script/Forums/Images/jig.gif)