-
Notifications
You must be signed in to change notification settings - Fork 0
/
SINC_TRANS.bas
3117 lines (2457 loc) · 113 KB
/
SINC_TRANS.bas
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
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
Attribute VB_Name = "SINC_TRANS"
'---------------------------------------------------------------------------------------
' Modulo : SINC_TRANS
' Fecha/Hora : 19/11/2003 21:10
' Autor : JCASTILLO
' Propósito : Rutinas para la sincronización y transferencias.
'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
' PROCESO DE LA TRANSFERENCIA:
'---------------------------------------------------------------------------------------
' Transferencias (Tabla PTRANS). Estados posibles para la transferencia:
' 0 -> EN CREACION: la transferencia esta en creación, todavia no le sale a los puestos, solo desde el
' central o el puesto desde donde se crea. En este estado es posible borrar la transferencia.
'
' 1 -> PENDIENTE: la transferencia ya no esta en creación, significa que ya le sale a los puestos que
' intervienen en la misma. desde el puesto de destino de la mercancía, se puede ACEPTAR. y desde
' el puesto de origen se puede anular.
'
' 2 -> ACEPTADA. La transferencia ha sido aceptada y añadida en el Destino.
'
' 3 -> CANCELADA: La transferencia ha sido cancelada. Solo se puede cancelar desde el origen, pues hay
' que devolver las unidades previamente descontadas al pasar a ESTADO=1 (pendiente).
'---------------------------------------------------------------------------------------
Option Explicit
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Const STILL_ACTIVE = &H103
Const PROCESS_QUERY_INFORMATION = &H400
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal Options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Const FORMAT_FULL = &H1
Public Type Cabecera_Grid_Print
Lineas() As String
cuantos As Long
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TFormatRange
hdc As Long
hdcTarget As Long
rc As Rect
rcPage As Rect
End Type
Const WM_USER = &H400
Const VP_FORMATRANGE = WM_USER + 125
Const VP_YESIDO = 456654
'---------------------------------------------------------------------------------------
' Procedimiento : iniciar_transferencia
' Fecha/Hora : 11/12/2003 10:32
' Autor : JCastillo
' Propósito : Pasar una transferencia de estado 0 a estado 1 (se pone estado 1 en
' el registro de PTRANS y se descuentan las unidades de stock.
' Devuelve 0 si se ha realizado correctamente y 1 si ha habido algun
' error y 2 si no hay registros en el detalle para esa transferencia
'---------------------------------------------------------------------------------------
Public Function iniciar_transferencia(CODIGO_TRANSF As Long, codigo_almacen As Byte, conexion As ADODB.Connection) As Byte
Dim rc As ADODB.Recordset
Dim entrans As Boolean
Dim miConn As New ADODB.Connection
On Error GoTo iniciar_transferencia_Error
Set rc = New ADODB.Recordset
With miConn
.ConnectionString = conexion.ConnectionString
.CursorLocation = adUseServer
.Open
.BeginTrans
End With
'seleccionar transferencias
rc.Open "SELECT CODART, TEMPOR, CODTALLA, CODCOL, UNIDADES FROM DETTRANS WHERE CODIGO = " & CODIGO_TRANSF & " AND CODALM = " & codigo_almacen, conexion, adOpenStatic, adLockReadOnly
'salida por no hay registros
If rc.RecordCount <= 0 Then
rc.Close
Set rc = Nothing
iniciar_transferencia = 2
Exit Function
End If
entrans = True
'quitar de stock
Do Until rc.EOF
'descontar las unidades para el almacen
stock rc.fields("CODART"), rc.fields("TEMPOR"), rc.fields("CODTALLA"), rc.fields("CODCOL"), codigo_almacen, rc.fields("UNIDADES"), False, miConn
rc.MoveNext
Loop
rc.Close
Set rc = Nothing
'pasar a pendiente
miConn.Execute "UPDATE PTRANS SET ESTADO = 1 WHERE CODIGO = " & CODIGO_TRANSF & " AND CODALMORIG = " & codigo_almacen
With miConn
.CommitTrans
.Close
End With
entrans = False
Set miConn = Nothing
On Error GoTo 0
Exit Function
iniciar_transferencia_Error:
Set rc = Nothing
If entrans Then
With miConn
If .State = 1 Then
.RollbackTrans
.Close
End If
End With
End If
Set miConn = Nothing
iniciar_transferencia = 1
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento iniciar_transferencia de Módulo SINC_TRANS"
End Function
'---------------------------------------------------------------------------------------
' Procedimiento : aceptar_transferencia
' Fecha/Hora : 09/12/2003 12:54
' Autor : JCastillo
' Propósito : Acepta una transferencia PENDIENTE (ESTADO=1).
' Introduce las unidades en STOCK y marca la transferencia como ACEPTADA
' (ESTADO=2).
' Devuelve 0 si se ha realizado correctamente y 1 si ha habido algun error y
' 2 si no hay registros en el detalle para esa transferencia
'---------------------------------------------------------------------------------------
Public Function aceptar_transferencia(codtrans As Long, codigo_almacen As Byte, conexion As ADODB.Connection) As Byte
Dim tmpstrconn As String
Dim tmprc As ADODB.Recordset
On Error GoTo aceptar_transferencia_Error
Set tmprc = New ADODB.Recordset
'abrimos el rc antes de cambiar de cursor para q vaya mas rapido
With tmprc
.Open "SELECT CODART, TEMPOR, CODTALLA, CODCOL, CODALM, UNIDADES FROM DETTRANS WHERE CODIGO = " & codtrans & " AND CODALM = " & codigo_almacen, conexion, adOpenStatic, adLockReadOnly
.ActiveConnection = Nothing 'lo desconectamosç
'si no hay registros
If .RecordCount = 0 Then
tmprc.Close
Set tmprc = Nothing
'salida no hay registros
aceptar_transferencia = 2
Exit Function
End If
.MoveFirst
End With
With conexion
tmpstrconn = .ConnectionString 'guardar el connection anterior por si acaso
If .State <> 0 Then .Close
.CursorLocation = adUseServer 'abrir con cursor para las transacciones
.Open strLocCnn
.BeginTrans
End With
'mientras haya registros
Do Until tmprc.EOF
'introducir unidades en stock
stock tmprc.fields("CODART"), tmprc.fields("TEMPOR"), tmprc.fields("CODTALLA"), tmprc.fields("CODCOL"), AlmacenActual, tmprc.fields("UNIDADES"), True, conexion
tmprc.MoveNext
Loop
With conexion
'poner esa transferencia como ACEPTADA.
.Execute "UPDATE PTRANS SET ESTADO=2 WHERE CODIGO = " & codtrans & " AND CODALMORIG = " & codigo_almacen
DoEvents
.CommitTrans 'aceptar todos los cambios
If .State <> 0 Then .Close
.CursorLocation = adUseClient
.Open tmpstrconn
End With
tmpstrconn = ""
'proceso terminado normalmente
aceptar_transferencia = 0
On Error GoTo 0
Exit Function
aceptar_transferencia_Error:
'On Error Resume Next
With conexion
If tmpstrconn <> .ConnectionString Then
.RollbackTrans
If .State <> 0 Then .Close
.CursorLocation = adUseClient
.Open tmpstrconn
End If
End With
tmpstrconn = ""
'salida con error
aceptar_transferencia = 1
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento aceptar_transferencia de Módulo SINC_TRANS"
End Function
'---------------------------------------------------------------------------------------
' Procedimiento : anular_transferencia_pendiente
' Fecha/Hora : 11/12/2003 11:46
' Autor : JCastillo
' Propósito : Anula una transferencia pendiente. Solo usar con las que tengan ESTADO = 1 (pendiente).
' devuelve 0-> si se ha realizado correctamente
' 1-> si hubo algun error
'---------------------------------------------------------------------------------------
Public Function anular_transferencia_pendiente(codtrans As Long, codigo_almacen As Byte, conexion As ADODB.Connection) As Byte
Dim rc As ADODB.Recordset
On Error GoTo anular_transferencia_pendiente_Error
Set rc = New ADODB.Recordset
'seleccionar transferencias
rc.Open "SELECT CODART, TEMPOR, CODTALLA, CODCOL, UNIDADES FROM DETTRANS WHERE CODIGO = " & codtrans & " AND CODALM = " & codigo_almacen, conexion, adOpenStatic, adLockReadOnly
'salida por no hay registros
If rc.RecordCount > 0 Then
'quitar de stock
Do Until rc.EOF
'descontar las unidades para el almacen
stock rc.fields("CODART"), rc.fields("TEMPOR"), rc.fields("CODTALLA"), rc.fields("CODCOL"), codigo_almacen, rc.fields("UNIDADES"), True, conexion
rc.MoveNext
Loop
End If
rc.Close
Set rc = Nothing
'pasar a cancelada
conexion.Execute "UPDATE PTRANS SET ESTADO = 3 WHERE CODIGO = " & codtrans & " AND CODALMORIG = " & codigo_almacen
anular_transferencia_pendiente = 0
On Error GoTo 0
Exit Function
anular_transferencia_pendiente_Error:
anular_transferencia_pendiente = 1
Set rc = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento anular_transferencia_pendiente de Módulo SINC_TRANS"
End Function
'---------------------------------------------------------------------------------------
' Procedimiento : crear_transferencia
' Fecha/Hora : 09/12/2003 16:35
' Autor : JCastillo
' Propósito : Crea un nuevo registro de cabecera de transferencia (en PTRANS). Devuelve el numero de trans
' ferencia creado. Se crea una transferencia con estado 0 (Creación)
'---------------------------------------------------------------------------------------'
Public Function crear_transferencia(codigo_almacen_origen As Byte, codigo_almacen_destino As Byte, conexion As ADODB.Connection, DesdePedido As Boolean, Num_Ped As Double) As Long
Dim tmpcodigo As Variant
On Error GoTo crear_transferencia_Error
'si es desde almacen usar la codificacion 900000000 + el contador para almacen
If DesdePedido Then
tmpcodigo = devuelve_campo("select max(CODIGO) + 1 from PTRANS where (CODIGO > 900000000) AND (CODALMORIG = " & codigo_almacen_origen & ")", conexion)
If tmpcodigo = "@" Then tmpcodigo = 900000000
Else
tmpcodigo = devuelve_campo("select max(CODIGO) + 1 from PTRANS where CODALMORIG = " & codigo_almacen_origen, conexion)
If tmpcodigo = "@" Then tmpcodigo = 1
End If
'se inserta con el estado en creación
conexion.Execute "INSERT INTO PTRANS (CODIGO, CODALMORIG, CODALMDEST, ESTADO, CODUSR, NUMPED) " & _
"VALUES (" & tmpcodigo & ", " & codigo_almacen_origen & ", " & codigo_almacen_destino & ", 0, " & UsuarioActual & ", " & Num_Ped & ")"
crear_transferencia = CLng(tmpcodigo)
Set tmpcodigo = Nothing
On Error GoTo 0
Exit Function
crear_transferencia_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento crear_transferencia de Módulo SINC_TRANS"
End Function
'---------------------------------------------------------------------------------------
' Procedimiento : crear_linea_transferencia
' Fecha/Hora : 10/12/2003 12:19
' Autor : JCastillo
' Propósito : Crea una nueva linea de transferencia (en dettrans)
'---------------------------------------------------------------------------------------'
Public Function crear_linea_transferencia(CODIGO_TRANSF As Double, almacen As Byte, codart As Integer, tempor As Byte, talla As Integer, Color As Integer, unidades As Double, conexion As ADODB.Connection, DesdePedido As Boolean)
Dim tmpcodigo As Variant
On Error GoTo crear_linea_transferencia_Error
If DesdePedido Then
tmpcodigo = devuelve_campo("select max(ID) + 1 from DETTRANS where (ID > 500000000) AND (CODALM = " & almacen & ")", conexion)
If tmpcodigo = "@" Then tmpcodigo = 500000000
Else
tmpcodigo = devuelve_campo("select max(ID) + 1 from DETTRANS where CODALM = " & almacen, conexion)
If tmpcodigo = "@" Then tmpcodigo = 1
End If
tmpcodigo = devuelve_campo("select max(ID) + 1 from DETTRANS where CODALM = " & almacen, conexion)
If tmpcodigo = "@" Then tmpcodigo = 1
conexion.Execute "INSERT INTO DETTRANS (CODIGO, CODART, ID, CODALM, TEMPOR, CODTALLA, CODCOL, UNIDADES) " & _
"VALUES (" & CODIGO_TRANSF & ", " & codart & ", " & tmpcodigo & ", " & almacen & ", " & tempor & ", " & talla & ", " & Color & "," & unidades & ")"
'End If
crear_linea_transferencia = CLng(tmpcodigo)
Set tmpcodigo = Nothing
On Error GoTo 0
Exit Function
crear_linea_transferencia_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento crear_linea_transferencia de Módulo SINC_TRANS"
End Function
'---------------------------------------------------------------------------------------
' Procedimiento : Abre_Conexion
' Fecha/Hora : 02/12/2003 09:33
' Autor : JCastillo
' Propósito :Abrir el Acceso telefónico a Redes de Windows y ejecutar una conexión
'---------------------------------------------------------------------------------------
'Private Sub Abre_Conexion()
'Dim AbrirConexion As Long
' On Error GoTo Abre_Conexion_Error
'
'AbrirConexion = Shell("rundll32.exe rnaui.dll,RnaDial " & "ConexiónInternet", 1)
'SendKeys "{ENTER}"
'
' On Error GoTo 0
' Exit Sub
'
'Abre_Conexion_Error:
'
' MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento Abre_Conexion de Módulo SINC_TRANS"
'End Sub
Public Sub PrintGrid(Grid As VSFlexGrid, ByVal LeftMargin As Single, _
ByVal TopMargin As Single, ByVal RightMargin As _
Single, ByVal BottomMargin As Single, Titel As _
String, Datum As String, Optional many As Integer)
Dim tRange As TFormatRange
Dim lReturn As Long
Dim DName As String
Dim DSchacht As Integer
Dim gbeg As Long
Dim CopyCW() As Long
Dim GRef As Boolean
Dim x%
GRef = False
If many > 0 Then
' Anzahl der zu druckenden Colums festlegen
' Alles > many wird auf colwidth = 0 gesetzt
If Grid.Cols > many Then
gbeg = Grid.Cols - many
ReDim CopyCW(gbeg)
Grid.Redraw = False
For x = many To Grid.Cols - 1
CopyCW(x - many) = Grid.ColWidth(x)
Grid.ColWidth(x) = 0
Next x
GRef = True
End If
End If
'mit wParam <> 0 kann überprüft werden
'ob das Control OPP unterstützt, wenn ja wird
'456654 (VP_YESIDO) zurückgeliefert
lReturn = SendMessage(Grid.hwnd, VP_FORMATRANGE, 1, 0)
If lReturn = VP_YESIDO Then
'Struktur mit Formatierungsinformationen füllen
Printer.ScaleMode = vbPixels
With tRange
.hdc = Printer.hdc
'Höhe und Breite einer Seite (in Pixel)
.rcPage.Right = Printer.ScaleWidth
.rcPage.Bottom = Printer.ScaleHeight
'Lage und Abmessungen des Bereichs auf den
'gedruckt werden soll (in Pixel)
.rc.Left = Printer.ScaleX(LeftMargin, vbMillimeters)
.rc.Top = Printer.ScaleY(TopMargin, vbMillimeters)
.rc.Right = .rcPage.Right - Printer.ScaleX(RightMargin, _
vbMillimeters)
.rc.Bottom = .rcPage.Bottom - Printer.ScaleY(BottomMargin, _
vbMillimeters)
End With
'Drucker initialisieren
Printer.Print vbNullString
'Seite(n) drucken
Do
Printer.CurrentX = Printer.ScaleX(LeftMargin, vbMillimeters)
Printer.CurrentY = Printer.ScaleY(10, vbMillimeters)
If Titel <> "" Then Printer.Print Titel
Printer.CurrentX = Printer.ScaleX(LeftMargin, vbMillimeters)
Printer.CurrentY = Printer.ScaleY(16, vbMillimeters)
If Datum <> "" Then
Printer.Print Datum
Else
Printer.Print Format(Date, "DD.MM.YYYY")
End If
lReturn = SendMessage(Grid.hwnd, VP_FORMATRANGE, 0, _
VarPtr(tRange))
If lReturn < 0 Then
Exit Do
Else
Printer.NewPage
End If
Loop
Printer.EndDoc
'Reset
lReturn = SendMessage(Grid.hwnd, VP_FORMATRANGE, 0, 0)
End If
If GRef Then
'Alle Colums wieder in richtiger Breite darstellen
For x = many To Grid.Cols - 1
Grid.ColWidth(x) = CopyCW(x - many)
Next x
Grid.Redraw = True
End If
End Sub
Public Sub PrintFlexGrid(flxdata As _
Object, xmin As Single, ymin As Single, orientacion As Byte, CabeceraL1 As String, CabeceraL2 As String, Cabecera_Fontsize As Byte, Linea_Totales As Long, Optional fuente_tamano As Byte)
Const GAP = 60
' Orientacion
' vbPRORPortrait 1
' vbPRORLandscape 2
Dim xmax As Single
Dim ymax As Single
Dim x As Single
Dim C As Integer
Dim R As Integer
Dim ptr As Object
Dim guardar_cy As Long
Dim guardar_cx As Long
Dim tmppag As Long
On Error GoTo PrintFlexGrid_Error
Set ptr = Printer
ptr.Orientation = orientacion
With ptr.Font
.Name = flxdata.Font.Name
'Imprimir la Cabecera
If CabeceraL1 <> "" Then
If Cabecera_Fontsize > 0 Then
.Size = Cabecera_Fontsize
Else
.Size = flxdata.Font.Size
End If
ptr.CurrentX = xmax = xmin + GAP
ptr.Print CabeceraL1
ptr.Print CabeceraL2
ptr.Print
ymin = ymin + ptr.CurrentY + 20
End If
If fuente_tamano > 0 Then
.Size = fuente_tamano
Else
.Size = flxdata.Font.Size
End If
End With
guardar_cy = ptr.CurrentY
guardar_cx = ptr.CurrentX
ptr.CurrentY = ptr.Height - (ptr.TextHeight(ptr.Page) * 4)
ptr.CurrentX = ptr.Width - 1200 '(ptr.TextWidth(ptr.Page) * 4)
ptr.Print ptr.Page
ptr.CurrentY = guardar_cy
ptr.CurrentX = guardar_cx
tmppag = 1
With flxdata
' See how wide the whole thing is.
xmax = xmin + GAP
For C = 0 To .Cols - 1
If Not .ColHidden(C) Then
'Select Case .ColFormat(c)
'Case "Currency"
xmax = xmax + .ColWidth(C) + 2 * GAP
'Case Else
'xmax = xmax + .ColWidth(c) + 2 * GAP
'End Select
End If
Next C
' Print each row.
ptr.CurrentY = ymin
For R = 0 To .Rows - 1
'Draw a line above this row.
'si es igual a la linea de totales
If R = Linea_Totales - 1 Then
ptr.FontUnderline = True
ptr.FontBold = True
Else
ptr.FontUnderline = False
ptr.FontBold = False
End If
If R > 0 Then ptr.Line (xmin, _
ptr.CurrentY)-(xmax, ptr.CurrentY)
ptr.CurrentY = ptr.CurrentY + GAP
' Print the entries on this row.
x = xmin + GAP
For C = 0 To .Cols - 1
If Not .ColHidden(C) Then
ptr.CurrentX = x
'Select Case .ColFormat(c)
'Case "Currency"
' ptr.Print Format(BoundedText(ptr, .TextMatrix(r, _
c), .ColWidth(c)), "Currency")
'
' Case Else
ptr.Print BoundedText(ptr, .TextMatrix(R, C), .ColWidth(C));
' End Select
x = x + .ColWidth(C) + 2 * GAP
End If
Next C
ptr.CurrentY = ptr.CurrentY + GAP
' Move to the next line.
ptr.Print
'cuando cambie de página, imprimir el numero otra vez
If tmppag <> ptr.Page Then
guardar_cy = ptr.CurrentY
guardar_cx = ptr.CurrentX
ptr.CurrentY = ptr.Height - (ptr.TextHeight(ptr.Page) * 4)
ptr.CurrentX = ptr.Width - 1200 '(ptr.TextWidth(ptr.Page) * 4)
ptr.Print ptr.Page
ptr.CurrentY = guardar_cy
ptr.CurrentX = guardar_cx
tmppag = ptr.Page
'guardar_cy = ptr.CurrentY
'ptr.CurrentY = ptr.Height - (ptr.TextHeight(ptr.Page) * 4)
'ptr.Print ptr.Page
'ptr.CurrentY = guardar_cy
End If
Next R
ymax = ptr.CurrentY
' Draw a box around everything.
'ptr.Line (xmin, ymin)-(xmax, ymax), , B
' Draw lines between the columns.
x = xmin
' For c = 0 To .Cols - 2
' If Not .ColHidden(c) Then
' X = X + .ColWidth(c) + 2 * GAP
' ptr.Line (X, ymin)-(X, ymax)
' End If
' Next c
End With
ptr.EndDoc
Set ptr = Nothing
On Error GoTo 0
Exit Sub
PrintFlexGrid_Error:
ptr.EndDoc
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento PrintFlexGrid de Módulo SINC_TRANS"
End Sub
' Truncate the string so it fits within the width.
Private Function BoundedText(ByVal ptr As Object, ByVal txt _
As String, ByVal max_wid As Single) As String
Do While ptr.TextWidth(txt) > max_wid
txt = Left$(txt, Len(txt) - 1)
Loop
BoundedText = txt
End Function
Private Sub copia_rc(origen As ADODB.Recordset, destino As ADODB.Recordset, comprueba_duplicado As Boolean)
Dim var As Long
Dim añadir As Boolean
'meter registros ...
On Error GoTo copia_rc_Error
añadir = True
Do Until origen.EOF
'primero buscar si existe el registro en el destino ...
If comprueba_duplicado Then
destino.Find "ROWGUID = '" & origen.fields("ROWGUID") & "'", , adSearchForward, 1
'si no se encuentra el registro, añadirlo nuevo
If destino.EOF Then
añadir = True
Else
añadir = False
End If
End If
If añadir Then
destino.AddNew
For var = 0 To origen.fields.Count - 1
If Not IsNull(origen.fields(var)) Then _
destino.fields(origen.fields(var).Name) = origen.fields(var)
Next var
destino.Update
End If
origen.MoveNext
Loop
On Error GoTo 0
Exit Sub
copia_rc_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento copia_rc de Módulo SINC_TRANS"
End Sub
Private Sub Actualiza_rc(origen As ADODB.Recordset, destino As ADODB.Recordset, esPtrans As Boolean)
Dim var As Long
Dim añadir As Boolean
'meter registros ...
On Error GoTo Actualiza_rc_Error
añadir = True
Do Until origen.EOF
destino.Find "ROWGUID = " & origen.fields("ROWGUID"), , adSearchForward, 1
'destino.Filter = "ROWGUID = " & origen.fields("ROWGUID") ', , adSearchForward, 1"
'si no se encuentra el registro, añadirlo nuevo
If destino.EOF Then
añadir = True
Else
añadir = False
End If
'destino.Filter = ""
If añadir Then
destino.AddNew
For var = 0 To origen.fields.Count - 1
Debug.Print origen.Source
If ver_tipo_campo(origen.fields(var)) = 2 Then
'si es de texto, y nulo, meter un " "
If IsNull(origen.fields(var)) Then
destino.fields(origen.fields(var).Name) = " "
Else
destino.fields(origen.fields(var).Name) = origen.fields(var)
End If
Else
If Not IsNull(origen.fields(var)) Then _
destino.fields(origen.fields(var).Name) = origen.fields(var)
End If
Next var
'si ya existe, actualizar el registro
Else
For var = 0 To origen.fields.Count - 1
'si es Ptrans tener cuidado con no actualizar el campo
'estado
If esPtrans And origen.fields(var).Name = "ESTADO" Then
'no hacer nada ...
'de lo contrario
Else
If Not IsNull(origen.fields(var)) Then _
destino.fields(origen.fields(var).Name) = origen.fields(var)
End If
Next var
End If
destino.Update
destino.Requery
origen.MoveNext
Loop
On Error GoTo 0
Exit Sub
Actualiza_rc_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento Actualiza_rc de Módulo SINC_TRANS"
End Sub
'---------------------------------------------------------------------------------------
' Procedimiento : Actualiza_rc_Clave
' Fecha/Hora : 26/03/2004 16:40
' Autor : JCastillo
' Propósito : Actualiza recordset buscando por clave(s) ...
'---------------------------------------------------------------------------------------
Private Sub Actualiza_rc_Clave(origen As ADODB.Recordset, conexion As ADODB.Connection, NomTablaDest As String, Clave1 As String, Clave2 As String, Clave3 As String, Clave4 As String, WhereEspecial As String, OrdenBY As String, esPtrans As Boolean)
Dim var As Long
Dim añadir As Boolean
Dim destino As ADODB.Recordset
Dim tmpwhere As String
'meter registros ...
On Error GoTo Actualiza_rc_Clave_Error
Set destino = New ADODB.Recordset
Do Until origen.EOF
'abrir el registro seleccionado en destino ...
If Trim(Clave1) <> "" Then
tmpwhere = Clave1 & " = " & origen.fields(Clave1).Value
End If
If Trim(Clave2) <> "" Then
tmpwhere = tmpwhere & " AND " & Clave2 & " = " & origen.fields(Clave2).Value
End If
If Trim(Clave3) <> "" Then
tmpwhere = tmpwhere & " AND " & Clave3 & " = " & origen.fields(Clave3).Value
End If
If Trim(Clave4) <> "" Then
tmpwhere = tmpwhere & " AND " & Clave4 & " = " & origen.fields(Clave4).Value
End If
'If OrdenBY <> "" Then OrdenBY = " ORDER BY " & OrdenBY
'If WhereEspecial <> "" Then WhereEspecial = " AND (" & WhereEspecial & ")"
If destino.State = 1 Then destino.Close
Debug.Print "select * from " & NomTablaDest & " WHERE " & tmpwhere
destino.Open "select * from " & NomTablaDest & " WHERE " & tmpwhere, conexion, adOpenStatic, adLockOptimistic
'If Trim(WhereEspecial) = "" Then
'Debug.Print "select * from " & NomTablaDest & " WHERE " & tmpwhere & " " & OrdenBY,
' destino.Open "select * from " & NomTablaDest & " WHERE " & tmpwhere & " " & OrdenBY, conexion, adOpenStatic, adLockOptimistic
'Else
' destino.Open "select * from " & NomTablaDest & " WHERE " & tmpwhere & " AND (" & WhereEspecial & ") " & OrdenBY, conexion, adOpenStatic, adLockOptimistic
'End If
'si no existe el registro en destino ...
If destino.RecordCount <= 0 Then
añadir = True
'si existe, actualizar ...
Else
añadir = False
End If
If añadir Then
destino.AddNew
For var = 0 To origen.fields.Count - 1
Debug.Print origen.Source
If ver_tipo_campo(origen.fields(var)) = 2 Then
'si es de texto, y nulo, meter un " "
If IsNull(origen.fields(var)) Then
destino.fields(origen.fields(var).Name) = " "
Else
destino.fields(origen.fields(var).Name) = origen.fields(var)
End If
Else
If Not IsNull(origen.fields(var)) Then _
destino.fields(origen.fields(var).Name) = origen.fields(var)
End If
Next var
'si ya existe, actualizar el registro
Else
For var = 0 To origen.fields.Count - 1
'si es Ptrans tener cuidado con no actualizar el campo
'estado
If esPtrans And origen.fields(var).Name = "ESTADO" Then
'no hacer nada ...
'de lo contrario
Else
If Not IsNull(origen.fields(var)) Then _
destino.fields(origen.fields(var).Name) = origen.fields(var)
End If
Next var
End If
destino.Update
origen.MoveNext
Loop
If destino.State = 1 Then destino.Close
Set destino = Nothing
On Error GoTo 0
Exit Sub
Actualiza_rc_Clave_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento Actualiza_rc_Clave de Módulo SINC_TRANS"
End Sub
'
'---------------------------------------------------------------------------------------
' Procedimiento : Crea_TRN_Datos
' Fecha/Hora : 19/02/2004 12:55
' Autor : JCastillo