Saudações a todos estou com um problema que não consigo identificar em uma adaptação de um código do mestre JPaulo
Não sei por que ele não adiciona o ultimo arquivo funcoes.xml já verifiquei ele está sendo criado corretamente e o caminho tbm está correto só não adiciona ao arquivo .zip alguém poderia me ajudar a achar o erro não estou conseguindo identificar.
desde já muito agradecido a todos
- Código:
Private Sub btGerar_Click()
Dim caminhoXml As String
Dim arqFerias, arqFuncionarios, arqSecretaria, arqFuncoes As String
'caminho para exportação
caminhoXml = DLookup("caminhoXml", "tblConfig")
If Right(caminhoXml, 1) <> "\" Then
caminhoXml = caminhoXml & "\"
End If
'nomes de arquivos
arqFerias = caminhoXml & "ferias.xml"
arqFuncionarios = caminhoXml & "funcionarios.xml"
arqSecretaria = caminhoXml & "secretarias.xml"
arqFuncoes = caminhoXml & "funcoes.xml"
'exporta xml
Application.ExportXML acExportQuery, "ferias", arqFerias, , , , acUTF8, , "mesInc=" & Me.cboMesInc.Column(0) & " and anoInc=" & Me.txtAno.Value
Application.ExportXML acExportQuery, "funcionario", arqFuncionarios, , , , acUTF8
Application.ExportXML acExportQuery, "secretaria", arqSecretaria, , , , acUTF8
Application.ExportXML acExportQuery, "funcao", arqFuncoes, , , , acUTF8
'zipa arquivos
Call ZipaXml(arqFerias, arqFuncionarios, arqSecretaria, arqFuncoes)
End Sub
Function ZipaXml(ferias, funcionarios, secretarias, funcoes)
'Criado pelo meu amigo e colega Raw do Canadá
'Adaptado por JPaulo Maximo Access
Dim strDate As String, DefPath As String
Dim oApp As Object
Dim FileNameZip
Dim nomeArq As String
'arquivo zip
nomeArq = Me.cboMesInc.Column(0) & "-" & Me.txtAno.Value
FileNameZip = DLookup("caminhoXml", "tblConfig") & nomeArq & ".zip"
'cria o arquivo zip
CriaNovoZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
'add arquivos ao zip
oApp.NameSpace(FileNameZip).CopyHere ferias
oApp.NameSpace(FileNameZip).CopyHere funcionarios
oApp.NameSpace(FileNameZip).CopyHere secretarias
oApp.NameSpace(FileNameZip).CopyHere funcoes
'sucesso
MsgBox "Criado com Sucesso em: " & FileNameZip
Set oApp = Nothing
'deleta os xml
Kill ferias
Kill funcionarios
Kill secretarias
Kill funcoes
Exit Function
End Function
Public Sub CriaNovoZip(sPath)
'Criado pelo meu amigo e colega Raw do Canada
'Adaptado por JPaulo ? Maximo Access
Dim ofso, arrHex, sBin, i, Zip
On Error Resume Next
Set ofso = CreateObject("Scripting.FileSystemObject")
arrHex = Array(80, 75, 5, 6, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
For i = 0 To UBound(arrHex)
sBin = sBin & Chr(arrHex(i))
Next
On Error Resume Next
With ofso.CreateTextFile(sPath, True)
.Write sBin
.Close
End With
Exit Sub
End Sub
Não sei por que ele não adiciona o ultimo arquivo funcoes.xml já verifiquei ele está sendo criado corretamente e o caminho tbm está correto só não adiciona ao arquivo .zip alguém poderia me ajudar a achar o erro não estou conseguindo identificar.
desde já muito agradecido a todos