VBA Excel - Protegendo planilha.

Hello folks...

Invariavelmente vez ou outra decidirá proteger suas planilhas contra o uso inapropriado por
terceiros.

Alguns limitam o uso da planilha por algum tempo, não permitindo que a mesma seja aberta após um período. Outro optam radicalmente pela deleção da planilha inteira.

Como sempre pensamos...Como fazê-lo?

Private Sub Workbook_Open()
             Dim nMess1 as String
             Dim nMess2 as String

             Let ExpDt = #31/07/2009#
             Let nMess1 = "Arquivo expirado. Digite a senha para poder acessá-lo"
             Let nMess2 = "Acesso Negado!"

             If Date > DataExpira Then
                          Let Senha = Application.InputBox(nMess1, "Expirado")

            
             If Senha <> 123 Then
                          MsgBox Prompt:=nMess2, Button:=vbOKOnly + vbCritical

            
             ThisWorkbook.Close SaveChanges:=False
                          End If
             End If
End Sub


A opção adicional é substituir a linha:
ThisWorkbook.Close SaveChanges:=False

Para deleção completa:
     ThisWorkbook.Saved = True
     ThisWorkbook.ChangeFileAccess xlReadOnly
     Kill ThisWorkbook.FullName
     Application.Quit




Google Talk: bernardess@gmail.com
Skype: inanyplace
MSN:
bernardess@gmail.com

VBA - Definindo a Impressora

VBA - Definindo a Impressora


Alguns dos nossos relatórios, listas, tabelas, textos, comentários podem ser dirigidos diretamente para algumas impressoras, sem que necessariamente sejam úteis, legíveis ou apropriados.

Podemos definir a impressão de certos relatórios por usuário, impedindo que a impressão ocorra numa impressora colorida por exemplo.

Talvez queira enviar certos relatórios diretamente para uma impressora instalada como driver conversor de PDF. Mas como?

Sub PrintToPDF()
        Dim originalPrinter

        'MsgBox "A impressora ativa no momento é: " & Chr(13) & Chr(13) & Application.ActivePrinter

        Let originalPrinter = Application.ActivePrinter

        'Application.ActivePrinter = "CutePDF Writer on SERV2:"
        'ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:='"CutePDF Writer on SERV2:",                 Collate:=True

        ActiveWindow.SelectedSheets.PrintOut Copies:=1, ActivePrinter:="CutePDF Writer on SERV2:",                 Collate:=True

        'Let folder = Environ("Temp")

        Let  Filename = Sheet2.Cells(30, 15).Value & ".pdf"
        Let folder = Environ("Temp")
        Let newHour = Hour(Now())
        Let newMinute = Minute(Now())
        Let newSecond = Second(Now()) + 1
        Let waitTime = TimeSerial(newHour, newMinute, newSecond)

        Application.Wait waitTime

        SendKeys Filename

        'MsgBox "A impressora ativa no momento é: " & Chr(13) & Chr(13) & Application.ActivePrinter

        Let  Application.ActivePrinter = originalPrinter

        'MsgBox "A impressora ativa no momento é: " & Chr(13) & Chr(13) & Application.ActivePrinter
End Sub

Mas talvez deseje que o usuário escolha a impressora a usar:

        Let nOpt = Application.Dialogs(xlDialogPrinterSetup).Show

        If nOpt = True Then   
            ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
        Else
            Exit Sub
        End If

VBA Access - Erro 3052

O número de bloqueios de compartilhamento de arquivos foi excedido.

Hello folks!

Vez por outra somos surpreendido por alguns erros nas nossas aplicações MS Access, os quais não fazemos ideia do que sejam (vá se acostumando).

Um dos erros que nos surpreendem, pegando-nos desprevenidos, é o erro 3052 ele aparece quando o número de bloqueios de compartilhamento de arquivos foi excedido, o valor padrão é 9.500. Sem nos apercebermos disso, excedemos o número máximo de bloqueios permitidos em um recordset, este limite é especificado pela definição MaxLocksPerFile no Registro do sistema.

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Jet\4.0\Engines\Jet
4.0\MaxLocksPerFile

Como eliminá-lo? Aumente a entrada de registro MaxLocksPerFile, o valor padrão pode ser alterado por meio da edição do Registro com Regedit.exe ou com o método SetOption.

Application.DBEngine.SetOption dbMaxLocksPerFile, <NumLocks>

Altere o <NumLocks> para 1000000 ou algo maior do que 10000 (um milhão poupará você de aplicar esse truque mais vezes) e o erro irá embora. Certifique-se de colocar a linha acima na sua subroutina, e evoque-a a partir do seu FORM principal.

Outros fatores que podem fazer o seu aplicativo atingir este limite são:

  • quantidade de memória disponível
  • tamanho das linhas no recordset
  • restrições no sistema operacional da rede

Mais detalhes: Inicializando o driver de mecanismo de banco de dados do Microsoft Jet 3.5
                       Personalizando configurações do Registro do Windows para Microsoft Jet


Pois é, desse erro você já se livrou .  .  .  Mas .  .  . outros virão...


André Luiz Bernardes

VBA Access - colocando título na sua aplicação

Mostre que suas aplicações MS Access são organizadas por inserir no título delas um texto que demonstre:

- O nome da aplicação
- A ação efetuada no momento por sua aplicação
- O nome da sua empresa
- Código do processamento sendo efetuado no momento.

Pode usar a funcionalidade para inúmeras coisas, aproveite!

' Digite num novo módulo:

Option Explicit
Option Compare Database

Private Declare Function SetWindowText _
                Lib "user32" _
                Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Public Sub SetFormTitle(frm As Form, TitleText As String)
    Dim fhWnd As Long
    fhWnd = frm.hwnd
    SetWindowText fhWnd, TitleText
End Sub

'Copie a SUB abaixo dentro do formulário, no evento OnOpen.
Private Sub Form_Open(Cancel As Integer)
    SetFormTitle Me, ".: A&A - In Any Place - Título da minha aplicação!"
End Sub



VBA Powerpoint - Dicas...


VBA Powerpoint: Populando LISTBOX a partir do Access.
VBA Powerpoint: Torne homogêneas todas as fontes e cores.

André Luiz Bernardes


VBA Word - Várias dicas.

Dicas de Word

VBA Word - Retire todos hyperlinks mantendo o texto no .DOC
VBA Word - Alteração de texto com base em opção em drop-down
VBA Word - Checando número de revisões ao abrir
VBA Word - Como listar todas as Macros no meu documento.
VBA Word - Várias Funções.
VBA Word - Instale uma macro em VBA na barra de acesso rápido do Word
VBA Word - Numerador automático de documentos


André Luiz Bernardes

VBA Outlook - Várias dicas.


