Início
Olá, a propósito de questão de colega partilho exemplo para converter ficheiro de Excel no formato XML para XLS.
Código utilizado:
Abraço e bons estudos com o MaximoAccess
Código utilizado:
- Código:
Private Sub cmdConverter_Click()
'Álvaro Teixeira (ahteixeira) 2017 para MaximoAccess
'Requer referencia a Microsoft Office xx.0 Object Library
'Requer função "fncSelecionaFicheiro()" para escolher ficheiro
Dim ExcelObj As Object
Dim FileXLS As String
Dim FileXML As String
'Defenir que vai gravar o ficheiro na pasta
'onde esta a rolar esta base de dados
FileXLS = Application.CurrentProject.Path & "\materiais.xls"
If Len(Dir$(FileXLS)) > 0 Then 'apagar se já existe
SetAttr FileXLS, vbNormal
Kill FileXLS
End If
'selecionar ficheiro, chama função abaixo
FileXML = fncSelecionaFicheiro()
If Len(FileXML) & "" > 0 Then
Set ExcelObj = CreateObject("Excel.Application")
ExcelObj.Workbooks.Open FileXML 'abrir xml
ExcelObj.Application.DisplayAlerts = False
'ExcelObj.Application.ActiveWorkbook.CheckCompatibility = False
With ExcelObj
If Application.Version >= "12.0" Then
.ActiveWorkbook.SaveAs FileXLS, FileFormat:=56
Else
.ActiveWorkbook.SaveAs FileXLS
End If
End With
ExcelObj.Application.ActiveWorkbook.Close
ExcelObj.Application.DisplayAlerts = True
ExcelObj.Quit
Set ExcelObj = Nothing
MsgBox "Foi criado o ficheiro " & FileXLS, vbInformation, ""
End If
End Sub
Function fncSelecionaFicheiro() As String
'Álvaro Teixeira (ahteixeira) 2017 para MaximoAccess
'Requer referencia a Microsoft Office xx.0 Object Library
On Error GoTo PROC_ERR
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Title = "Selecione o ficheiro"
fd.InitialFileName = CurrentProject.Path
fd.Filters.Add "Ficheiro XLS", "*.xml", 1
fd.Show
If (fd.SelectedItems.Count > 0) Then
fncSelecionaFicheiro = fd.SelectedItems(1)
Else
MsgBox "Não foi escolhido nenhum ficheiro.", vbInformation, ""
End If
PROC_EXIT:
Exit Function
PROC_ERR:
DoCmd.Hourglass False
If Err.Number = 3011 Then
MsgBox "Ficheiro inválido.", vbInformation, ""
Else
MsgBox Err.Number & "-" & Err.Description, vbCritical, ""
End If
Resume PROC_EXIT
End Function
Abraço e bons estudos com o MaximoAccess
- Anexos
xml(ExcelWorkbook)2xls.zip - Você não tem permissão para fazer download dos arquivos anexados.
- (33 Kb) Baixado 70 vez(es)