Visual Basic - ayuda con actualización de proyecto

Dim xRaton As Long

Dim yRaton As Long

Dim Old As Long

Dim DIRHTML As String

Const DIRDATOS = "C:\Recepcion\Recepcion.mdb"

Const DIRLISTADOS = "C:\Recepcion\"

Const DIRLEGISLACION = "C:\Recepcion\6Legis\INDICELEX.html"

Const DIRPLIEGO = "C:\Recepcion\2pliego\INDICEPLI.html"

Private Sub BotonesRecepcion_ButtonClick(ByVal Button As MSComctlLib.Button)

    Select Case Button.Key

        Case "Borrar"

            With datRecepcion.Recordset

                If Not .EOF Then

                    If MsgBox("¿Quiere Borrar " & GridLineas.Columns("Descripcion"), vbQuestion + vbYesNo, "Borrar") = vbYes Then

                        .Delete

                        datRecepcion.Refresh

                    End If

                End If

            End With

        Case "Caducidad" '2/3

            GridLineas.ReBind

            With datRecepcion.Recordset

                If Not .EOF Then .MoveFirst

                Do While Not .EOF

                    If ![Fecha Caducidad/Cp] <> "" And ![Fecha Envasado] <> "" Then

                        If (CDate(![Fecha Caducidad/Cp]) - CDate(Fecha)) < (CDate(![Fecha Caducidad/Cp]) - CDate(![Fecha Envasado])) / 3 Then

                            .Edit

                            ![id NoApto] = 1

                            .Update

                        End If

                    End If

                    .MoveNext

                Loop

                GridLineas.ReBind

            End With

    End Select

End Sub

Private Sub BotonesRecepcion_ButtonMenuClick(ByVal ButtonMenu As MSComctlLib.ButtonMenu)

    With Listado

        Select Case ButtonMenu.Key

            Case "Recepcion"

                  .Formulas(0) = "Unidad='" & ComboUnidad.Text & "'"

                  .Formulas(1) = "Tipo='" & IIf(Option1(1) = 0, "Normalizada", "No Normalizada") & "'"

                  .SelectionFormula = IIf(Option1(1) = 0, "", "not") &                     " {Recepcion.Normalizada} and " &                     " {Recepcion.Fecha}=date (" & Format$(Fecha, "YYYY,MM,DD") & ") and " &                     " {Recepcion.Id Unidad}=" & datUnidades.Recordset!Id

                  .WindowTitle = "Control a la Recepción..."

                  .ReportFileName = DIRLISTADOS & "Recepcion.rpt"

            Case "Rechazo"

                  .Formulas(0) = "Unidad='" & ComboUnidad.Text & "'"

                  .Formulas(1) = "Tipo='" & IIf(Option1(1) = 0, "Normalizada", "No Normalizada") & "'"

                  .SelectionFormula = IIf(Option1(1) = 0, "", "not") &                     " {Recepcion.Normalizada} and " &                     " {Recepcion.Fecha}=date (" & Format$(Fecha, "YYYY,MM,DD") & ") and " &                     " {Recepcion.Id Unidad}=" & datUnidades.Recordset!Id                     & " and {Recepcion.Id NoApto} > 0"

                  .WindowTitle = "Productos Rechazados..."

                  .ReportFileName = DIRLISTADOS & "Rechazo.rpt"

            Case "Mensual", "Anual"

                  frmMemoria.Caption = ButtonMenu.Text

                  frmMemoria.Show vbModal

        End Select

        If ButtonMenu.Key = "Recepcion" Or ButtonMenu.Key = "Rechazo" Then

            Me.MousePointer = vbHourglass

            .DataFiles(0) = DIRDATOS

            .Action = 1

            Me.MousePointer = vbDefault

        End If

    End With

End Sub

Private Sub Calendario_Click()

    GridLineas.Columns(Calendario.DataField) = Calendario.Value

    Calendario.Visible = False

End Sub

Private Sub Calendario_KeyDown(KeyCode As Integer, Shift As Integer)

    If KeyCode = 27 Then Calendario.Visible = False

End Sub

Private Sub ComboUnidad_Click(Area As Integer)

    datUnidades.Recordset.Bookmark = ComboUnidad.SelectedItem

    If Area = 2 Then Option1_Click (0)

End Sub

Private Sub dbClave_GotFocus(Index As Integer)

    dbClave(Index).BackColor = &H80000018

End Sub

Private Sub dbClave_LostFocus(Index As Integer)

    dbClave(Index).BackColor = &H80000005

End Sub

Private Sub Fecha_BotonClick()

    Fecha.MostrarCalendario

    Option1_Click (0)

