Attribute VB_Name = "m_Access"
Option Compare Database
Option Explicit

'=========== Access - funes referentes a Banco de dados e campos ===========

Public Sub AppTitle(T As String)
  Dim obj As Object
  Const conPropNotFoundError = 3270
  On Error GoTo ErrorHandler
  CurrentDb.Properties!AppTitle = T
  Application.RefreshTitleBar
  Exit Sub
ErrorHandler:
  If Err.Number = conPropNotFoundError Then
    Set obj = CurrentDb.CreateProperty("AppTitle", dbText, T)
    CurrentDb.Properties.Append obj
  Else
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
  End If
  Resume Next
End Sub


Public Sub Remove_Prefix_Tables(Prefix As String)
  ' Remove table names prefix (to use in linked tables)
  Dim T%, x
  T = Len(Prefix)
  If T = 0 Then Exit Sub
  For Each x In CurrentDb.TableDefs
    If Left(x.Name, T) = Prefix Then
      x.Name = Mid(x.Name, T + 1)
    End If
  Next
End Sub


Public Function fn_Scalar(SQL As String, Optional DSN As String = "")
  On Error GoTo fn_Scalar_Err
  Dim q As QueryDef
  Dim a As DAO.Recordset
  Set q = CurrentDb.CreateQueryDef("")
  If DSN > "" Then q.Connect = "ODBC;DSN=" & DSN & ";"
  q.SQL = SQL
  Set a = q.OpenRecordset(dbOpenDynaset, dbSeeChanges)
  If a.RecordCount = 0 Then
    fn_Scalar = Null
  Else
    fn_Scalar = a.Fields(0).Value
  End If
  Exit Function
fn_Scalar_Err:
  If Errors.Count >= 2 Then
    fn_Scalar = "**** " & error & " = " & Errors(Errors.Count - 2).Description
  ElseIf Errors.Count >= 1 Then
    fn_Scalar = "**** " & error & " = " & Errors(Errors.Count - 1).Description
  End If
End Function


Public Function fn_Count(Table As String, Field As String, Value As Variant) As Integer
  fn_Count = fn_Scalar("Select count(*) from " & Table & " where " & Field & "=" & SQL_Value(Value))
End Function


Public Function fn_Table(SQL As String, Optional DSN As String = "") As DAO.Recordset
  Dim q As QueryDef
  Dim r As DAO.Recordset
  Set q = CurrentDb.CreateQueryDef("")
  If DSN > "" Then q.Connect = "ODBC;DSN=" & DSN & ";Trusted_Connection=Yes;"
  q.SQL = SQL
  Set fn_Table = q.OpenRecordset(dbOpenDynaset, dbSeeChanges)
End Function


Public Function Exec_SQL(SQL As String, Optional DSN As String = "") As Integer
  Dim q As QueryDef
  Set q = CurrentDb.CreateQueryDef("")
  If DSN > "" Then q.Connect = "ODBC;DSN=" & DSN & ";Trusted_Connection=Yes;"
  q.SQL = SQL
  q.ReturnsRecords = False
'  q.Execute dbSeeChanges
  q.Execute
  Exec_SQL = q.RecordsAffected
End Function


Public Function GetString(r As Recordset) As String
  Dim s As String, x As Integer
  If r.RecordCount > 0 Then
    r.MoveFirst
    While Not r.EOF()
      If Len(s) > 0 Then s = s & vbCrLf
      For x = 0 To r.Fields.Count - 1
        s = s & r.Fields(x) & ";"
      Next x
      r.MoveNext
    Wend
  End If
  GetString = s
End Function


Public Function GUID_Clean(GUID As Variant) As String
  Dim G As String
  If IsNull(GUID) Then
    G = ""
  ElseIf TypeName(GUID) = "Textbox" Or TypeName(GUID) = "ComboBox" Then
    G = StringFromGUID(Nz(GUID, ""))
  Else
    G = GUID
  End If
  If Left(G, 6) = "{guid " Then
    GUID_Clean = Mid(G, 7, 38)
  Else
    GUID_Clean = G
  End If
