Dim planilhas() As String
Dim caminho As String
Dim num As Integer
Dim ps As String
Private Function gera(plan As String) As String
Dim maquina As String 'nome da maquina
Dim patrimonio As String 'numero da plaqueta
Dim produto As String 'codigo do cartucho
Dim cor As String 'cor do cartucho/tonner
Dim tipo As String 'tipo do produto
Dim aux As String
Dim objExcel As Excel.Application
Set objExcel = New Excel.Application
'objExcel.Workbooks.Open caminho & plan & ".xls"
objExcel.Workbooks.Open plan & ".xls"
'impressoras
If plan = "IMPRESSORAS_CAMPUS_II" Then
' aux = ""
' For y = 2 To 171
' maquina = objExcel.Range("C" + LTrim(RTrim(Str(y))))
' patrimonio = objExcel.Range("G" + LTrim(RTrim(Str(y))))
' If (Len(LTrim(RTrim(patrimonio))) > 0) And (patrimonio <> ".") And (patrimonio <> "-.") Then
' aux = aux + "update SN1010 set N1_EQUIINF = '" + maquina + "' where (N1_CHAPA = '" + patrimonio + ".' Or N1_CHAPA = '" + patrimonio + "')" + Chr(13) + Chr(10)
' End If
' Next
' gera = aux
'cartuchos
ElseIf (plan = "CI - Referência de suprimentos para impressoras") Then
' aux = ""
' For y = 2 To 48
' maquina = objExcel.Range("A" + LTrim(RTrim(Str(y))))
' produto = objExcel.Range("D" + LTrim(RTrim(Str(y))))
' cor = objExcel.Range("C" + LTrim(RTrim(Str(y))))
' 'gera = maquina + " | " + patrimonio
' 'aux = aux + "update SN1010 set N1_EQUIINF = '" + maquina + "' where N1_CHAPA = '" + patrimonio + ".'" + Chr(13) + Chr(10)
' If InStr(1, cor, "-") Then
' cor = Mid(cor, InStr(1, cor, "-") + 2)
' End If
' 'P=Preto;C=Colorido;M=Magenta;I=Ciano;A=Amarelo;G=Magenta Claro;N=Ciano Claro
' If InStr(1, cor, "preto") Then
' cor = "P"
' ElseIf InStr(1, cor, "Color") Then
' cor = "C"
' ElseIf (InStr(1, cor, "Magenta")) And (Not (InStr(1, cor, "claro"))) Then
' cor = "M"
' ElseIf (InStr(1, cor, "Ciano")) And (Not (InStr(1, cor, "claro"))) Then
' cor = "I"
' ElseIf InStr(1, cor, "Amarelo") Then
' cor = "A"
' ElseIf InStr(1, cor, "Magenta Claro") Then
' cor = "G"
' ElseIf InStr(1, cor, "Ciano Claro") Then
' cor = "N"
' Else
' cor = ""
' End If
' 'aux = aux + "impressora=" + maquina + " - produto=" + produto + " - cor=" + cor + Chr(13) + Chr(10)
' aux = aux + "insert into CartuhosDasImpressoras (Impressora, Cor, Produto ) values ('" + maquina + "', '" + cor + "', '" + produto + "')" + Chr(13) + Chr(10)
' Next
' gera = aux
'cartuchos atualizados
ElseIf (plan = "C:Documentos_AndréTrabalhoProgramaçãoExcelfichas_cartImpressorasPatrimoniosSuprimentos que ter CAR") Then
aux = ""
For y = 2 To 286
patrimonio = objExcel.Range("C" + LTrim(RTrim(Str(y))))
maquina = objExcel.Range("D" + LTrim(RTrim(Str(y))))
produto = objExcel.Range("F" + LTrim(RTrim(Str(y))))
cor = objExcel.Range("G" + LTrim(RTrim(Str(y))))
tipo = objExcel.Range("H" + LTrim(RTrim(Str(y))))
'gera = maquina + " | " + patrimonio
'aux = aux + "update SN1010 set N1_EQUIINF = '" + maquina + "' where N1_CHAPA = '" + patrimonio + ".'" + Chr(13) + Chr(10)
'P=Preto;C=Colorido;M=Magenta;I=Ciano;A=Amarelo;G=Magenta Claro;N=Ciano Claro
If cor = "PRETO" Then
cor = "P"
ElseIf cor = "COLORIDO" Then
cor = "C"
ElseIf cor = "MAGENTA" Then
cor = "M"
ElseIf cor = "CIANO" Then
cor = "I"
ElseIf cor = "AMARELO" Then
cor = "A"
ElseIf cor = "MAGENTA CLARO" Then
cor = "G"
ElseIf cor = "CIANO CLARO" Then
cor = "N"
Else
cor = ""
End If
If tipo = "CARTUCHO" Then
tipo = "C"
ElseIf tipo = "TONER" Then
tipo = "T"
ElseIf tipo = "CABEÇA DE IMPRESSAO" Then
tipo = "B"
ElseIf tipo = "RIBBON" Then
tipo = "R"
Else
tipo = ""
End If
aux = aux + "update SN1010 set N1_EQUIINF = '" + maquina + "' where (N1_CHAPA = '" + patrimonio + ".' Or N1_CHAPA = '" + patrimonio + "')" + Chr(13) + Chr(10)
'aux = aux + "insert into CartuhosDasImpressoras (Impressora, Cor, Produto, TipoProduto) values ('" + maquina + "', '" + cor + "', '" + produto + "','" + tipo + "')" + Chr(13) + Chr(10)
Next
gera = aux
'cartuchos
ElseIf (plan = "CII - Referência de suprimentos para impressoras") Then
' aux = ""
' For y = 2 To 286
' maquina = objExcel.Range("A" + LTrim(RTrim(Str(y))))
' produto = objExcel.Range("D" + LTrim(RTrim(Str(y))))
' cor = objExcel.Range("C" + LTrim(RTrim(Str(y))))
' 'gera = maquina + " | " + patrimonio
' 'aux = aux + "update SN1010 set N1_EQUIINF = '" + maquina + "' where N1_CHAPA = '" + patrimonio + ".'" + Chr(13) + Chr(10)
' If InStr(1, cor, "-") Then
' cor = Mid(cor, InStr(1, cor, "-") + 2)
' End If
' 'P=Preto;C=Colorido;M=Magenta;I=Ciano;A=Amarelo;G=Magenta Claro;N=Ciano Claro
' If InStr(1, cor, "preto") Then
' cor = "P"
' ElseIf InStr(1, cor, "Color") Then
' cor = "C"
' ElseIf (InStr(1, cor, "Magenta")) And (Not (InStr(1, cor, "claro"))) Then
' cor = "M"
' ElseIf (InStr(1, cor, "Ciano")) And (Not (InStr(1, cor, "claro"))) Then
' cor = "I"
' ElseIf InStr(1, cor, "Amarelo") Then
' cor = "A"
' ElseIf InStr(1, cor, "Magenta Claro") Then
' cor = "G"
' ElseIf InStr(1, cor, "Ciano Claro") Then
' cor = "N"
' Else
' cor = ""
' End If
' 'aux = aux + "impressora=" + maquina + " - produto=" + produto + " - cor=" + cor + Chr(13) + Chr(10)
' aux = aux + "insert into CartuhosDasImpressoras (Impressora, Cor, Produto ) values ('" + maquina + "', '" + cor + "', '" + produto + "')" + Chr(13) + Chr(10)
' Next
' gera = aux
Else
' maquina = objExcel.Range("K2")
' patrimonio = objExcel.Range("B14")
' 'gera = maquina + " | " + patrimonio
' If (Len(LTrim(RTrim(patrimonio))) > 0) And (patrimonio <> ".") And (patrimonio <> "-.") Then
' gera = "update SN1010 set N1_EQUIINF = '" + maquina + "' where (N1_CHAPA = '" + patrimonio + ".' Or N1_CHAPA = '" + patrimonio + "')"
' End If
End If
Set objExcel = Nothing
ps = "C:TempPstoolspskill excel"
Shell ps
End Function
Private Sub Command1_Click()
Dim x As Integer, y As Integer
Dim strRetorno As String
Dim strAux As String
Screen.MousePointer = vbHourglass
'para cada planilha
For x = 1 To num
If planilhas(x) <> "" Then
strAux = gera(planilhas(x))
strRetorno = strRetorno + strAux + Chr(13) + Chr(10)
End If
Next
Open "C:Documentos_AndréTrabalhoProgramaçãoExcelTeste.txt" For Output As #1
Print #1, strRetorno
Close #1
Screen.MousePointer = vbNormal
MsgBox "Ok"
Shell ps
End Sub
Private Sub Form_Load()
num = 13
caminho = "C:Documentos_AndréTrabalhoProgramaçãoExcelfichas"
ReDim planilhas(1)
'subPegaArquivos "C:Documentos_AndréTrabalhoProgramaçãoExcelfichasFichas suporte", "_"
'subPegaArquivos "C:Documentos_AndréTrabalhoProgramaçãoExcelfichas_cart", "_"
'planilhas(1) = "SEC-208"
'planilhas(2) = "SEC-209"
'ReDim Preserve planilhas(15)
'planilhas(3) = "SEC-210"
'planilhas(4) = "SEC-211"
'planilhas(5) = "SEC-212"
'planilhas(6) = "SEC-216"
'planilhas(7) = "SEC-217"
'planilhas(8) = "SEC-218"
'planilhas(9) = "SEC-221"
'planilhas(10) = "SEC-223"
' num = UBound(planilhas) + 1
' ReDim Preserve planilhas(num)
' planilhas(num) = "C:Documentos_AndréTrabalhoProgramaçãoExcelfichasIMPRESSORAS_CAMPUS_II"
' num = UBound(planilhas) + 1
' ReDim Preserve planilhas(num)
' planilhas(num) = "C:Documentos_AndréTrabalhoProgramaçãoExcelfichasCII - Referência de suprimentos para impressoras"
' num = UBound(planilhas) + 1
' ReDim Preserve planilhas(num)
' planilhas(num) = "C:Documentos_AndréTrabalhoProgramaçãoExcelfichasCI - Referência de suprimentos para impressoras"
'
' ReDim Preserve planilhas(num)
' planilhas(num) = "C:Documentos_AndréTrabalhoProgramaçãoExcelfichasCI - Referência de suprimentos para impressoras"
ReDim Preserve planilhas(num)
planilhas(num) = "C:Documentos_AndréTrabalhoProgramaçãoExcelfichas_cartImpressorasPatrimoniosSuprimentos que ter CAR"
ps = "C:TempPstoolspskill excel"
Shell ps
End Sub
'Desenvolvedor......: André Martini -
andremartini@feevale.br - Ramal 8823
'Data de criação....: 20/12/2004
'Funcionalidade.....: esta sub serve pegar todos os arquivos de projetos que estão na pasta de origem
'...................: o parâmetro 'strPriCarac' é utilizado para informar uma string para que o sistema
'...................: não busque arquivos nas pasta que iniciam com esta string
'Referências de uso.: frmPrincipal
'Exemplo de uso.....: subPegaArquivos txtPastaOrigem.Text, "_"
'Destacar alterações:
Private Sub subPegaArquivos(strPastaOrigem As String, strPriCarac As String)
Dim nplan As Integer
'Cria instância do FSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolderOrigem = objFSO.GetFolder(strPastaOrigem)
Set objFoldersSubOrig = objFolderOrigem.SubFolders
'Para cada pasta na coleção de subpastas da pasta origem
For Each objfolder In objFoldersSubOrig
'se procura arquivos nas pastas que não iniciam pela string 'strPriCarac'
If Left(objfolder.Name, Len(strPriCarac)) <> strPriCarac Then
'Chama recursivo enquanto tiver subpasta
subPegaArquivos objfolder.Path, strPriCarac
'Para cada arquivo na coleção de arquivos da pasta
For Each objFile In objfolder.Files
'Verifica se o arquivo encontrado é do tipo XLS
If ((LCase(Right(objFile.Path, 3))) = "xls") Then
'If Len(LTrim(RTrim(planilhas(1))) = 0) Then
' planilhas(1) = Mid(objFile.Path, 1, Len(objFile.Path) - 4)
'Else
nplan = UBound(planilhas) + 1
ReDim Preserve planilhas(nplan)
planilhas(nplan) = Mid(objFile.Path, 1, Len(objFile.Path) - 4)
'End If
End If
Next
End If
Next
End Sub
