|
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.
|
|
|
|
|
Dave Kreskowiak wrote: Absolutely noone is going to look through all that code
Is that a challenge? 
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.
|
|
|
|
|
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.
|
|
|
|
|
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.
|
|
|
|
|
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 
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.
|
|
|
|
|
The reason why this works is because, like has been stated before, there are no OLEDB drivers in 64-bit. You cannot run both 64 and 32-bit code in the same process. So, since your app was 64-bit, you couldn't use the 32-bit OLEDB drivers to get at the database. That's why your code works when forced to compile as a 32-bit app.
|
|
|
|
|
hey there
I got a visual basic 2008 express version
but the 'Target CPU' option isn't where you said it should be..
anybody know what could be the cause of that?
Thanks
Empathies
|
|
|
|
|
That's because it isn't there in the Express Editions. There is no 64-bit compiler support in the Express Editions, therefore you won't get the option to limit the compiler to 32-bit only code. It's already 32-bit only.
|
|
|
|
|
|
I have same issue but the advanced tab is not available it is there but disabled?
|
|
|
|
|
What version of Visual Studio are you using? Perhaps that feature is not available in the Express version?
|
|
|
|
|
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)