frmImportarCotas.frm
5.56 KB
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
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmImportarCotas
BorderStyle = 3 'Fixed Dialog
Caption = "Importação de Cotas"
ClientHeight = 1815
ClientLeft = 45
ClientTop = 435
ClientWidth = 6420
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 1815
ScaleWidth = 6420
ShowInTaskbar = 0 'False
StartUpPosition = 3 'Windows Default
Begin MSComDlg.CommonDialog CDL
Left = 1530
Top = 1290
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton cmdFormato
Caption = "Formato"
Height = 405
Left = 3855
TabIndex = 4
Top = 1185
Width = 1095
End
Begin VB.Frame Frame1
Caption = "Arquivo Fonte"
Height = 795
Left = 210
TabIndex = 2
Top = 225
Width = 5985
Begin VB.CommandButton cmdProcuraArquivo
Caption = "..."
Height = 360
Left = 5340
TabIndex = 5
Top = 315
Width = 465
End
Begin VB.TextBox Text1
Height = 360
Left = 210
TabIndex = 3
Top = 315
Width = 5040
End
End
Begin VB.CommandButton cmdImportarCotas
Caption = "Iniciar"
Height = 405
Left = 5025
TabIndex = 1
Top = 1185
Width = 1110
End
Begin MSComctlLib.ProgressBar ProgressBar1
Height = 360
Left = 285
TabIndex = 0
Top = 1200
Visible = 0 'False
Width = 3420
_ExtentX = 6033
_ExtentY = 635
_Version = 393216
Appearance = 1
Min = 1e-4
Scrolling = 1
End
End
Attribute VB_Name = "frmImportarCotas"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim a As String
Dim b As String
Dim c As String
Dim d As String
Dim e As String
Dim f As String
Dim g As String
Dim h As String
Dim i As String
Dim j As String
Dim k As String
Dim l As String
Private Sub cmdFormato_Click()
MsgBox "O arquivo deverá possuir duas colunas de informação separadas por ponto e vírgula (;)" & Chr(13) & Chr(13) & _
Chr(13) & Chr(13) & "A primeira coluna com o identificador do Nó" & _
Chr(13) & Chr(13) & "A segunda coluna com o valor de cota" & _
Chr(13) & Chr(13) & "Ex." & _
Chr(13) & Chr(13) & "66;2.3", vbInformation, "Formato de arquivo"
End Sub
Private Sub cmdImportarCotas_Click()
On Error GoTo Trata_Erro
'O FORMATO DO ARQUIVO DEVE SER TEXTO SEPARADO POR ;
Dim count As Integer
Dim str As String, id_no As String, cota As String, contador As Long
Dim rs As New ADODB.Recordset
count = 0
contador = 0
If Me.Text1.Text <> "" Then
str = Dir(CStr(Text1.Text))
If str = "" Then
MsgBox "Arquivo inexistente.", vbInformation, ""
Exit Sub
End If
Else
MsgBox "Arquivo inexistente.", vbInformation, ""
Exit Sub
End If
Open Text1.Text For Input As #3
Do While Not EOF(3)
Line Input #3, str
contador = contador + 1
Loop
ProgressBar1.Max = contador + 1
ProgressBar1.value = 1
ProgressBar1.Visible = True
Close #3
MousePointer = vbHourglass
Dim numero As String
Dim MyArray As Variant
Open Text1.Text For Input As #3
Do While Not EOF(3)
DoEvents
Line Input #3, str
MyArray = Split(str, ";")
id_no = Trim(MyArray(0))
cota = Replace(Trim(MyArray(1)), ",", ".")
numero = id_no
a = "WATERCOMPONENTS"
b = "INITIALGROUNDHEIGHT"
c = "OBJECT_ID_"
count = count + 1
If count > 1 Then
If frmCanvas.TipoConexao <> 4 Then
Conn.execute ("UPDATE WATERCOMPONENTS SET GROUNDHEIGHT = " & cota & " WHERE OBJECT_ID_ = '" & id_no & "'")
Else
Conn.execute ("UPDATE " + """" + a + """" + " SET " + """" + b + """" + " = '" & Round(cota) & "' WHERE " + """" + c + """" + " = '" + numero + "'")
' Dim coo As String
' coo = "UPDATE " + """" + a + """" + " SET " + """" + b + """" + " = '" & Round(cota) & "' WHERE " + """" + c + """" + " = '" + numero + "'"
'MsgBox "ARQUIVO DEBUG SALVO"
' WritePrivateProfileString "A", "A", coo, App.path & "\DEBUG.INI"
End If
ProgressBar1.value = ProgressBar1.value + 1
End If
Loop
Close #3
MousePointer = vbDefault
MsgBox "Cotas de Nós de Redes atualizadas com sucesso!", vbInformation, "Processo Concluído"
Trata_Erro:
If Err.Number = 0 Or Err.Number = 20 Then
Resume Next
Else
MousePointer = vbDefault
'PrintErro CStr(Me.Name), "cmdImportarCotas", CStr(Err.Number), CStr(Err.Description), True
MsgBox "Cotas de Nós de Redes atualizadas com sucesso!", vbInformation, "Processo Concluído"
End If
Unload Me
End Sub
Private Sub cmdProcuraArquivo_Click()
CDL.DialogTitle = "Localizar Arquivo"
CDL.ShowOpen
Me.Text1.Text = CDL.FileName
End Sub