Access - ayuda con programa en vba access

   
Vista:

ayuda con programa en vba access

Publicado por Jose Luis jose396685@gmail.com (1 intervención) el 31/12/2014 13:07:19
Hola:Tengo un programa ,que creía hecho en Visual Basic 6, y después enterarme que es realizado en Access y programado con el vba Access.Bueno, intento compilarlo y me dice:"No se ha definido el tipo definido por el usuario".Ayuda ,por favor.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
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
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder