Exportando seus dados para diversos formatos

VB6 - Exportando .mdb para doc , xls, ppt , xml e html

Que tal uma aplicação que realize a exportação dos dados de uma tabela para os formatos .doc, .xls, .ppt, .xml e .html ? Pois lhe apresento a aplicação mostrando o seu formulário principal:

Esta aplicação embora seja simples pode ensinar muitas coisas para quem esta aprendendo a linguagem Visual Basic:

Como usar arquivos .INI para armazenar/recuperar configurações da aplicação
Como abrir um arquivo associado ao seu programa sem conhecer a sua extensão.
Como acessar um banco de dados via ADO
Como acessar e relacionar as tabelas do banco de dados via ADO
Verificar se um diretório existe
Criar um diretório
Usar a barra de progresso
Usar a caixa de diálogo Procurar Arquivos

O programa funciona assim:

O usuário clica no botão para informar o caminho e nome do banco de dados e selecione um arquivo .mdb;
A combobox cboTabela será preenchida com os nomes das tabelas do banco de dados selecionado;
O usuário seleciona uma tabela;
O usuário informa o nome do arquivo para qual pretende exporta dos dados tabela informando a extensão;
O usuário seleciona uma das opções para exporta (o nome do arquivo deve possuir a extensão correspondente a opção marcada)
O usuário clica no botão Iniciar
Após a exportação ter sido realizada o usuário pode abrir o arquivo clicando no botão Verificar

A seguir será apresentado o código do projeto. Antes é importante mencionar as referências que você deve incluir no seu projeto. Você já deve saber fazer isto mas vamos lá: Com o projeto aberto, no menu Project selecione a opção References... Inclua as referências para o Word, Excel , PowerPoint e XML conforme a figura abaixo (O PowerPoint não aparece pois eu não o tenho instalado).

Nota: Dependendo da versão do pacote Office que você tiver instalado o nome das referências podem ser diferentes dos exibidos na figura.

O código do evento Load faz o seguinte :

Define os valores usados pela caixa de diálogo Procurar Arquivos;
Obtém o caminho de destino do arquivo .INI;
Chama a rotina verificaDestino para ver se o diretório existe. Se o diretório não existir ele será criado.

Private Sub Form_Load()
'define o titulo do diálogo
cmdlg1.DialogTitle = "Procurar Arquivos .mdb"
'define o caminho inicial
cmdlg1.InitDir = App.Path
'define o filtro para exibir os arquivos
cmdlg1.filter = "Arqs. MDB(*.mdb)|*.mdb|Todos " & "Arqs. (*.*)|*.*"
cmdlg1.FilterIndex = 1
'define algumas variaveis de forma que o usuário possas selecionar somente arquivos que existam , exibe
'nome de arquivos longos e usa a interface estilo do Explorer
'cmdlg1.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly + cdlOFNLongNames + cdlOFNExplorer
'dispara um erro se não for selecionado algo
cmdlg1.CancelError = True
cmdVerificar.Enabled = False
txtDestino.Text = ReadINI("Geral", "Caminho", App.Path & "\exporta.INI")
verificaDestino (txtDestino.Text)
End Sub

O código para a rotina verificaDestino é dada a seguir. Este rotina usa a função DiretorioExiste para ver se o diretório informado existe.

Private Sub verificaDestino(caminho As String)
On Error GoTo trataerro

If Not DiretorioExiste(caminho) Then
MkDir caminho
Else
MsgBox "O caminho : " & caminho & " já existe..."
End If
Exit Sub
trataerro:
MsgBox "Erro ao criar diretório : " & caminho
End Sub

Private Function DiretorioExiste(strDir As String) As Boolean
Dim i As String
Dim resultado As String
On Error Resume Next

resultado = Dir(strDir, vbDirectory)

If resultado = "." Then
DiretorioExiste = True
Else
DiretorioExiste = False
End If
End Function

Quando o usuário clicar no botão para selecionar o banco de dados o evento Click do botão cmdSelecionaBD será disparado. No código abaixo associado a este evento vemos que a caixa de diálogo Procurar Arquivos será aberta e o nome selecionado será atribuído a caixa de texto txtArquivo.text e a rotina cmdExibeTabelas para obter as tabelas do banco de dados será chamada;

Private Sub cmdSelecioneBD_Click()
On Error Resume Next

'exibe a caixa de diálogo Abrir Arquivo
cmdlg1.ShowOpen

If Err.Number <> 0 Then
   ' erro desconhecido
   MsgBox "Erro " & Err.Number & " ao selecionar o arquivo."
   Exit Sub
End If

On Error GoTo 0

'atribui o nome do arquivo selecionado a caixa de texto
txtArquivo.Text = cmdlg1.FileName
cmdExibeTabelas

End Sub

O código da rotina cmdExibeTabelas() , exibida a seguir, usa a propriedade TableSchema para obter o as tabelas do banco de dados e preencher a combobox com o nome de cada tabela

Private Sub cmdExibeTabelas()
'define objetos
Dim TablesSchema As ADODB.Recordset

On Error GoTo trataerro

If txtArquivo.Text = "" Then Exit Sub

If cnn.State = 1 Then cnn.Close

cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtArquivo.Text
rs.CursorLocation = adUseClient

'limpa o listbox
cboTabela.Clear

'obtém todas as tabelas do banco de dados.
Set TablesSchema = cnn.OpenSchema(adSchemaTables)

Do While Not TablesSchema.EOF
   ' lista o nome das tabelas
   ' Não permite as tabelas do sistema
If Left(TablesSchema("TABLE_NAME"), 4) <> "MSys" Then
       cboTabela.AddItem TablesSchema("TABLE_NAME")
End If
TablesSchema.MoveNext
Loop

Exit Sub

trataerro:
    MsgBox "Erro " & Err.Number & vbCrLf & Err.Description
End Sub

A seguir temos as rotinas para exporta a tabela selecionada para cada um dos formatos desejado.

1- Exportando para o formato .doc do Microsoft Word:

Private Sub WordExportacao()
'On Error GoTo CheckWord
On Error Resume Next

Dim wd As New Word.Application
Dim doc As Word.Document
Dim tb As Word.Table
Dim f As ADODB.Field
Dim k As Integer
Dim i As Integer

   If cnn.State = 1 Then cnn.Close

   cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtArquivo.Text
   rs.CursorLocation = adUseClient
rs.Open "select * from " & cboTabela.Text, cnn, 2, 3
   pb.Max = rs.RecordCount
   pb.Value = 0
   Screen.MousePointer = vbHourglass
   Set doc = wd.Documents.Add
   Set tb = doc.Tables.Add(wd.Selection.Range, rs.RecordCount + 1, rs.Fields.Count)

    k = 1
    For Each f In rs.Fields
           tb.Cell(1, k).Range.Font.Bold = True
           tb.Cell(1, k).Range.Text = f.Name
           k = k + 1
   Next
   rs.MoveFirst

For i = 1 To rs.RecordCount
   pb.Value = i
   k = 1
    For Each f In rs.Fields
        tb.Cell(i + 1, k).Range.Text = rs.Fields(f.Name)
         k = k + 1
    Next
    rs.MoveNext
Next

Screen.MousePointer = vbNormal
MsgBox "Conversão realizada com sucesso"
pb.Value = 0

doc.SaveAs txtDestino.Text
Set doc = Nothing
Set w = Nothing
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
'Exit Sub
'CheckWord:
'MsgBox Err.Description

End Sub

2- Exportando para o formato .xls do Microsoft Excel:

Private Sub ExcelExportacao()

On Error GoTo CheckExcel

Dim exc As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Dim f As ADODB.Field
Dim k As Integer
Dim i As Integer

If cnn.State = 1 Then cnn.Close

cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtArquivo.Text
rs.CursorLocation = adUseClient
rs.Open "select * from " & cboTabela.Text, cnn, 2, 3
pb.Max = rs.RecordCount
pb.Value = 0
Screen.MousePointer = vbHourglass
Set wb = exc.Workbooks.Add
Set ws = wb.Worksheets.Add
ws.Cells.Clear
k = 1
For Each f In rs.Fields
    ws.Cells(1, k).Font.Bold = True
    ws.Cells(1, k) = f.Name
    k = k + 1
Next
rs.MoveFirst

For i = 1 To rs.RecordCount
   pb.Value = i
   k = 1
   For Each f In rs.Fields
        If IsDate(rs.Fields(f.Name)) = True Then
        ws.Cells(i + 1, k) = Format(rs.Fields(f.Name))
Else
   ws.Cells(i + 1, k) = rs.Fields(f.Name)
End If

ws.Columns(k).AutoFit
k = k + 1
Next
rs.MoveNext
Next
Screen.MousePointer = vbNormal
MsgBox "Conversão realizada com sucesso"
pb.Value = 0
wb.SaveAs txtDestino.Text
wb.Close True
Set exc = Nothing
Set wb = Nothing
Set ws = Nothing
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
Exit Sub
CheckExcel:
MsgBox Err.Description

End Sub

3- Exportando para o formato .ppt do Microsoft PowerPoint:

Private Sub PowerPointExportacao()

On Error GoTo CheckPP

Dim rs As New ADODB.Recordset
Dim pp As New PowerPoint.Application
Dim pt As PowerPoint.Presentation
Dim slide As PowerPoint.slide
Dim st As String
Dim st1 As String

If cnn.State = 1 Then cnn.Close

cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtArquivo.Text
rs.CursorLocation = adUseClient
rs.Open "select * from " & cboTabela.Text, cnn, 2, 3
pb.Max = rs.RecordCount
pb.Value = 0
Screen.MousePointer = vbHourglass
Set pt = pp.Presentations.Add

Dim f As ADODB.Field
Dim f1 As ADODB.Field
Dim i As Integer
Dim t As Integer

rs.MoveFirst
For i = 1 To rs.RecordCount
   pb.Value = i
   Set slide = pt.Slides.Add(i, ppLayoutText)

   For Each f In rs.Fields
       st = st & f.Name & " : " & rs.Fields(f.Name) & vbCrLf
       slide.Shapes(2).TextFrame.TextRange.Text = st
       slide.Shapes(2).TextFrame.TextRange.Font.Size = 12
   Next
   st = st & vbCrLf
   st = ""
   rs.MoveNext
Next

Screen.MousePointer = vbNormal
MsgBox "Conversão realizada com sucesso"
pb.Value = 0
pt.SaveAs txtDestino.Text
Set pp = Nothing
Set pt = Nothing
Set slide = Nothing
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
Exit Sub
CheckPP:
MsgBox Err.Description

End Sub

4- Exportando para o formato .html:

Private Sub HtmlExportacao()

On Error GoTo CheckHtml

Dim f As ADODB.Field
Dim i As Integer

If cnn.State = 1 Then cnn.Close

cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtArquivo.Text
rs.CursorLocation = adUseClient
rs.Open "select * from " & cboTabela.Text, cnn, 2, 3
pb.Max = rs.RecordCount
pb.Value = 0
Screen.MousePointer = vbHourglass

Open txtDestino.Text For Output As #1
Print #1, "<HTML>"
Print #1, "<BODY ALIGN=CENTER>"
Print #1, "<TABLE BORDER=1>"
Print #1, "<TR>"
For Each f In rs.Fields
    Print #1, "<TD><B>" & f.Name & "</B></TD>"
Next

Print #1, "</TR>"

For i = 1 To rs.RecordCount
   pb.Value = i
   Print #1, "<TR>"
   For Each f In rs.Fields
      Print #1, "<TD>" & rs.Fields(f.Name) & "</TD>"
   Next
   Print #1, "</TR>"
   rs.MoveNext
Next
Screen.MousePointer = vbNormal
MsgBox "Conversão realizada com sucesso"
pb.Value = 0
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
Print #1, "</TABLE>"
Print #1, "</BODY>"
Print #1, "</HTML>"
Close #1
Exit Sub
CheckHtml:
MsgBox Err.Description

End Sub

4- Exportando para o formato .xml:

Private Sub XmlExportacao()
'On Error GoTo CheckXml

On Error Resume Next

Dim xmlDoc As New DOMDocument
Dim xmlroot As IXMLDOMElement
Dim node As IXMLDOMNode
Dim XMLRootTags As String, done As Boolean
Dim f As ADODB.Field
Dim i As Integer

If cnn.State = 1 Then cnn.Close

cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtArquivo.Text
rs.CursorLocation = adUseClient
rs.Open "select * from " & cboTabela.Text, cnn, 2, 3
pb.Max = rs.RecordCount
pb.Value = 0
Screen.MousePointer = vbHourglass
XMLRootTags = "<Root></Root>"
done = xmlDoc.loadXML(XMLRootTags)

If done = True Then
    Set xmlroot = xmlDoc.documentElement
    For i = 1 To rs.RecordCount
        pb.Value = i
        Set node = xmlDoc.createNode(NODE_ELEMENT, "Node" & i, "")
        xmlroot.appendChild node
        Set nodeTag = xmlroot.selectSingleNode("Node" & i)
        For Each f In rs.Fields
           Set node = xmlDoc.createNode(NODE_ELEMENT, f.Name, "")
           node.Text = rs.Fields(f.Name)
           nodeTag.appendChild node
        Next
       rs.MoveNext
   Next
Else
   MsgBox "error"
Exit Sub
End If
Screen.MousePointer = vbNormal
MsgBox "Conversão realizada com sucesso"
pb.Value = 0
xmlDoc.Save txtDestino.Text
rs.Close
Set rs = Nothing
cnn.Close
Set cnn = Nothing
' Exit Sub
'CheckXml:
' MsgBox Err.Description

End Sub

Agora temos o código do botão - Iniciar - que verifica se a seleção do usuário esta correta e chama as rotinas acima.

Private Sub cmdOK_Click()
If txtArquivo.Text = "" Or cboTabela.Text = "" Or txtDestino.Text = "" Then
     MsgBox "Dados inválidos, verifique se informou todas as informações.", vbCritical, "Super Exportador"
Else
If optWord And Right(txtDestino.Text, 4) = ".doc" Then
     Call WordExportacao
ElseIf optExcel And Right(txtDestino.Text, 4) = ".xls" Then
   Call ExcelExportacao
   ElseIf optPowerPoint And Right(txtDestino.Text, 4) = ".ppt" Then
     Call PowerPointExportacao
   ElseIf optHtml And Right(txtDestino.Text, 5) = ".html" Then
    Call HtmlExportacao
ElseIf optXml And Right(txtDestino.Text, 4) = ".xml" Then
     Call XmlExportacao
Else
    MsgBox "Extensão do arquivo de destino inválida...", vbCritical, "Super Exportador"
End If
cmdOK.Enabled = False
cmdVerificar.Enabled = False
End If
End Sub

Se a exportação para um dos formatos foi bem sucedida o usuário pode clicar no botão - Verificar - cujo código é dado abaixo. A rotina IniciarDoc() é chamada e é feita a verificação de erro.

Private Sub cmdVerificar_Click()

Dim r As Long,
dim msg As String

r = IniciarDoc(txtDestino.Text)
If r <= 32 Then

'há um erro
Select Case r
   Case SE_ERR_FNF
         msg = "Arquivo não encontrado"
    Case SE_ERR_PNF
        msg = "Caminho não encontrado"
    Case SE_ERR_ACCESSDENIED
        msg = "Acesso negado."
     Case SE_ERR_OOM
        msg = "Sem memória"
     Case SE_ERR_DLLNOTFOUND
        msg = "DLL não encontrada"
     Case SE_ERR_SHARE
        msg = "Ocorreu violação de compartilhamento"
     Case SE_ERR_ASSOCINCOMPLETE
        msg = "Associação incompleta ou inválida"
     Case SE_ERR_DDETIMEOUT
       msg = "DDE - tempo expirado"
     Case SE_ERR_DDEFAIL
       msg = "DDE - transação falhou"
     Case SE_ERR_DDEBUSY
        msg = "DDE - ocupado"
     Case SE_ERR_NOASSOC
       msg = "Não há associação ou extensão do arquivo"
     Case ERROR_BAD_FORMAT
        msg = "EXE invalido ou erro no EXE"
    Case Else
       msg = "Ocorreu um erro não conhecido..."
End Select
MsgBox msg
End If
cmdVerificar.Enabled = False
End Sub

A aplicação permite que o usuário configure o caminho armazenando a informação em um arquivo .INI. Abaixo temos a tela do formulário usado para este fim.

O código do formulário é usado a seguir. Nela usamos as rotinas WriteINI e ReadINI definidas no módulo do sistema, para gravar e ler a partir do arquivo exporta.ini .

Option Explicit
Private Sub Command1_Click()

Call WriteINI("Geral", "Usuario", Text1.Text, App.Path & "\exporta.ini")
Call WriteINI("Geral", "Caminho", Text2.Text, App.Path & "\exporta.ini")

MsgBox "Dados gravados com sucesso !!! "

End Sub
Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Me.Width = 6780
Me.Height = 2865
Text1.Text = ReadINI("Geral", "Usuario", App.Path & "\exporta.INI")
Text2.Text = ReadINI("Geral", "Caminho", App.Path & "\exporta.INI")
End Sub

Private Sub Form_Resize()
Me.Width = 6780
Me.Height = 2865
End Sub

A seguir temos os códigos associados aos eventos dos botões de comando

Private Sub mnuConfigurar_Click()
'abre o formulário de configuração
frmconfig.Show vbModal
End Sub

Private Sub mnuSair_Click()
cmdCancel_Click
End Sub

Private Sub txtArquivo_Change()
cmdOK.Enabled = True
End Sub

Private Sub txtDestino_Change()
cmdOK.Enabled = True
End Sub

Private Sub cboTabela_Change()
cmdOK.Enabled = True
End Sub

O código para encerrar a aplicação:

Private Sub cmdCancela_Click()
If (MsgBox("Confirma encerramento do programa ? ", vbYesNo, "Super Exportador") = vbYes) Then
Unload Me
End If
End Sub

Quase ia esquecendo falta o código do módulo usado pelo sistema:

Public cnn As New ADODB.Connection
Public rs As New ADODB.Recordset

'API para executar um programa associado a uma extensão
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As String, _
ByVal lpszFile As String, ByVal lpszParams As String, ByVal LpszDir As String, ByVal FsShowCmd As Long) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long

'declaracoes usadas para gravar e ler arquivos INI
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Const SW_SHOWNORMAL = 1

Const SE_ERR_FNF = 2&
Const SE_ERR_PNF = 3&
Const SE_ERR_ACCESSDENIED = 5&
Const SE_ERR_OOM = 8&
Const SE_ERR_DLLNOTFOUND = 32&
Const SE_ERR_SHARE = 26&
Const SE_ERR_ASSOCINCOMPLETE = 27&
Const SE_ERR_DDETIMEOUT = 28&
Const SE_ERR_DDEFAIL = 29&
Const SE_ERR_DDEBUSY = 30&
Const SE_ERR_NOASSOC = 31&
Const ERROR_BAD_FORMAT = 11&

Function IniciarDoc(DocName As String) As Long
Dim Scr_hDC As Long
Scr_hDC = GetDesktopWindow()
IniciarDoc = ShellExecute(Scr_hDC, "Open", DocName, "", "C:\", SW_SHOWNORMAL)
End Function

Public Sub WriteINI(Section As String, Key As String, Text As String, FileName As String)
'Filename=nome do arquivo ini
'section=O que esta entre []
'key=nome do que se encontra antes do sinal de igual
'text= valor que vem depois do igual
WritePrivateProfileString Section, Key, Text, FileName
End Sub

Public Function ReadINI(Section As String, Key As String, FileName As String)
'Filename=nome do arquivo ini
'section=O que esta entre []
'key=nome do que se encontra antes do sinal de igual
Dim retlen As String
Dim Ret As String
Ret = String$(255, 0)
retlen = GetPrivateProfileString(Section, Key, "", Ret, Len(Ret), FileName)
Ret = Left$(Ret, retlen)
ReadINI = Ret
End Function

Abaixo temos as telas mostrando a aplicação exportando para o formato .xls (Excel) em duas etapas: a exportação e a verificação.

O velho e bom Visual Basic com dois formulários e um módulo fez um trabalho bem feito.

Até o próximo artigo VB...

Veja os Destaques e novidades do SUPER DVD Visual Basic (sempre atualizado) : clique e confira !

Quer migrar para o VB .NET ?

Veja mais sistemas completos para a plataforma .NET no Super DVD .NET , confira...
Curso Básico VB .NET - Vídeo Aulas

Quer aprender C# ??

Chegou o Super DVD C# com exclusivo material de suporte e vídeo aulas com curso básico sobre C#.
Curso C# Basico - Video Aulas

Quer aprender os conceitos da Programação Orientada a objetos ?

Curso Fundamentos da Programação Orientada a Objetos com VB .NET

Quer aprender o gerar relatórios com o ReportViewer no VS 2013 ?

Curso - Gerando Relatórios com o ReportViewer no VS 2013 - Vídeo Aulas

Referências:

José Carlos Macoratti