Herramienta SQL Spacer para Access, complemento gratuito con código VBA de código abierto

VBA

Módulo estándar

Este código se llama mediante el formulario del menú del complemento. También se puede ejecutar por sí solo. SQLSpacer_s4p devuelve una cadena con espaciado y saltos de línea dada una instrucción SQL.

'*************** Code Start *****************************************************
' module name: bas_SQLSpacer_s4p
'-------------------------------------------------------------------------------
' Purpose  : return SQL Statement with added line breaks and spaces
'                 so it's easier to comprehend
'            this module also includes a function to add quotes and line continuations for VBA
' Author   : crystal (strive4peace)
' web site : 
' This code: /tool/Addin_Addin_SQLSpacer.htm
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark your changes. Use at your own risk
'-------------------------------------------------------------------------------
'           LaunchMenu
'-------------------------------------------------------------------------------
Function LaunchMenu() 
'230727 strive4peace
   DoCmd.OpenForm  "f_Menu_SQLSpacer_s4p"
End Function 

'-------------------------------------------------------------------------------
'           SQLSpacer_s4p
'-------------------------------------------------------------------------------
Function SQLSpacer_s4p( _ 
   Optional ByVal pSQL As String =  "" _ 
   ) As String 
'
' SQLSpacer_s4p
' strive4peace (crystal)
' 150726 ... 150811, 230727-28
' return SQL statement with added line breaks and spacing
'  so it's easier to comprehend

   'PARAMETER
   '  pSQL = SQL statement to add line breaks and spacing to
   
   'CALLED BY:
   '  code behind form f_Menu_SQLSpacer_s4p
   '  SQLSpacer4VBA
   
   On Error GoTo Proc_Err 
 
   SQLSpacer_s4p =  ""
   If Not Len(Trim(pSQL)) > 0 Then Exit Function 
 
   Dim sSQL As String _ 
      ,sLineBreak As String _ 
      ,i As Integer 
 
   'NOTE: there could be more terms in this list
   Const iMax As Integer = 14 
   Dim aLookFor(1 To iMax) As String 
 
   sSQL = Trim(pSQL) 
 
   sLineBreak = vbCrLf 
 
   sSQL = Replace(sSQL,sLineBreak, " ") 
   
   aLookFor(1) =  " SELECT "
   aLookFor(2) =  " FROM "
   aLookFor(3) =  " IN "
   aLookFor(4) =  " INTO "
   aLookFor(5) =  " WHERE "
   aLookFor(6) =  " GROUP BY "
   aLookFor(7) =  " HAVING "
   aLookFor(8) =  " ORDER BY "
 
   aLookFor(9) =  " SET "
   aLookFor(10) =  " ON "
   aLookFor(11) =  " AND "
   aLookFor(12) =  " LEFT "
   aLookFor(13) =  " RIGHT "
   aLookFor(14) = " INNER "
 
   For i = 1 To iMax 
      If i >= 9 Then 
         sSQL = Replace(sSQL,aLookFor(i),sLineBreak & Space(3) & aLookFor(i)) 
      Else 
         sSQL = Replace(sSQL,aLookFor(i),sLineBreak &  " " & aLookFor(i)) 
      End If 
   Next i 
   'replace commas with line break, space, comma
   sSQL = Replace(sSQL, ", ",sLineBreak & Space(3) &  ", ") 
 
   SQLSpacer_s4p = sSQL 
   
   'Also print to Immediate (Debug) window -- Ctrl-G to look
   Debug.Print sSQL 

 
Proc_Exit: 
   On Error Resume Next 
   Exit Function 
 
Proc_Err: 
   MsgBox Err.Description,,_ 
        "ERROR " & Err.Number _ 
        &  "   SQLSpacer_s4p"
 
   Resume Proc_Exit 
   Resume 
 
End Function 
 
'-------------------------------------------------------------------------------
'           runSQLSpacer4VBA
'-------------------------------------------------------------------------------
Sub runSQLSpacer4VBA() 
   'Customize and then CLICK HERE and Press F5 to Run!
   'Ctrl-G to look at Immediate (Debug) window to see Results
   Dim sSQL As String 
   '------------------------ customize with your SQL statement to test
   sSQL =  "SELECT E.AtomicN, E.Symb, E.Element, E.AtomicMass, IIf((E).(Row_)Debug.Print sSQL 
End Sub 
 