End Sub

Private Sub Form_Load()

    Caption = "Recepcion de Mercancías... " & " Versión " & App.Major & "." & App.Minor & "." & App.Revision

    If IsNull(Fecha) Then Fecha = Date

    datProductos.DatabaseName = DIRDATOS

    datProductos.Refresh

    DatIndicaciones.DatabaseName = DIRDATOS

    datNoApto.DatabaseName = DIRDATOS

    datApto.DatabaseName = DIRDATOS

    datRecepcion.DatabaseName = DIRDATOS

    datUnidades.DatabaseName = DIRDATOS

    datProveedores.DatabaseName = DIRDATOS

End Sub

Private Sub GridLineas_BeforeColEdit(ByVal ColIndex As Integer, ByVal KeyAscii As Integer, Cancel As Integer)

    If Label1 = "No" And GridLineas.AddNewMode = 1 Then Cancel = True

End Sub

Private Sub GridLineas_ButtonClick(ByVal ColIndex As Integer)

Dim c As Column

Set c = GridLineas.Columns(ColIndex)

    If GridLineas.AddNewMode = 1 Then Exit Sub

    If c.NumberFormat = "General Date" Then  ' Fecha envasado y Fecha caducidad

        With Calendario

            .DataField = c.DataField

            .Left = GridLineas.Left + c.Left - 2500

            .Top = GridLineas.Top + GridLineas.RowTop(GridLineas.Row) + GridLineas.RowHeight

            .Visible = True

            .SetFocus

        End With

    Else  'Apto y No Apto

        With List1

            If c.DataField = "Apto.Descripcion" Then

                .DataField = "Id Apto"

                Tabla.RecordSource = datApto.RecordSource

            Else

                .DataField = "Id NoApto"

                Tabla.RecordSource = datNoApto.RecordSource

            End If

            Tabla.Refresh

            .Left = GridLineas.Left + c.Left

            .Top = GridLineas.Top + GridLineas.RowTop(GridLineas.Row) + GridLineas.RowHeight

            .Width = c.Width + 15

            .Visible = True

            .ZOrder 0

            .SetFocus

        End With

    End If

End Sub

Private Sub GridLineas_DragDrop(Source As Control, X As Single, Y As Single)

Dim Marca As Long

    With datRecepcion.Recordset

        'Repetido en recepcion

        If GridLineas.AddNewMode = 0 Then Marca = !Id  'Modifica

        .FindFirst "[Id Producto]=" & Val(Label1)

         If Not .NoMatch Then

             Beep

             MsgBox "Ya existe: " & ListaSeleccion.Text,                  vbExclamation, "Producto con Recepción"

             GridLineas.ReBind

             Exit Sub

         Else

            .FindFirst "Id=" & Marca

         End If

        '--------------------

    End With

    With GridLineas

        If .AddNewMode = 0 Then             If MsgBox("¿Quiere cambiar " & .Columns("Descripcion")                   & " por " & ListaSeleccion.Text, vbYesNo + vbCritical, "Cambia el producto")                  = vbNo Then Exit Sub

        Old = Val(.Columns("Id Producto"))

        .Columns("Id Producto") = Label1

        .Columns("Fecha") = Fecha

        .Columns("Normalizada") = datProductos.Recordset!normalizada

        .Columns("Id Unidad") = datUnidades.Recordset!Id

        'Refresco de linea

        If Old = Val("") Then

            datRecepcion.Recordset.AddNew

        Else

            .Refresh

            datRecepcion.Recordset.MovePrevious

            datRecepcion.Recordset.MoveNext

        End If

    End With

    Label1 = "No"

End Sub

Private Sub GridLineas_GotFocus()

    GridLineas.BackColor = &H80000018

End Sub

Private Sub GridLineas_LostFocus()

    GridLineas.BackColor = &H80000005

End Sub

Private Sub List1_Click()

    Tabla.Recordset.Bookmark = List1.SelectedItem

    If List1.Visible = True Then

        c = GridLineas.Col

        GridLineas.Columns(List1.DataField) = Tabla.Recordset!Id

        h = datRecepcion.Recordset!Id

        datRecepcion.Refresh

        datRecepcion.Recordset.FindFirst "id=" & h

        GridLineas.Col = c

    End If

    List1.Visible = False

End Sub

Private Sub ListaSeleccion_GotFocus()

    ListaSeleccion.BackColor = &H80000018

End Sub

Private Sub ListaSeleccion_LostFocus()

    ListaSeleccion.BackColor = &H80000005

End Sub