VBA Outlook - Eliminar mensagem de alerta no Outlook
VBA Outlook - 06 - Uso do editor do Word no outlook.
VBA Outlook - 05 - Criando tarefas a partir de um e-mail.
VBA Outlook - 04 - Arquivos anexados.
VBA Outlook - 03 - Mensagens em uma pasta específica
VBA Outlook - 02 Enviando lembretes.
VBA Outlook - 01 - Iniciando
VBA Outlook - Inserindo Assinatura programaticamente.
VBA Outlook 01 - Enviando mensagem sem interrupções.
VBA Outlook - Reencaminhar mensagens enviadas como ocultas.

André Luiz Bernardes


VBA - Várias Dicas para diversas aplicações

Diversas dicas em várias aplicações VBA

Apagar ficheiros
VBA Office: Controlando aplicativo Office a partir de outro.
controlo windowsmediaplayer
Escolher qual impressora p/ imprimir
Browser
VBA - Menu no Formulário
Problema com Label
Gravando uma aba para uma planilha.
Livros: VBA
Janelas em VB
Gestor de tarefas
VBA - design
Gifs no VB 6.0
VBA com DOS: Execute comandos a partir das aplicações VBA.
Impressão em Argox os 214
VBA - Winzip com VBA
10 Dicas para gerenciar um projeto.
Condições para ativa e desativar botão
Pesquisas em Form por Data
macro find e deletar linha
Como imprimir hiperlinks de várias células
Tabela editável parecido com listbox
VBA - Código para converter segundos em h:m:s
VBA - comparação entre colunas
VBA - excluindo linhas duplicadas - Em coluna ordenada.
VBA - controle interrupções

VBA - Boa definição ao pedir ajuda.
Imagens GIF em movimento
Redimensionamento automático de uma imagem
Erro ao executar F5 em VBA
Trabalhando com área de transferência em VBA
VBA - História
Procurando Valores pelo VBA
Diferenca duas datas com horas sem fim de semana
Usando índices em VBA
Lista de Compras
Ajuda
Pensando o VBA
VBA - Origem
Buscar palavras com VBA
Controle de estoques no VBA
Manual de Visual Basic Simples
VBA - Controles ActiveX - caixas de texto.
Dica: Converter texto para maiúsculos ou minúsculos
VBA - Diversos códigos e soluções prontos para utilização
VBA Desenvolvimento: Profissionalizando minhas soluções


André Luiz Bernardes

VBA Access - Índice

Várias dicas interessantes...

VBA Access - Deletando objetos
VBA Access - Encontrando um registro específico
VBA Access - Exemplos de Códigos DDL/DML
VBA Access - Nome do usuário na rede (Network User Name).

VBA Access - Deletando tabelas e querys programaticamente
VBA Access - Copiando query existente para outra.
VBA Access - Conectando arquivos DBF
VBA Access - Tabelas Dinâmicas
VBA Access: Pesquisa em tabelas
VBA Access - Nome do Computador (Estação de Trabalho).
VBA Access - Exportando relatório para RTF, XLS e Snapshot
VBA Access - Enviando relatórios Access por email
VBA Access - Ocultar
VBA Access - Exportando imagens para o Powerpoint
VBA Access - Utilização da função FORMAT
VBA Access - Exportando dados da query para Slides PPT
VBA Access - Exportando registros para PARADOX


André Luiz Bernardes

VBA Excel - Índice - Minhas postagens no InfoFórum



Várias dicas interessantes para Excel, postadas no Info Fórum sob minha autoria:

VBA Excel - 05 - Exportando gráficos para o PowerPoint
VBA Excel - 04 - Exportando gráficos para o PowerPoint
VBA Excel - 03 - Exportando para o PowerPoint.
VBA Excel - 02 - Exportando gráficos para o PowerPoint
VBA Excel - 01 - Exportando gráficos para o PowerPoint
VBA Excel - Máscara para CNPJ
VBA Excel - Como as planilhas aumentam inexplicavelmente?

VBA Excel - Formatando várias células
VBA Excel - Eficiência para deletar milhares de linhas.
VBA Excel - Removendo todas as referências a Links externos
VBA Excel - Deixando suas planilhas enxutas!
VBA Excel - Ocultar linha
VBA Excel - Inserindo novas planilhas (worksheets) na pasta.
VBA Excel - Criando um calendário dentro da planilha
VBA Excel - Retornando o período em ANOS, MESES e DIAS.
VBA Excel - Realizando loops no intervalo nomeado
VBA Excel - Protegendo o título do seu gráfico
VBA Excel - Criando gráficos com VBA
VBA Excel - Abrindo caixa de diálogo
VBA Excel - Copiando Chart, Range, qualquer coisa como imagem
VBA Excel - Enviando e-mails a partir do Excel - 01
VBA Excel - Exportar conteúdo da planilha para arquivo texto
VBA Excel - Definindo o tipo de Gráfico
VBA Excel - Gráfico - Redefine tamanho de bolha
VBA Excel - Identificando a última Coluna utilizada
VBA Excel - Apague todas as linhas vazias da sua planilha.
VBA Excel - Identificando o número da semana no Ano.
VBA Excel - Navegando entre as pastas existentes
VBA Excel - Entre milhares de linhas identifique a última!
VBA Excel - Envie um email com sua planilha a partir do Excel
VBA Excel - Deletando linhas com informações.
VBA Excel - Como carregar um ComboBox ?
VBA Excel - Deletando linhas duplicadas
VBA Excel - Macro que elimina células em branco
VBA Excel - utomatização de gráficos nas planilhas


TagsExcel, Column, Coluna, Delete, Linha, Plan, Planilhas, Report, Row,  rows,worksheet, lines



André Luiz Bernardes
A&A® - In Any Place.


VBA Access - Exportando relatórios para MS Word, MS Excel e Snapshot View.

Olá a todos...

Como posso exportar dados já formatados em um relatório direcioando-os para o Word, Excel ou outro formato?

A função abaixo explora 2 formas diferentes de fazer isso...

Ao exportar para o MS Excel utiliza o TransferSpreadsheet (TransferirPlanilha) Método TransferSpreadsheet (TransferirPlanilha)

Ao exportar para o MS Word e o padrão Snapshot utilizo o Método OutputTo (SaídaPara)
O método OutpuTo pode exportar informações para os seguintes padrões:

acFormatASP
acFormatDAP
acFormatHTML
acFormatIIS
acFormatRTF
acFormatSNP
acFormatTXT
acFormatXLS


Function ...
        If nOption = 6 Then
            If Not IsNull(Me.SelecRTF) Then
                DoCmd.OutputTo acOutputReport, nReport, acFormatRTF, RptName & ".rtf", True
            End If
           
            If Not IsNull(Me.SelecSNP) Then
                DoCmd.OutputTo acOutputReport, nReport, acFormatSNP, RptName & ".snp", True
            End If

            If Not IsNull(Me.SelecXLS) Then
                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, nTbl1, RptName & ".xls", False, "ESN"
                DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, nTbl2, RptName & ".xls", False, "Supllier"
            End If
        End If
End

Perceba que uma importante característica de exportação para a planilha é o fato de fazê-lo a
partir de conteúdos diferentes (tabelas) para a mesma planilha.


Conheçam um Blog legal só de MS Access em: http://brzaccessdeveloper.blogspot.com/

André Luiz Bernardes
http://al-bernardes.sites.uol.com.br/

VBA Access - Distributing Access reports using email

Sub RunEmailDist()
       Dim MyDB As Database, MyRecs As Recordset, MyName As String
       Set MyDB = CurrentDb()
       Set MyRecs = MyDB.OpenRecordset("emaildist")

       Let MyName = InputBox("Entre o seu nome","RunEmailDist (CiM)", "Chris Mead (Extn 3841)")

       MyRecs.MoveFirst
       Do While Not MyRecs.EOF

       If MyRecs!distname = Forms("F_ChooseEmail")!DistNameCombo Then
              DoCmd.SendObject acSendReport, "Your budget report", acFormatRTF, MyRecs!SendTo, , , "Budget reports", _
"Please find attached your set of budget reports." & vbCrLF & MyName, 0
       End If

       MyRecs.MoveNext
       Loop

       MyRecs.Close
End Sub


André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/
bernardess@gmail.com

VBA Word - Como listar todas as Macros no meu documento.

Talvez haja a necessidade de documentar todas as macros que existam no seu documento
MS Word. Como fazê-lo?

Segue código abaixo sugerido por Hafizullah <hafizullah@aol.com>

With Selection
.InsertAfter strlProcedure & vbCr
Let .Font.Bold = gTrue
.InsertAfter "Project "
.Collapse wdCollapseEnd
.InsertAfter strlProject
Let .Font.Italic = gTrue
.Collapse wdCollapseEnd
.InsertAfter vbCr
.InsertAfter "Component "
.Collapse wdCollapseEnd
.InsertAfter strlComponent
Let .Font.Italic = gTrue
.Collapse wdCollapseEnd
.InsertAfter vbCr
.InsertAfter "Start "
.Collapse wdCollapseEnd
.InsertAfter intlStartLine
Let .Font.Italic = gTrue
.Collapse wdCollapseEnd
.InsertAfter vbCr
.InsertAfter "Number of Lines "
.Collapse wdCollapseEnd
.InsertAfter intlProcCountLines
Let .Font.Italic = gTrue
.Collapse wdCollapseEnd
.InsertAfter vbCr
End With

VBA Excel - Deletando linhas - 08 - Deletando linhas com informações.





Você provavelmente precisa vez ou outra deletar as linhas utilizadas da sua planilha, ou talvez deseja disponibilizar este código na planilha caso alguém a abra sem a sua autorização.

Sub Prepare()

    Dim CR As Long
    Dim LR As Long

    Let Application.ScreenUpdating = False
    Let Application.Calculation = xlCalculationManual
    Let LR = ActiveSheet.Range("B65536").End(xlUp).Row

    For CR = LR To 3 Step -1
        If ActiveSheet.Cells(CR, "A") = "" Then
            Let ActiveSheet.Cells(CR - 1, "B") = Cells(CR - 1, "B") & " " & Cells(CR, "B")
           
            ActiveSheet.Cells(CR, "A").EntireRow.Delete
        End If
    Next CR

    Let Application.ScreenUpdating = True
    Let Application.Calculation = xlCalculationAutomatic

    Application.Calculate
End Sub


TagsExcel, Column, Coluna, Delete, Linha, Plan, Planilhas, Report, Row,  rows,worksheet, lines



André Luiz Bernardes
A&A® - In Any Place.

Word VBA - Várias Funções - Parte 02.

Function GetSearchPath() Let GetSearchPath = BrowseFolder.BrowseFolder$("Browse Search Folder...") End Function Sub GetControlType() Dim ctrl As Control Dim lngCount As Long Dim ctrlName As String ReDim arrFileTypes(0) Let lngCount = 0

For Each ctrl In frmOptions.framOptions.Controls If ctrl.Name <> "chkShow" And InStr(1, ctrl.Name, "chk") Then Let ctrlName = ctrl.Name

If ctrl.Value = True Then Let arrFileTypes(lngCount) = Right(ctrlName, Len(ctrlName) - 3) ReDim Preserve arrFileTypes(lngCount + 1) End If

End If Next ctrl End Sub