End Function


Public Function Form_GUID(Form As String, Field As String) As String
  On Error Resume Next
  Form_GUID = GUID_Clean(StringFromGUID(Forms(Form).Form.Recordset(Field)))
End Function


Public Function Next_Code(Table As String, Optional Field As String = "")
  ' Return the next code of the PrimaryKey of table
  Dim a As Recordset, b
  Set a = CurrentDb.OpenRecordset(Table)
  a.Index = "PrimaryKey"
  a.MoveLast
  If Field = "" Then
    Next_Code = a(0) + 1
  Else
    Next_Code = a(Field) + 1
  End If
  a.Close
End Function


Public Function Locate(f As Form, ByVal Code As Variant, Optional lB As ListBox = Nothing)
  ' Localiza o cdigo cod no primeiro campo do recordset do form f.
  ' Caso LB seja passado, posiciona LB em cod
  Dim rs As DAO.Recordset
  Dim Tipo As String
  Tipo = TypeName(Code)
  If Tipo = "AccessField" Or Tipo = "Field" Then Tipo = TypeName(Code.Value)
  If Tipo <> "GUID" Then
    If Not Left(Code, 1) = "{" Then Code = Str(Nz(Code, 0))
  Else
    Code = GUID_Clean(Code)
  End If
  Set rs = f.RecordsetClone
  If rs.Fields(0).Type = dbGUID Then
    rs.MoveFirst
    Do While Not rs.EOF()
      If Code = GUID_Clean(rs.Fields(0)) Then Exit Do
      rs.MoveNext
    Loop
  Else
    If Not IsNull(Code) Then
      rs.FindFirst "[" & rs.Fields(0).Name & "] = " & Code  ' Str(Nz(lst, 0))
    End If
  End If
  If Not rs.EOF Then f.Bookmark = rs.Bookmark
  If Not lB Is Nothing Then lB.Value = Code
End Function


Public Sub Save_Record()
    DoCmd.DoMenuItem acFormBar, acRecordsMenu, acSaveRecord, , acMenuVer70
End Sub


Public Sub Undo()
    DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70
End Sub


Public Sub Msg_Save_Changes(ByRef Cancel As Integer)
  Dim x
  x = MsgBox("Salva as alteraes?", vbYesNoCancel + vbDefaultButton1) ' "Save changes?"
  If x = vbYes Then Exit Sub
  If x = vbNo Then Undo
  Cancel = (x = vbCancel)
End Sub


Public Function ListBox_MultValue(l As ListBox, Optional Column = 0, Optional Delimiter = ",", Optional Type_ = "N") As String
' Retorna string com todos os itens selecionados separados por Separador
  Dim r$, x%
  For x = 0 To l.ListCount
    If l.Selected(x) Then r = r & IIf(Type_ <> "N", """", "") & l.Column(Column, x) & IIf(Type_ <> "N", """", "") & Delimiter
  Next x
  If Right(r, Len(Delimiter)) = Delimiter Then r = Left(r, Len(r) - Len(Delimiter))
  ListBox_MultValue = r
End Function


Public Function Make_WHERE(Field As String, FieldDefault As String, lst As ListBox) As String
  Dim f$, Campo$
  f = "("
  Campo = IIf(Field = "*" Or Field = ".", FieldDefault, Replace(Field, "*", ""))
  If Left(Field, 1) = "*" Then f = f & Campo & " IS NULL OR "
  Make_WHERE = f & Campo & " In (" & ListBox_MultValue(lst) & "))"
End Function


Public Function Insert_Name(Table As String, Name As String, Optional Field_Code = 0, Optional Field_Name = 1)
  ' Field_Code = number or name of the field that have the PrimaryKey
  ' Field_Name = number or name of the field that will save the Name value
  On Error GoTo IncluiNome_erro
  Dim a As Recordset, b
  If Nz(Name) = "" Then
    Insert_Name = acDataErrDisplay
  ElseIf MsgBox("Inclui o " + Table + " '" + Name + "' ?", vbYesNo, "Incluso") = vbYes Then
    Set a = CurrentDb.OpenRecordset(Table)
    a.Index = "PrimaryKey"
    a.MoveLast
    b = a(Field_Code) + 1
    a.AddNew
    a(Field_Name) = Name
    a(Field_Code) = b
    a.Update
    a.Close
    Insert_Name = acDataErrAdded
  Else
    Insert_Name = acDataErrDisplay
  End If
  Exit Function
IncluiNome_erro:
  MsgBox Err.Description
  Insert_Name = acDataErrContinue
End Function


Public Function GetFixedSizeTXT(r As Recordset, Optional So_Estrutura As Boolean = False) As String
  Dim s As String, x As Integer, e As Boolean
  If So_Estrutura Then
    e = True
  Else
    r.MoveFirst
  End If
  While (So_Estrutura = False And Not r.EOF()) Or (So_Estrutura And e)
    For x = 0 To r.Fields.Count - 1
      If r.Fields(x).Type = dbDecimal Then
        If e Then
          ' ? r.Fields(x).Properties("decimalPlaces")
          s = s & r.Fields(x).Name & vbTab & "N" & r.Fields(x).CollatingOrder & vbCrLf  ' bug - size est no collatingOrder
        Else
          s = s & Format(r.Fields(x), String(r.Fields(x).CollatingOrder, "0"))
        End If
      ElseIf r.Fields(x).Type = dbText Then
        If e Then
          s = s & r.Fields(x).Name & vbTab & "A" & r.Fields(x).Size & vbCrLf
        Else
          s = s & RPad(Nz(r.Fields(x)), r.Fields(x).Size, " ")
        End If
      Else
        MsgBox "Tipo de campo invlido."
      End If
    Next x
    If So_Estrutura Then
      e = False
    Else
      r.MoveNext
      s = s & vbCrLf
    End If
  Wend
  GetFixedSizeTXT = s
End Function


Public Sub Replace_Table_Connections(Text_to_Find As String, New_Text As String)
  ' Replace text in 'Connect' string of linked tables
  Dim T%, x
  T = Len(Text_to_Find)
  If T = 0 Then Exit Sub
  For Each x In CurrentDb.TableDefs
    If InStr(x.Connect, Text_to_Find) > 0 Then
      x.Connect = Replace(x.Connect, Text_to_Find, New_Text)
      x.RefreshLink
    End If
  Next
End Sub


Public Function ADORecordsetMemory(query As String) As ADODB.Recordset
  Dim rs As ADODB.Recordset
  Dim r As ADODB.Recordset
  Dim f, x%, nc%
  Set rs = New ADODB.Recordset
  Set r = New ADODB.Recordset
  rs.Open query, CurrentProject.Connection
  With r
    nc = rs.Fields.Count - 1
    For x = 0 To nc
      r.Fields.Append rs.Fields(x).Name, rs.Fields(x).Type, rs.Fields(x).DefinedSize, rs.Fields(x).Attributes
    Next x
    .CursorType = adOpenKeyset
    .CursorLocation = adUseClient
    .LockType = adLockPessimistic
    .Open
  End With
  rs.MoveFirst
  Do Until rs.EOF
    r.AddNew
    For x = 0 To nc
      r.Fields(x) = rs.Fields(x)
    Next x
    rs.MoveNext
  Loop
  Set ADORecordsetMemory = r
End Function


Public Function AgregaStr(Tabela As String, Campo_Agr As String, Campo_Where As String, Valor, Optional Separador As String = ",")
  Dim s As String
  s = RTrimEx(GetString(CurrentDb.OpenRecordset("SELECT " & Campo_Agr & " FROM " & Tabela & " WHERE " & Campo_Where & "=" & Valor)), ";")
  AgregaStr = RTrimEx(Replace(s, ";" & vbCrLf, Separador), Separador)
End Function


Public Function Picture_In_Report(Img As Image, File As String)
  Img.Picture = File
End Function
