Update button is greyed out - Visual Basic Discussion Boards

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.

Smile | :)

Luc Pattyn

Badger | [badger,badger,badger,badger...]

Have a look at my entry for the lean-and-mean competition; please provide comments, feedback, discussion, and don’t forget to vote for it! Thank you.

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.

Hi, I can see that this is your first post here so before posting again I would read the message at the top of this board on how to ask a question. You have supplied way too much code here and because it isn't formatted, some people won't even read it.

With regards to your problem, what I suggest you do is place a break point in your code and step through it, checking the conditions that will result in cmdUpdate0.Enabled equalling false.

Absolutely noone is going to look through all that code to try and find out what your problem is. You should only post the RELEVANT portions of code, not the entire fricken' project.

A guide to posting questions on CodeProject[^]

Dave Kreskowiak
Microsoft MVP
Visual Developer - Visual Basic
2006, 2007, 2008
But no longer in 2009...

Dave Kreskowiak wrote:
Absolutely noone is going to look through all that code

Is that a challenge? Wink | ;)

Steve Jowett
-------------------------
Real programmers don't comment their code. If it was hard to write, it should be hard to read.

Not really, but if you felt so inclined, please...far be it from me to hold you back. Wink | ;)

A guide to posting questions on CodeProject[^]

Dave Kreskowiak
Microsoft MVP
Visual Developer - Visual Basic
2006, 2007, 2008
But no longer in 2009...

Hi,
I am trying to make a testing solution where in data from an excel sheet gets filled up in a web form displayed on IE.
My solution comprises of an Excel macro.
I am facing a problem in this simple piece of code.When I run the macro I get an error saying
"Method Document of IWebBrowser2 failed"(Run time error-2147467259)
IE version 7.0 is being used....

Dim x As Excel.Worksheet
Dim selRange As Range
Dim ie As Object
Sub Button1_Click()
Set x = ThisWorkbook.ActiveSheet
If ActiveCell Is Nothing Then
MsgBox "No selection made"
Else
Set selRange = ActiveWindow.RangeSelection
End If
Set ie = CreateObject("internetexplorer.Application")
ie.Visible = True
ie.Navigate "http://172.25.103.220/IDS/"
While ie.Busy: Wend
ie.Document.All("txtName").Value = ActiveCell
End Sub

Please help me out....
Thanks.

modified on Friday, August 28, 2009 7:13 AM

You can't set the value of an document element to an Excel range. You have to provide the VALUE of the cell, not the cell itself.

A guide to posting questions on CodeProject[^]

Dave Kreskowiak
Microsoft MVP
Visual Developer - Visual Basic
2006, 2007, 2008
But no longer in 2009...

Hey,
I really appreciate the point that you made.
Lets say now i replace the ActiveCell by some constant value.I still get the error.I suppose thats because of multiple IE objects which might be open at the time of execution.The tabbed browsing is the icing on the cake!...
Please tell me how to identify the right tab in the right object.

Thanks.

hi i have one text box where i have diplay current time
now i have one table in MS-Access and it have lots of records with different times
i want 2 display the price column value in the second text box where the current time matches

here in front of last trade price column i want the price to be display from database,means current time ka price
hope u will understnd wat i m trying 2 ask
thanks

So what do you need to know? How to get data from an access database? If so, there are plenty of examples both here and on google. If that is not what you want then you need to be clearer with your question.

Bob
Ashfield Consultants Ltd
Proud to be a 2009 Code Project MVP

i want to know how to write that the sql querry in VB
and how to display the result of that querry in text box
hope u understnd

So I assume google doesn't work for you, so here you are [^]

Bob
Ashfield Consultants Ltd
Proud to be a 2009 Code Project MVP

In my program I am cycling through port numbers starting with COM1 all the way to COM100 to check if my device is hooked up to a com port. I dont think there are 100 Com ports on the pc but I am not sure. Is there a reasonable number that I should cycle up to?

Hi,

COM ports aren't always called "COMdd", for some of them you can freely choose the name (this requires a driver that allows for it, often the case with USB-to-RS232C cables).

Assuming you are using .NET, I suggest you have a look at SerialPort.GetPortNames().

If you are still considering ancient VB code, you would need help from some Win32 functions, maybe EnumDevices. Have a look here[^] (it is C++ code) and/or search CodeProject or google.

Smile | :)

Luc Pattyn

Have a look at my entry for the lean-and-mean competition; please provide comments, feedback, discussion, and don’t forget to vote for it! Thank you.

Hi,

I need to connect to access db on 64bit WinXP machine. I've read that jet provider is not available on 64 machines...., but the exact code runs perfectly in VB6 on the same machine but i cant get it to work in VB.net OMG | :OMG:

here is the .Net code that stops at dbConn.Open() and says {"Provider cannot be found. It may not be properly installed."}

Private Sub FRMOption_Activated(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Activated
    Dim SQL_STR As String
    Dim ConnSTR As String
    Dim dbConn As ADODB.Connection
    Dim rs As ADODB.Recordset
    SQL_STR = "select * from TBL_Favorits where FAV_Delete_Bol=false order by FAV_Used_Bol,FAV_Order_Txt,FAV_Oper_Txt"
    ConnSTR = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & My.Application.Info.DirectoryPath & "\localFTC.mdb;"
    dbConn = New ADODB.Connection
    rs = New ADODB.Recordset
    dbConn.Mode = ADODB.ConnectModeEnum.adModeRead
    dbConn.ConnectionString = ConnSTR
    dbConn.Open()
    rs.Open(SQL_STR, dbConn, ADODB.CursorTypeEnum.adOpenKeyset, ADODB.LockTypeEnum.adLockOptimistic)
    If Not rs.BOF Then
        While Not rs.EOF
            ComboBox1.Items.Add(rs.Fields("FAV_Order_Txt").Value & " " & rs.Fields("FAV_Oper_Txt").Value)
            rs.MoveNext()
        End While
    End If
    rs.Close()
    dbConn.Close()
End Sub

Thanks
Arash

I think this is what you are missing:

Go to Project Properties
Click on the Compile Tab
Select "All Configurations" in the Configuration drop down
Click the Advanced Compile Options button
In the Advanced Compiler Settings form, set the Target CPU to x86

This compiles the application as a 32 bit program, and when running on a 64 bit machine it should be able to find the provider.

That was it. thanks for the help now i can simply use the data binding instead of all that.