Function FilePathExists(strPickedPath) As Boolean Set objFSO = CreateObject("scripting.
FileSystemObject") If objFSO.FolderExists(strPickedPath) Then Let FilePathExists = True Else Let FilePathExists = False End If End Sub Sub ShowProgress(ByVal snglFileCounter, ByVal snglCount, ByVal strFolderPath As String) Dim snglDecimal As Single Dim snglWidth As Single Dim strLabelText As String If BoolCancel Then Exit Sub Let snglDecimal = snglFileCounter / snglCount Let snglWidth = snglDecimal * 280 Let strLabelText = TruncPathForLabel(strFolderPath) Let frmProgress.lblPercent.Caption = "Folder scan is " & FormatPercent(snglDecimal) & " complete." Let frmProgress.lblStatus.Caption = snglCount & " files in " & strLabelText Let frmProgress.lblProgress.Width = snglWidth frmProgress.Repaint End Sub Sub MakeTable() Dim MyTableRange Dim Active If BoolCancel Then Exit Sub Set Active = ActiveDocument If ActiveDocument.Tables.Count = 0 Then Set MyTableRange = Active.Tables.Add(Range:=Active.Range(Start:=0, End:=0), NumRows:=1, NumColumns:=3) AddMacroButton 1, "MACROBUTTON TableSortAToZ Description " AddMacroButton 2, "MACROBUTTON TableSortAToZ File Path/Name " AddMacroButton 3, "MACROBUTTON TableSortAToZ File Type " With ActiveDocument.Tables(1) .Columns(1).SetWidth ColumnWidth:=InchesToPoints(2.3), RulerStyle:=wdAdjustProportional .Columns(2).SetWidth ColumnWidth:=InchesToPoints(4.5), RulerStyle:=wdAdjustProportional .Columns(3).SetWidth ColumnWidth:=InchesToPoints(0.7), RulerStyle:=wdAdjustProportional End With Let lngTableRows = 1 End If Let BoolTableMade = True End Sub Sub AddMacroButton(ByVal lngCellNumber As Long, ByValstrMacroButton As String) Dim CellRange As Range If BoolCancel Then Exit Sub Set CellRange =ActiveDocument.Tables(1).Rows(1).Cells(lngCellNumber).Range CellRange.Select CellRange.Delete Selection.Fields.Add Range:=CellRange, Type:=wdFieldEmpty,text:=strMacroButton, preserveformatting:=False End Sub Sub pMacroClickOptions() If BoolCancel Then Exit Sub If frmOptions.chkSort.Value = True Then With Options Let .ButtonFieldClicks = 1 End With Else With Options Let .ButtonFieldClicks = 2 End With End If End Sub Function TruncPathForLabel(strText)Dim intLen As Integer Dim intMarkLeft As Integer Dim intMarkRight As Integer Dim strLeft As String Dim strConj As String Dim strRight As String Dim strLabelText As String If BoolCancel Then Exit Function Let intLen = Len(strText) If intLen > 60 Then Let intMarkLeft = InStr(15, strText, "\") Let intMarkRight = InStrRev(strText, "\", -1) Let strLeft = Left(strText, intMarkLeft) Let strConj = "..." Let strRight = "\" & Right(strText, intLen - intMarkRight) Let strLabelText = strLeft & strConj & strRight Let TruncPathForLabel = strLabelText Else Let TruncPathForLabel = strText End If End Sub Sub sOpenBrowser(FileName) Dim Dummy As String Dim RetVal As Long Dim hwnd Let RetVal = ShellExecute(hwnd, "open", FileName, "", Dummy, SW_SHOWNORMAL) End Sub Sub BuildCustomMenu() Dim vCtrlCount As Long Dim ctlControl ''' Always attempt to delete any previously existing ''' custom toolbars when you first start up. ''' Rebuild them rather than trying to reuse them. On Error Resume Next Application.CommandBars("Menu Bar").Controls("docsonline").Delete On Error GoTo 0 ''' Create the custom command bar. Let vCtrlCount = CommandBars("Menu Bar").Controls.Count Let vCtrlCount = vCtrlCount + 1 With CommandBars("Menu Bar").Controls .Add(Type:=msoControlPopup, Before:=vCtrlCount).Caption = "&docsonline" End With 'Make the new menu start the group With CommandBars("Menu Bar").Controls("docsonline") Let .BeginGroup = True End With ''' Add the buttons. Set ctlControl = CommandBars("Menu Bar").Controls("docsonline").Controls.Add(msoControlButton) Let ctlControl.Caption = "&New Catalog" Let ctlControl.Style = msoButtonCaption ''' Display only the caption text." Let ctlControl.OnAction = "NewCatalog" Set ctlControl = CommandBars("Menu Bar").Controls("docsonline").Controls.Add(msoControlButton) Let ctlControl.Caption = "&About docsonline" Let ctlControl.Style = msoButtonCaption ''' Display only the caption text." Let ctlControl.OnAction = "Aboutdocsonline" Let ActiveDocument.Saved = True End Sub Sub NewCatalog() Application.Documents.Add 'Template:=Templates(1).FullName, Visible:=True frmOptions.Show End Sub Sub SetTable() ActiveDocument.Tables(1).Select Let Selection.Font.Size = 9 ActiveDocument.Tables(1).AutoFitBehavior _ wdAutoFitWindow Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=False Let ActiveDocument.SpellingChecked = True End Sub Sub CheckTableContents() If ActiveDocument.Tables(1).Rows.Count = 1 Then ActiveDocument.Tables(1).Delete Selection.InsertAfter "There were no files or subfolders in the selected path." End If End Sub Sub DoTheseThings(strFile) Debug.Print strFile End Sub
André Luiz Bernardes A&A - WORK, DON´T PLAY! http://al-bernardes.sites.uol.com.br/ bernardess@gmail.com

Word VBA - Várias Funções - Parte 01.

Decidi cooperar com algumas funções úteis sobre código VBA para o MS Word... Divirtam-se! Option Explicit Public BoolCancel As Boolean Public BoolSelected As Boolean Public BoolDoSpecialActions As Boolean Public lngTableRows As Long Public BoolTableMade As Boolean Public objFSO As Object Public lngCounter As Long Public arrFileTypes() Public strPickedPath As String Private Const SW_SHOW = 5 ' Displays Window in its current size ' and position Private Const SW_SHOWNORMAL = 1 ' Restores Window if Minimized or ' Maximized Private Declare Function ShellExecute Lib "shell32.dll" Alias _ "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As _ String, ByVal lpFile As String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Declare Function FindExecutable Lib "shell32.dll" Alias _ "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As _ String, ByVal lpResult As String) As Long Sub GetStarted(Optional ByVal strFolderPath) Let BoolDoSpecialActions = False Let BoolTableMade = False Let lngCounter = 0 If BoolCancel Then Exit Sub If IsMissing(strFolderPath) Then strFolderPath = "C:\" If Right(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\" If Selection.ExtendMode Then Selection.ExtendMode = False If Application.ScreenUpdating Then Application.ScreenUpdating = False If frmOptions.chkDoSpecialActions.Value = True Then Let BoolDoSpecialActions = True End If

GetFiles (strFolderPath) If frmOptions.chkRecurse.Value <> False Then GetFolders (strFolderPath) End If With Application If Not .ScreenUpdating Then .ScreenUpdating = True .ScreenRefresh End With If Not frmOptions.optNoTable Then If Not BoolTableMade Then MakeTable End If If Not frmOptions.optNoTable Then With ActiveDocument.Tables(1).Rows(1) Let Selection.Font.Size = 9

With .Shading Let .Texture = wdTextureNone Let .ForegroundPatternColor = wdColorAutomatic Let .BackgroundPatternColor = wdColorTurquoise End With

Let Selection.Font.Size = 9 End With End If Set objFSO = Nothing If Not frmOptions.optNoTable Then SetTable CheckTableContents End If frmProgress.Hide End Sub Sub GetFolders(strCurrFolder) Dim objFolders As Object Dim FoldSubs Dim strFolder If BoolCancel Then Exit Sub Set objFSO = CreateObject("scripting.FileSystemObject") Set objFolders = objFSO.GetFolder(strCurrFolder) Set FoldSubs = objFolders.SubFolders For Each strFolder In FoldSubs Application.ScreenRefresh GetFiles strFolder If frmOptions.chkRecurse.Value <> False Then GetFolders strFolder End If If Err <> 0 Then Err.Clear Let Err.Number = 0 End If Next End Sub Sub GetFiles(strFolderName) Dim lngFileCounter As Long Dim objFolders As Object Dim FoldFiles Dim lngArrSize As Long Dim i As Long Dim intLength As Integer Dim intDotPos As Integer Dim strMatch As String Dim strTrimmed As String Dim strInsert As String Dim strFile If BoolCancel Then Exit Sub Set objFSO = CreateObject("scripting.FileSystemObject") Set objFolders = objFSO.GetFolder(strFolderName) Set FoldFiles = objFolders.Files Let lngArrSize = UBound(arrFileTypes) Let lngFileCounter = 0 For Each strFile In FoldFiles If BoolCancel Then Exit Sub If frmOptions.chkFullPath = True Then Let strInsert = strFile.Name Else Let strInsert = strFile End If

Let lngFileCounter = lngFileCounter + 1

ShowProgress lngFileCounter, CLng(FoldFiles.Count), objFolders

For i = 0 To lngArrSize 'Following Lines commented for File Type bug 'results in types of .2.doc, etc 'intDotPos = InStr(strFile.Name, ".") 'intLength = Len(strFile.Name) 'strMatch = LCase(Right(strFile.Name, intLength - intDotPos)) 'Improved strMatch routine Let strMatch = FileType(strFile.Name) Let strTrimmed = LCase(Trim(arrFileTypes(i)))

If strMatch = strTrimmed Then MakeEntry strMatch, strFile, strInsert

'This is where any special stuff can be done! If BoolDoSpecialActions = True Then DoTheseThings (strFile) End If

If Err <> 0 Then Err.Clear Err.Number = 0 End If Let lngCounter = lngCounter + 1 ElseIf arrFileTypes(0) = "All" Then MakeEntry strMatch, strFile, strInsert End If Next i Next strFile DoEvents End Sub

Function FileType(ByVal strName As String) As String Dim arrType As Variant Dim Bound As Long Let arrType = Split(strName, ".") Let Bound = UBound(arrType) Let FileType = arrType(Bound) End Function

Sub MakeEntry(ByVal strExt As String, ByVal strFileName As String, ByVal strShownText) Dim myrange As Range If frmOptions.optNoTable Then ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=strFileName, TextToDisplay:=strShownText Selection.InsertAfter vbNewLine & vbNewLine Selection.EndKey Unit:=wdStory, Extend:=False Else If Not BoolTableMade Then MakeTable

With Selection ActiveDocument.Tables(1).Rows.Add Let lngTableRows = lngTableRows + 1 With ActiveDocument.Tables(1).Rows(lngTableRows).Cells(2).Range .Delete Set myrange = ActiveDocument.Tables(1).Rows(lngTableRows).Cells(2).Range ActiveDocument.Hyperlinks.Add Anchor:=myrange, Address:=strFileName, TextToDisplay:=strShownText End With With ActiveDocument.Tables(1).Rows(lngTableRows).Cells(3).Range .Delete .InsertAfter strExt End With

End With DoEvents End If With ActiveDocument Let .SpellingChecked = True .UndoClear End With End Sub

André Luiz Bernardes A&A - WORK, DON´T PLAY! http://al-bernardes.sites.uol.com.br/ bernardess@gmail.com

Word VBA - Várias Funções

Decidi cooperar com algumas funções úteis sobre código VBA para o MS Word... Divirtam-se! Option Explicit Public BoolCancel As Boolean Public BoolSelected As Boolean Public BoolDoSpecialActions As Boolean Public lngTableRows As Long Public BoolTableMade As Boolean Public objFSO As Object Public lngCounter As Long Public arrFileTypes() Public strPickedPath As String Private Const SW_SHOW = 5 ' Displays Window in its current size ' and position Private Const SW_SHOWNORMAL = 1 ' Restores Window if Minimized or ' Maximized Private Declare Function ShellExecute Lib "shell32.dll" Alias _ "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As _ String, ByVal lpFile As String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Declare Function FindExecutable Lib "shell32.dll" Alias _ "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As _ String, ByVal lpResult As String) As Long Sub GetStarted(Optional ByVal strFolderPath) Let BoolDoSpecialActions = False Let BoolTableMade = False Let lngCounter = 0 If BoolCancel Then Exit Sub If IsMissing(strFolderPath) Then strFolderPath = "C:\" If Right(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\" If Selection.ExtendMode Then Selection.ExtendMode = False If Application.ScreenUpdating Then Application.ScreenUpdating = False If frmOptions.chkDoSpecialActions.Value = True Then Let BoolDoSpecialActions = True End If

GetFiles (strFolderPath) If frmOptions.chkRecurse.Value <> False Then GetFolders (strFolderPath) End If With Application If Not .ScreenUpdating Then .ScreenUpdating = True .ScreenRefresh End With If Not frmOptions.optNoTable Then If Not BoolTableMade Then MakeTable End If If Not frmOptions.optNoTable Then With ActiveDocument.Tables(1).Rows(1) Let Selection.Font.Size = 9

With .Shading Let .Texture = wdTextureNone Let .ForegroundPatternColor = wdColorAutomatic Let .BackgroundPatternColor = wdColorTurquoise End With

Let Selection.Font.Size = 9 End With End If Set objFSO = Nothing If Not frmOptions.optNoTable Then SetTable CheckTableContents End If frmProgress.Hide End Sub Sub GetFolders(strCurrFolder) Dim objFolders As Object Dim FoldSubs Dim strFolder If BoolCancel Then Exit Sub Set objFSO = CreateObject("scripting.FileSystemObject") Set objFolders = objFSO.GetFolder(strCurrFolder) Set FoldSubs = objFolders.SubFolders For Each strFolder In FoldSubs Application.ScreenRefresh GetFiles strFolder If frmOptions.chkRecurse.Value <> False Then GetFolders strFolder End If If Err <> 0 Then Err.Clear Let Err.Number = 0 End If Next End Sub Sub GetFiles(strFolderName) Dim lngFileCounter As Long Dim objFolders As Object Dim FoldFiles Dim lngArrSize As Long Dim i As Long Dim intLength As Integer Dim intDotPos As Integer Dim strMatch As String Dim strTrimmed As String Dim strInsert As String Dim strFile If BoolCancel Then Exit Sub Set objFSO = CreateObject("scripting.FileSystemObject") Set objFolders = objFSO.GetFolder(strFolderName) Set FoldFiles = objFolders.Files Let lngArrSize = UBound(arrFileTypes) Let lngFileCounter = 0 For Each strFile In FoldFiles If BoolCancel Then Exit Sub If frmOptions.chkFullPath = True Then Let strInsert = strFile.Name Else Let strInsert = strFile End If

Let lngFileCounter = lngFileCounter + 1

ShowProgress lngFileCounter, CLng(FoldFiles.Count), objFolders

For i = 0 To lngArrSize 'Following Lines commented for File Type bug 'results in types of .2.doc, etc 'intDotPos = InStr(strFile.Name, ".") 'intLength = Len(strFile.Name) 'strMatch = LCase(Right(strFile.Name, intLength - intDotPos)) 'Improved strMatch routine Let strMatch = FileType(strFile.Name) Let strTrimmed = LCase(Trim(arrFileTypes(i)))

If strMatch = strTrimmed Then MakeEntry strMatch, strFile, strInsert

'This is where any special stuff can be done! If BoolDoSpecialActions = True Then DoTheseThings (strFile) End If

If Err <> 0 Then Err.Clear Err.Number = 0 End If Let lngCounter = lngCounter + 1 ElseIf arrFileTypes(0) = "All" Then MakeEntry strMatch, strFile, strInsert End If Next i Next strFile DoEvents End Sub

Function FileType(ByVal strName As String) As String Dim arrType As Variant Dim Bound As Long Let arrType = Split(strName, ".") Let Bound = UBound(arrType) Let FileType = arrType(Bound) End Function

Sub MakeEntry(ByVal strExt As String, ByVal strFileName As String, ByVal strShownText) Dim myrange As Range If frmOptions.optNoTable Then ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=strFileName, TextToDisplay:=strShownText Selection.InsertAfter vbNewLine & vbNewLine Selection.EndKey Unit:=wdStory, Extend:=False Else If Not BoolTableMade Then MakeTable

With Selection ActiveDocument.Tables(1).Rows.Add Let lngTableRows = lngTableRows + 1 With ActiveDocument.Tables(1).Rows(lngTableRows).Cells(2).Range .Delete Set myrange = ActiveDocument.Tables(1).Rows(lngTableRows).Cells(2).Range ActiveDocument.Hyperlinks.Add Anchor:=myrange, Address:=strFileName, TextToDisplay:=strShownText End With With ActiveDocument.Tables(1).Rows(lngTableRows).Cells(3).Range .Delete .InsertAfter strExt End With

End With DoEvents End If With ActiveDocument Let .SpellingChecked = True .UndoClear End With End Sub

Function GetSearchPath() Let GetSearchPath = BrowseFolder.BrowseFolder$("Browse Search Folder...") End Function Sub GetControlType() Dim ctrl As Control Dim lngCount As Long Dim ctrlName As String ReDim arrFileTypes(0) Let lngCount = 0

For Each ctrl In frmOptions.framOptions.Controls If ctrl.Name <> "chkShow" And InStr(1, ctrl.Name, "chk") Then Let ctrlName = ctrl.Name

If ctrl.Value = True Then Let arrFileTypes(lngCount) = Right(ctrlName, Len(ctrlName) - 3) ReDim Preserve arrFileTypes(lngCount + 1) End If

End If Next ctrl End Sub

Function FilePathExists(strPickedPath) As Boolean Set objFSO = CreateObject("scripting.FileSystemObject") If objFSO.FolderExists(strPickedPath) Then Let FilePathExists = True Else Let FilePathExists = False End If End Sub Sub ShowProgress(ByVal snglFileCounter, ByVal snglCount, ByVal strFolderPath As String) Dim snglDecimal As Single Dim snglWidth As Single Dim strLabelText As String If BoolCancel Then Exit Sub Let snglDecimal = snglFileCounter / snglCount Let snglWidth = snglDecimal * 280 Let strLabelText = TruncPathForLabel(strFolderPath) Let frmProgress.lblPercent.Caption = "Folder scan is " & FormatPercent(snglDecimal) & " complete." Let frmProgress.lblStatus.Caption = snglCount & " files in " & strLabelText Let frmProgress.lblProgress.Width = snglWidth frmProgress.Repaint End Sub Sub MakeTable() Dim MyTableRange Dim Active If BoolCancel Then Exit Sub Set Active = ActiveDocument If ActiveDocument.Tables.Count = 0 Then Set MyTableRange = Active.Tables.Add(Range:=Active.Range(Start:=0, End:=0), NumRows:=1, NumColumns:=3) AddMacroButton 1, "MACROBUTTON TableSortAToZ Description " AddMacroButton 2, "MACROBUTTON TableSortAToZ File Path/Name " AddMacroButton 3, "MACROBUTTON TableSortAToZ File Type " With ActiveDocument.Tables(1) .Columns(1).SetWidth ColumnWidth:=InchesToPoints(2.3), RulerStyle:=wdAdjustProportional .Columns(2).SetWidth ColumnWidth:=InchesToPoints(4.5), RulerStyle:=wdAdjustProportional .Columns(3).SetWidth ColumnWidth:=InchesToPoints(0.7), RulerStyle:=wdAdjustProportional End With Let lngTableRows = 1 End If Let BoolTableMade = True End Sub Sub AddMacroButton(ByVal lngCellNumber As Long, ByValstrMacroButton As String) Dim CellRange As Range If BoolCancel Then Exit Sub Set CellRange =ActiveDocument.Tables(1).Rows(1).Cells(lngCellNumber).Range CellRange.Select CellRange.Delete Selection.Fields.Add Range:=CellRange, Type:=wdFieldEmpty,text:=strMacroButton, preserveformatting:=False End Sub Sub pMacroClickOptions() If BoolCancel Then Exit Sub If frmOptions.chkSort.Value = True Then With Options Let .ButtonFieldClicks = 1 End With Else With Options Let .ButtonFieldClicks = 2 End With End If End Sub Function TruncPathForLabel(strText)Dim intLen As Integer Dim intMarkLeft As Integer Dim intMarkRight As Integer Dim strLeft As String Dim strConj As String Dim strRight As String Dim strLabelText As String If BoolCancel Then Exit Function Let intLen = Len(strText) If intLen > 60 Then Let intMarkLeft = InStr(15, strText, "\") Let intMarkRight = InStrRev(strText, "\", -1) Let strLeft = Left(strText, intMarkLeft) Let strConj = "..." Let strRight = "\" & Right(strText, intLen - intMarkRight) Let strLabelText = strLeft & strConj & strRight Let TruncPathForLabel = strLabelText Else Let TruncPathForLabel = strText End If End Sub Sub sOpenBrowser(FileName) Dim Dummy As String Dim RetVal As Long Dim hwnd Let RetVal = ShellExecute(hwnd, "open", FileName, "", Dummy, SW_SHOWNORMAL) End Sub Sub BuildCustomMenu() Dim vCtrlCount As Long Dim ctlControl ''' Always attempt to delete any previously existing ''' custom toolbars when you first start up. ''' Rebuild them rather than trying to reuse them. On Error Resume Next Application.CommandBars("Menu Bar").Controls("docsonline").Delete On Error GoTo 0 ''' Create the custom command bar. Let vCtrlCount = CommandBars("Menu Bar").Controls.Count Let vCtrlCount = vCtrlCount + 1 With CommandBars("Menu Bar").Controls .Add(Type:=msoControlPopup, Before:=vCtrlCount).Caption = "&docsonline" End With 'Make the new menu start the group With CommandBars("Menu Bar").Controls("docsonline") Let .BeginGroup = True End With ''' Add the buttons. Set ctlControl = CommandBars("Menu Bar").Controls("docsonline").Controls.Add(msoControlButton) Let ctlControl.Caption = "&New Catalog" Let ctlControl.Style = msoButtonCaption ''' Display only the caption text." Let ctlControl.OnAction = "NewCatalog" Set ctlControl = CommandBars("Menu Bar").Controls("docsonline").Controls.Add(msoControlButton) Let ctlControl.Caption = "&About docsonline" Let ctlControl.Style = msoButtonCaption ''' Display only the caption text." Let ctlControl.OnAction = "Aboutdocsonline" Let ActiveDocument.Saved = True End Sub Sub NewCatalog() Application.Documents.Add 'Template:=Templates(1).FullName, Visible:=True frmOptions.Show End Sub Sub SetTable() ActiveDocument.Tables(1).Select Let Selection.Font.Size = 9 ActiveDocument.Tables(1).AutoFitBehavior _ wdAutoFitWindow Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=False Let ActiveDocument.SpellingChecked = True End Sub Sub CheckTableContents() If ActiveDocument.Tables(1).Rows.Count = 1 Then ActiveDocument.Tables(1).Delete Selection.InsertAfter "There were no files or subfolders in the selected path." End If End Sub Sub DoTheseThings(strFile) Debug.Print strFile End Sub
André Luiz Bernardes

VBA Access - Deletando objetos

Docmd.DeleteObject Method

O método DoCmd DeleteObject executa a deleção de objetos ativos no Visual Basic for Applications.

Este comando é usado várias vezes para remover objetos temporários criados durante a execução de certos processos nas nossas aplicações de banco de dados no MS Access database.

O texto abaixo mostra a syntaxe e as opções para o comando 'Delete Object'.

DoCmd.DeleteObject Opções para o parâmetro tipo de objeto - AcObjectType. acDataAccessPage acDefault (default) acDiagram acForm acFunction acMacro acModule acQuery acReport acServerView acStoredProcedure acTable
André Luiz Bernardes A&A - WORK, DON´T PLAY! http://al-bernardes.sites.uol.com.br/ bernardess@gmail.com

VBA Access - Encontrando um registro...



Não existe atividade mais repetitiva num banco de dados MS Access quanto a de encontrar um registro específico. Existem diversas formas de fazer isso, abaixo segue uma delas. 

Divirtam-se!

Dim strSQL As String
Dim rst As ADODB.Recordset
Dim lngID As Long

   strSQL = "SELECT Det.ID, Det.EntryDate, Det.UserEntry FROM UserEntrys WHERE Det.ID=" & EID
  
   Set rst = New ADODB.Recordset

     With rst
       .Open strSQL, CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly

       Do While Not rst.EOF
          Let idnumber = !ID
          Let recdate = !EntryDate
          Let recdata = !UserEntry

          rst.MoveNext
       Loop

       .Close
   End With

   Set rst = Nothing

Tags: VBA, Access, recordset, select, SQL, rst, record, registro, find


VBA Access - Nome do usuário na rede (Network User Name).

Em alguns casos pode ser necessário que registremos os nomes dos usuários que estão acessando as nossas aplicações. Ou talvez desejemos desenvolver um modo de Login que utilize esses nomes de usuários na rede. Function NetUName() As String On Error GoTo Err_Handler Dim lngLen As Long Dim strUserName As String Const lngcMaxFieldSize As Long = 64& ' Inicia. Let strUserName = String$ (254, vbNullChar) Let lngLen = 255& ' Em caso de sucesso a API retornará um valor diferente de zero. If apiGetUserName (strUserName, lngLen) <> 0& Then Let lngLen = lngLen - 1& If lngLen > lngcMaxFieldSize Then 'Tamanho Máximo do campo. Let lngLen = lngcMaxFieldSize End If Let NetworkUserName = Left$ (strUserName, lngLen) End If Exit_Handler: Exit Function Err_Handler: Call LogError(Err.Number, Err.Description, conMod & ".NetworkUserName", , False) Resume Exit_Handler End Function
André Luiz Bernardes A&A - WORK, DON´T PLAY! http://al-bernardes.sites.uol.com.br/ bernardess@gmail.com

VBA Access - Usando o DML - Data Definition Language.


Exemplos de Código com o DDL

SQL padrão é uma sublinguagem utilizada no MS Access para lidar com os dados, tabelas, querys, etc...

ObjetoTipo
Tabela1
Query5
Tabela Conectada 4, 6, or 8
Formulário-32768
Relatório-32764
Módulo-32761
  • Data Manipulation Language (DML)O comando SELECT e queries de ação (DELETE, UPDATE, INSERT INTO, ...)

  • Data Definition Language (DDL)Comandos que alterem o "schema" (Mudando tabelas, campos, índices, relações, queries, etc.)

Usando o DML para queries, poderemos ler alguns aspectos do "schema" do banco de dados.

Poderá listar os objetos na base de dados Access como abaixo: 

SELECT MSysObjects.Type, MSysObjects.Name FROM MSysObjects WHERE MSysObjects.Name Not Like "~*" ORDER BY MSysObjects.Type, MSysObjects.Name;

Onde Type poderá colocar um dos valores da tabela acima. (Infelizmente, o modo provido pelo DML não é o caminho mais fácil para se ler os nomes dos campos nas tabelas.)

DDL provê outras características de intervenção como:

  • CREATE TABLE para gerar uma nova tabela, especificando os nomes dos campos, tipos, e constraints.

  • ALTER TABLE para adicionar uma coluna para a tabela, deletar uma coluna na tabela, ou mudar a tabela como tipo e tamanho da mesma.

  • DROP TABLE para deletar uma tabela.

Similarmente, você pode aplicar o comandos CREATE/ALTER/DROP em outras coisas tais como índicesconstraintsviews e procedures (queries), usuário e grupos (segurança.)

Enquanto o DDL é importante para algumas bases de dados enormes, ele é limitado no uso com o MS Access. Você pode criar um campo Texto, mas não pode configurá-lo com a propriedade Largura Diferente de Zero, ou características similares. Pode criar um campo Yes/No, mas não pode dizer que o dataentry ocorrerá por meio de um text box, ou um check box. Também poderá criar um campo Date/Time, mas não poderá configurar a sua propriedade Format. DDL não pode criar campos Hyperlink, ou campos Attachment.

Poderá executar uma query DDL sob o DAO ou ADO.

Parar DAO, use: dbEngine(0)(0).Execute strSql, dbFailOnError
Parar ADO, use: CurrentProject.Connection.Execute strSql

Algumas características do JET 4 (Access 2000 e superior) são suportados somente sob o ADO.

Uma situação na qual o DDL é realmente utilizável é quanto a mudança do Tipo ou Tamanho dos campos. Você não pode fazer isto com o DAO ou ADOX, utilizar o DDL é a técnica mais prática para estes fins. Obviamente existem outras saídas mais trabalhosas e incoerentes pelo simples fato de serem mais demoradas tanto na implementação quanto na execução.

Abaixo disponibilizo alguns exemplos para que você possa iniciar-se nas técnicas de utilização do DDL.
Índice das FunçõesDescrição
CreateTableDDL()Cria duas tabelas, seus índices e relacionamentos, ilustrando os diferentes tipos de campos suas propriedades configuradas.
CreateFieldDDL()Ilustra como adicionar um campo para uma tabela.
CreateFieldDDL2()Adiciona um campo a uma tabela em outra base de dados.
CreateViewDDL()Cria uma nova query.
DropFieldDDL()Deleta o campo de uma tabela.
ModifyFieldDDL()Muda o tipo ou tamanho de um campo. (Este é o mais comum uso do DDL.)
AdjustAutoNum()Configura o start da AutoNumeração.
DefaultZLS()Cria um campo que tem por default ser uma stringque não suporta ficar vazia.

  
Option Compare Database
Option Explicit
  
Sub CreateTableDDL()
     Dim cmd As New ADODB.Command
     Dim strSql As String
  
   Let cmd.ActiveConnection = CurrentProject.Connection
  
   'Cria o "Contractor" na tabela.
    
   Let strSql = "CREATE TABLE tblDdlContractor " & _           "(ContractorID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, " & _         "Surname TEXT(30) WITH COMP NOT NULL, " & _           "FirstName TEXT(20) WITH COMP, " & _           "Inactive YESNO, " & _         "HourlyFee CURRENCY DEFAULT 0, " & _         "PenaltyRate DOUBLE, " & _           "BirthDate DATE, " & _         "EnteredOn DATE DEFAULT Now(), " & _           "Notes MEMO, " & _         "CONSTRAINT FullName UNIQUE (Surname, FirstName));"       
         "(ContractorID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, " & _
       "Surname TEXT(30) WITH COMP NOT NULL, " & _
    
       "FirstName TEXT(20) WITH COMP, " & _
           "Inactive YESNO, " & _
       "HourlyFee CURRENCY DEFAULT 0, " & _
       "PenaltyRate DOUBLE, " & _
    
       "BirthDate DATE, " & _
         "EnteredOn DATE DEFAULT Now(), " & _
         "Notes MEMO, " & _
       "CONSTRAINT FullName UNIQUE (Surname, FirstName));"
    
   Let cmd.CommandText = strSql       cmd.Execute       Debug.Print "tblDdlContractor criada."         'Cria a tabela de Booking.     
  
   cmd.Execute
  
   Debug.Print "tblDdlContractor criada."
    
   'Cria a tabela de Booking.
   Let strSql = "CREATE TABLE tblDdlBooking " & _           "(BookingID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, " & _         "BookingDate DATE CONSTRAINT BookingDate UNIQUE, " & _         "ContractorID LONG REFERENCES tblDdlContractor (ContractorID) " & _           "ON DELETE SET NULL, " & _         "BookingFee CURRENCY, " & _         "BookingNote TEXT (255) WITH COMP NOT NULL);"       
  
       "(BookingID COUNTER CONSTRAINT PrimaryKey PRIMARY KEY, " & _
       "BookingDate DATE CONSTRAINT BookingDate UNIQUE, " & _
         "ContractorID LONG REFERENCES tblDdlContractor (ContractorID) " & _
  
       "ON DELETE SET NULL, " & _
         "BookingFee CURRENCY, " & _
       "BookingNote TEXT (255) WITH COMP NOT NULL);"
  
   Let cmd.CommandText = strSql       cmd.Execute       Debug.Print "tblDdlBooking criado."  End Sub    Sub CreateFieldDDL()      Dim strSql As String     Dim db As DAO.Database           
     cmd.Execute
  
   Debug.Print "tblDdlBooking criado."
  End Sub
  
Sub CreateFieldDDL()
      Dim strSql As String
   Dim db As DAO.Database
    
   Let Set db = CurrentDb()     
   Let strSql = "ALTER TABLE MyTable ADD COLUMN MyNewTextField TEXT (5);"       db.Execute strSql, dbFailOnError       Set db = Nothing       Debug.Print "MyNewTextField adicionado para MyTable"  End Sub    Function CreateFieldDDL2()       Dim strSql As String     Dim db As DAO.Database         Set db = CurrentDb()       
  
   db.Execute strSql, dbFailOnError
    
   Set db = Nothing
  
   Debug.Print "MyNewTextField adicionado para MyTable"
  End Sub
  
Function CreateFieldDDL2()
       Dim strSql As String
   Dim db As DAO.Database
  
   Set db = CurrentDb()
  
   Let strSql = "ALTER TABLE Table IN 'C:\A&A\Junkki.mdb' ADD COLUMN MyNewField TEXT (5);"       db.Execute strSql, dbFailOnError       Set db = Nothing       Debug.Print "MyNewField Adicionado!"  End Function    Function CreateViewDDL()       Dim strSql As String         
  
   db.Execute strSql, dbFailOnError
    
   Set db = Nothing
  
   Debug.Print "MyNewField Adicionado!"
  End Function
  
Function CreateViewDDL()
       Dim strSql As String
  
   Let strSql = "CREATE VIEW qry1 as SELECT tblInvoice.* from tblInvoice;"       CurrentProject.Connection.Execute strSql  End Function    Sub DropFieldDDL()      Dim strSql As String         
  
   CurrentProject.Connection.Execute strSql
  End Function
  
Sub DropFieldDDL()
      Dim strSql As String
  
   Let strSql = "ALTER TABLE [MyTable] DROP COLUMN [DeleteMe];"       DBEngine(0)(0).Execute strSql, dbFailOnError  End Sub    Sub ModifyFieldDDL()     Dim strSql As String         
  
   DBEngine(0)(0).Execute strSql, dbFailOnError
  End Sub
  
Sub ModifyFieldDDL()
     Dim strSql As String
  
   Let strSql = "ALTER TABLE MyTable ALTER COLUMN MyText2Change TEXT(100);"       DBEngine(0)(0).Execute strSql, dbFailOnError  End Sub    Function AdjustAutoNum()     Dim strSql As String         
  
   DBEngine(0)(0).Execute strSql, dbFailOnError
  End Sub
  
Function AdjustAutoNum()
     Dim strSql As String
  
   Let strSql = "ALTER TABLE MyTable ALTER COLUMN ID COUNTER (1000,1);"       CurrentProject.Connection.Execute strSql  End Function    Function DefaultZLS()      Dim strSql As String         
  
   CurrentProject.Connection.Execute strSql
  End Function
  
Function DefaultZLS()
      Dim strSql As String
  
   Let strSql = "ALTER TABLE MyTable ADD COLUMN MyZLSfield TEXT (100) DEFAULT """";"       CurrentProject.Connection.Execute strSql  End Function
  
   CurrentProject.Connection.Execute strSql
  End Function


Tags: VBA, Acces, DDL, DML, DAO, ADO, CREATE, ALTER,DROP,índices, constraints, views e procedures,queries, usuário, grupos, users, groups, index, JET 4, ADOX

diHITT - Notícias