Private Sub ListaSeleccion_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    If Button = 2 Then

        With Label1

            .Left = xRaton

            .Top = yRaton

             datProductos.Recordset.Bookmark = ListaSeleccion.SelectedItem

            .Caption = datProductos.Recordset!Id

            .Drag 1

        End With

    End If

End Sub

Private Sub ListaSeleccion_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    xRaton = X

    yRaton = Y + 1000

End Sub

Private Sub ListProductos_Click()

    datProductos.Recordset.Bookmark = ListProductos.SelectedItem

End Sub

Private Sub Opciones_ButtonClick(ByVal Button As MSComctlLib.Button)

    Select Case Button.Key

        Case "Nuevo"

            datProductos.Recordset.AddNew

            descripcion.SetFocus

            Opciones.Buttons("Acepta").Enabled = True

            Opciones.Buttons("Cancela").Enabled = True

            Opciones.Buttons("Actualiza").Enabled = False

            Opciones.Buttons("Borra").Enabled = False

        Case "Actualiza"

            datProductos.Refresh

        Case "Borra"

            If MsgBox("¿Esta Seguro?", vbQuestion + vbYesNo, "Borrar registro") = vbYes Then

                datProductos.Recordset.Delete

                datProductos.Recordset.MoveNext

                ListProductos.ReFill

            End If

        Case "Acepta", "Cancela"

            If Button.Key = "Cancela" Then

                datProductos.Recordset.CancelUpdate

            Else

                datProductos.Recordset.Update

                datProductos.Recordset.Bookmark = datProductos.Recordset.LastModified

                'ListProductos.ReFill

            End If

            Opciones.Buttons("Acepta").Enabled = False

            Opciones.Buttons("Cancela").Enabled = False

            Opciones.Buttons("Actualiza").Enabled = True

            Opciones.Buttons("Borra").Enabled = True

        Case "Imagen"

            On Error GoTo CancelLoad

                Busca.ShowOpen

                On Error GoTo BadLoad

                    If Busca.FileName <> "" Then Imagen = LoadPicture(Busca.FileName)

                On Error GoTo 0

            On Error GoTo 0

            Exit Sub

CancelLoad:

    If Err.Number <> cdlCancel Then

        MsgBox Err.Description, vbExclamation

    Else

        Exit Sub

    End If

BadLoad:

    MsgBox Err.Description, vbExclamation

    End Select

End Sub

Private Sub Option1_Click(Index As Integer)

Dim Norm As Integer

    Norm = -1

    If Option1(1).Value Then Norm = 0  'No Normalizada

    datProductos.RecordSource = "Select * from articulos "                     & "where normalizada=" & Norm

    datProductos.Refresh

    datRecepcion.RecordSource = "select * from [Consulta Recepcion] "         & " where fecha=#" & Format(Fecha, "MM/DD/YY") & "# "         & " and [Id Unidad] = " & datUnidades.Recordset!Id         & " and Normalizada = " & Norm

    datRecepcion.Refresh

    ListaSeleccion.SetFocus

End Sub

Private Sub SStab_Click(PreviousTab As Integer)

    Select Case SStab.Tab

        Case 0 'Productos

            ListProductos.SetFocus

            datProductos.RecordSource = "Select * from articulos "                 & " order by descripcion"

            datProductos.Refresh

            DatIndicaciones.Refresh

            datProveedores.Refresh

        Case 1 'Recepción

            GridLineas.Splits(1).MarqueeStyle = 6

            datUnidades.Refresh

            ComboUnidad.Text = datUnidades.Recordset!descripcion

            datNoApto.Refresh

            datApto.Refresh

            Tabla.DatabaseName = DIRDATOS

            Option1_Click (0)

        Case 3 'Legislación

            DIRHTML = DIRLEGISLACION

            brwWebBrowser(1).Navigate DIRLEGISLACION

        Case 4 'Pliego de Condiciones

            DIRHTML = DIRPLIEGO

            brwWebBrowser(0).Navigate DIRPLIEGO

        End Select

End Sub

Private Sub tbToolBar_ButtonClick(Index As Integer, ByVal Button As Button)

    On Error Resume Next

    Select Case Button.Key

        Case "Back"

            brwWebBrowser(Index).GoBack

        Case "Forward"

            brwWebBrowser(Index).GoForward

        Case "Refresh"

            brwWebBrowser(Index).Refresh

        Case "Home"

            brwWebBrowser(Index).Navigate DIRHTML

        Case "Search"

            brwWebBrowser(Index).GoSearch

        Case "Stop"

            brwWebBrowser(Index).Stop

    End Select

End Sub

Private Sub brwWebBrowser_DownloadComplete(Index As Integer)

    On Error Resume Next

End Sub