'-------------------------------------------------------------------------------
'           SQLSpacer4VBA
'-------------------------------------------------------------------------------
Function SQLSpacer4VBA(ByVal pSQL As String) As String 
   Dim sSQL As String _ 
   ,iPos As Integer 
 'create a string you can paste into a VBA procedure to construct an SQL statement
 ' adds quote marks and replaces CrLf with line continuation for VBA
 '    Modify to include variable as desired
   sSQL = SQLSpacer_s4p(pSQL) 
   sSQL = Trim( """" & Replace(sSQL,vbCrLf, " "" _" & vbCrLf &  " & """)) 
   iPos = InStrRev(sSQL, ";") 
   If iPos > 0 Then 
      sSQL = Trim(Left(sSQL,iPos)) &  """"
   End If 
   SQLSpacer4VBA = sSQL 
End Function 


'*************** Code End *****************************************************

Ir al inicio

Código detrás del formulario de menú, f_Menu_SQLSpacer_s4p

Option Compare Database 
Option Explicit 

'*************** Code Start *****************************************************
' code behind form: f_Menu_SQLSpacer_s4p
'-------------------------------------------------------------------------------
' Purpose  : add line breaks and spaces to SQL statement so it's easier to comprehend
'            textbox with Original SQL and Result SQL
'            bound to a table with 2 long text fields
'              keep overwriting same record
' Author   : crystal (strive4peace)
' web site : 
' This code: /tool/Addin_Addin_SQLSpacer.htm
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark your changes. Use at your own risk.
'TABLE:
'  s4p_Mem: one record with long text fields
'     is used over and over so strings can be longer
'-------------------------------------------------------------------------------
'           Form_Load
'-------------------------------------------------------------------------------
Private Sub Form_Load() 
'200410 strive4peace
   'clear old data
   Me.memOrig = Null 
   Me.memResult = Null 
End Sub 


'-------------------------------------------------------------------------------
'           memOrig_AfterUpdate
'-------------------------------------------------------------------------------
Private Sub memOrig_AfterUpdate() 
'230727, 28
' write results to the form
   
   'call SQLSpacer_s4p
   With Me 
      If IsNull(.memOrig.Value) Then Exit Sub 
      .memResult.Value = SQLSpacer_s4p(.memOrig.Value &  "") 
   End With 

Proc_Exit: 
      On Error Resume Next 
      Exit Sub 
Proc_Err: 
      MsgBox Err.Description _ 
          ,, "ERROR " & Err.Number _ 
           &  "   memOrig_AfterUpdate : " & Me.Name 

      Resume Proc_Exit 
      'if you BREAK MsgBox, you can set this to be next statement:
      Resume 
End Sub 

'-------------------------------------------------------------------------------
'           cmd_Copy2Clipboard_Click
'-------------------------------------------------------------------------------
Private Sub cmd_Copy2Clipboard_Click() 
'200411 strive4peace, 230727
'copy result code to the Windows clipboard
   Dim sCode As String 
   With Me.memResult 
      If Nz(.Value, "") =  "" Then Exit Sub 
      sCode = .Value 
   End With 
   'MSForms.DataObject
   With CreateObject( "new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") 
      .SetText sCode 
      .PutInClipboard 
   End With 
   MsgBox  "Press Ctrl-V to paste the Result where you want it",, "Done"
End Sub 

'-------------------------------------------------------------------------------
'           cmd_SaveFile_Click
'-------------------------------------------------------------------------------
Private Sub cmd_SaveFile_Click() 
'200429 strive4peace, 230728
' save SQL results to a text file. Will start with "SQL_" and end with Now as "yymmdd_hhnn_ss"
'  Prompt for optional Title to include in file name
'  Path is currently a folder called \strive4peace\ on the Desktop, which can be changed

   'CALLS
   '  SaveStringAsFile
   Dim sPathFile As String _ 
      ,sPath As String _ 
      ,sTitle As String _ 
      ,sResult As String 

   sResult =  ""
   With Me.memResult 
      If Nz(.Value, "") =  "" Then Exit Sub 
      sResult = .Value 
   End With 

   sTitle = InputBox( "Enter optional title to include in file name:" _ 
      , "Title", "") 
   
   '--- sPath
   sPath = Environ( "USERPROFILE") &  "\Desktop\strive4peace\"
   'create folder if it doesn't yet exist
   If Dir(sPath,vbDirectory) =  "" Then 
      MkDir sPath 
      DoEvents 
   End If 
   
   'add filename to path
   sPathFile = sPath &  "SQL_" _ 
      & IIf(sTitle   "",sTitle &  "_", "") _ 
      & Format(Now(), "yymmdd_hhnn_ss") &  ".txt"
      
   ' Call SaveStringAsFile
'   With Me.memResult
      If sResult   "" Then 
         Call SaveStringAsFile(sPathFile,sResult) 
      Else 
         MsgBox  "Nothing to save", "Nothing to do"
         Exit Sub 
      End If 
      
      
      
'   End With
   
   If MsgBox(sPathFile &  " was created. Open Path to file?" _ 
      ,vbYesNo, "Open Path?") = vbNo Then Exit Sub 
      
   Application.FollowHyperlink sPath 
   
End Sub 

'---------------------------------------------------------------------------------------
'                              SaveStringAsFile
'---------------------------------------------------------------------------------------
' this could be a Public procedure
Private Sub SaveStringAsFile(psPathFile As String,psFileContents As String) 
'160730 strive4peace
   Dim iFile As Integer 
   iFile = FreeFile 
   Open psPathFile For Output As iFile 
   Print #iFile,psFileContents 
   Close iFile 
End Sub 
'

'*************** Code End *******************************************************