CODE
Option Compare Database
Option Explicit
Type MyFldType
FldName As String
FldType As String
FldSize As Integer
End Type
Function basXpose(strSource As String, Optional ByVal strTarget As Variant)
Dim dbs As DAO.Database
Dim rstSrc As DAO.Recordset
Dim rstDest As DAO.Recordset
Dim Idx As Integer
Dim Jdx As Integer
Dim Kdx As Integer
Dim Ldx As Integer
Dim MyStatus As Long
Dim MyDest As String
On Error GoTo ErrExit
If (IsMissing(strTarget)) Then
MyDest = strSource & "Xpose"
Else
MyDest = strTarget
End If
Set dbs = CurrentDb()
Set rstSrc = dbs.OpenRecordset(strSource)
'Seperate routine to create the table
MyStatus = basCreXposeTbl(strSource, MyDest)
If (MyStatus <> 0) Then
MsgBox "Err(" & MyStatus & ") " & Error(Err), vbCritical, "File Creation Error"
GoTo ErrExit
End If
'Open the New table, to populate it's fields with the source recordset records
rstSrc.MoveFirst
Set rstDest = dbs.OpenRecordset(MyDest, dbOpenDynaset)
'Fill each Field of the tblNew (rstDest) _
with a record from the recordset in the input argument (rstSrc).
Idx = 1
While Idx < rstSrc.Fields.Count '(1 to 11)
Jdx = 0
rstSrc.MoveFirst
'Begin with the second field, because the first field _
already contains the field names.
With rstDest
.AddNew
If (Jdx = 0) Then
.Fields(Jdx) = rstSrc.Fields(Idx).Name
Jdx = Jdx + 1
End If
Do While Jdx < rstDest.Fields.Count - 1 '(1 to 128)
.Fields(Jdx) = Trim(rstSrc.Fields(Idx).Value)
rstSrc.MoveNext
If (rstSrc.EOF = True) Then
Exit Do
End If
Jdx = Jdx + 1
Loop
.Update
End With
Idx = Idx + 1
Wend
Set rstSrc = Nothing
Set rstDest = Nothing
dbs.Close
Exit Function
ErrExit:
Select Case Err
Case 3010
MsgBox "The table " & strTarget & " already exists."
Case 3078
MsgBox "The table " & strSource & " doesn't exist."
Case 3191 'Camnnot define field more than once
MsgBox "Camnnot define field more than once"
Case Else
MsgBox CStr(Err) & " " & Err.Description
End Select
Exit Function
End Function
Public Function basValdName(strIn As String) As String
'To remove Invalid Characters and Spaces from "proposed" field Names
Dim Idx As Long
Dim Jdx As Long
Dim blnVldChr As Boolean
Dim MyChr As String * 1
Dim strOut As String
Dim InVldChrs(30) As String * 1
Dim blnWhtSpc As Boolean
InVldChrs(0) = "."
InVldChrs(1) = "/"
InVldChrs(2) = "\"
InVldChrs(3) = "&"
InVldChrs(4) = "^"
InVldChrs(5) = "%"
InVldChrs(6) = "*"
InVldChrs(7) = "("
InVldChrs(8) = ")"
InVldChrs(9) = "!"
InVldChrs(10) = "@"
InVldChrs(11) = "#"
InVldChrs(12) = "$"
InVldChrs(13) = "<"
InVldChrs(14) = ">"
InVldChrs(15) = "?"
InVldChrs(16) = "+"
InVldChrs(17) = " "
InVldChrs(18) = "{"
InVldChrs(19) = "}"
InVldChrs(20) = "["
InVldChrs(21) = "]"
InVldChrs(22) = "|"
InVldChrs(23) = Chr(34)
InVldChrs(24) = Chr(39)
InVldChrs(25) = ""
InVldChrs(26) = ""
InVldChrs(27) = ""
InVldChrs(28) = ""
InVldChrs(29) = ""
InVldChrs(30) = ""
Idx = 1
While Idx <= Len(strIn)
MyChr = Mid(strIn, Idx, 1)
If (Idx = 1) Then
If (IsNumeric(MyChr)) Then
strOut = "_" & MyChr
End If
End If
Jdx = 0
blnVldChr = True
Do While Jdx <= UBound(InVldChrs)
If (MyChr = InVldChrs(Jdx)) Then
blnVldChr = False
blnWhtSpc = True
Exit Do
End If
Jdx = Jdx + 1
Loop
If (blnVldChr = True) Then
If (blnWhtSpc = True) Then
strOut = strOut & UCase(MyChr)
blnWhtSpc = False
Else
strOut = strOut & MyChr
End If
End If
Idx = Idx + 1
Wend
basValdName = strOut
End Function
Public Function basCreXposeTbl(strSource As String, strTarget As String) As Long
Dim dbs As DAO.Database
Dim rstSrc As DAO.Recordset
Dim tblNew As TableDef
Dim fldNew As DAO.Field
Dim MyNewFld As String
Dim MyFld() As MyFldType
Dim FldLen() As String
Dim Idx As Long
Dim Jdx As Long
Dim Kdx As Long
Dim MyFldLen As Integer
On Error GoTo ErrExit
Set dbs = CurrentDb()
Set rstSrc = dbs.OpenRecordset(strSource)
'Get a valid record count from the Source Table
Idx = rstSrc.RecordCount
ReDim MyFld(Idx)
ReDim FldLen(Idx)
rstSrc.MoveFirst
'First field name Derived from the Field Name of Field(0)
MyFld(0).FldName = basValdName(rstSrc.Fields(0).Name)
'Remaiining field names from field(0) values
Idx = 1
While Not rstSrc.EOF
MyFld(Idx).FldName = basValdName(rstSrc.Fields(0).Value)
rstSrc.MoveNext
Idx = Idx + 1
Wend
'Here with a supposed set of field names in an array. Need to _
check for dups and adjust to make sure there are none
Idx = 0
While Idx <= UBound(MyFld) - 1
Kdx = 1
Jdx = Idx + 1
While Jdx <= UBound(MyFld) - 1
If (MyFld(Jdx).FldName = MyFld(Idx).FldName) Then
'Aparent Dup - so add a suffix
MyFld(Jdx).FldName = MyFld(Jdx).FldName & "_" & Trim(Str(Kdx))
Kdx = Kdx + 1
End If
Jdx = Jdx + 1
Wend
Idx = Idx + 1
Wend
'Here to get the field Types and (for Text fields) the Sizes
Idx = 1
rstSrc.MoveFirst
While Not rstSrc.EOF
MyFldLen = 1
Jdx = 1
While Jdx <= rstSrc.Fields.Count - 1
If (Not IsNull(Len(Trim(rstSrc.Fields(Jdx))))) Then
MyFldLen = Len(Trim(rstSrc.Fields(Jdx)))
If (MyFldLen > MyFld(Idx).FldSize) Then
MyFld(Idx).FldSize = MyFldLen
End If
End If
Jdx = Jdx + 1
Wend
Idx = Idx + 1
rstSrc.MoveNext
Wend
' Create a new table to hold the transposed data.
Set tblNew = dbs.CreateTableDef(strTarget)
'Create a field for each record in the original table, with _
field names derived from the First Column of the Source Recordset.
Idx = 0
While Idx <= UBound(MyFld)
With tblNew
.Fields.Append .CreateField(MyFld(Idx).FldName, dbText, MyFld(Idx).FldSize)
End With
Idx = Idx + 1
Wend
'Actually Save the New table with the fields (all are text!)
dbs.TableDefs.Append tblNew
'Show the new table in the dbWindow
RefreshDatabaseWindow
Set rstSrc = Nothing
Set dbs = Nothing
ErrExit:
basCreXposeTbl = Err
End Function
Public Function basXferPlanInfo(strTblIn As String, strTblOut As String) As Boolean
Dim dbs As DAO.Database
Dim rstSrc As DAO.Recordset
Dim rstDest As DAO.Recordset
Dim Idx As Integer
Dim Jdx As Integer
Dim Kdx As Integer
Dim strSQl As String
Dim MyFld As Variant
Dim MySrcFld As String
Dim MyDestFld As String
strSQl = "Delete * from " & strTblOut & ";"
DoCmd.SetWarnings False
DoCmd.RunSQL strSQl
DoCmd.SetWarnings True
Set dbs = CurrentDb
Set rstSrc = dbs.OpenRecordset(strTblIn, dbOpenDynaset)
Set rstDest = dbs.OpenRecordset(strTblOut, dbOpenDynaset)
While Not rstSrc.EOF 'The Whole magillia
Idx = 0
With rstDest
.AddNew
While Idx < rstSrc.Fields.Count
MySrcFld = rstSrc.Fields(Idx).Name 'Get the name of the source field
'Seperate routine to return the content of "Boolean" fields _
(Could by "Y", "N", Other String, oor Null
If (rstDest(MySrcFld).Type = dbBoolean) Then
MyFld = basChkBlnContent(rstSrc("Company"), rstSrc("ServicePlan"), MySrcFld)
Else
'Not Boolean, just copy it
rstDest(MySrcFld) = rstSrc(MySrcFld)
GoTo NoBool
End If
If (Not IsNull(MyFld)) Then
'Something there, Where to Place it?
If (MyFld = "N") Then 'Is it a No?
rstDest(MySrcFld) = False
Else
rstDest(MySrcFld) = Null
End If
End If
If (MyFld = "Y") Then
rstDest(MySrcFld) = True
End If
If (Len(MyFld) > 1) Then
rstDest(MySrcFld & "Desc") = MyFld
End If
NoBool:
Idx = Idx + 1 'rstSrc Field Index
Wend 'Idx (Index of rstDest.Fields.Count)
.Update
End With 'rstSrc
rstSrc.MoveNext 'Next Source Record
Wend
End Function
Public Function basChkBlnContent(ByVal MyCpny As String, _
ByVal MyPln As String, _
Optional ByVal MyFld As Variant) As Variant
Dim dbs As DAO.Database
Dim rstSrc As DAO.Recordset
Set dbs = CurrentDb
Set rstSrc = dbs.OpenRecordset("tblSvcPlnXpose", dbOpenDynaset)
'Routine to check for "boolean" fields which actually contains Text. _
Where this occurs, Return the Text in the source recordset field, _
otherwise, return Null. The Calling procedure will set the corresponding _
Text field to the Value returned. The Calling procedure is further _
responsible for the setting of the boolean field, which is based on _
wheather there is ANY text in the "boolean" field, and what it is.
Dim Idx As Integer
Dim Jdx As Integer
Dim blnFldMatch As Boolean
Dim strCrit As String
Dim Tmp As Variant
Dim Quo As String * 1
Quo = Chr(34)
'This array is for the few "boolean" fields in [rstSrc] _
which (unfortunatly) include text. The Text (other than Y/N) _
needs to be transfered to the Filed with the Name "FldsNew" & Desc _
(e.g. the Text would go into [CirculatorPumpDesc] and the (boolean _
field [CirculatorPump] is set to "Y" (true).
Dim FldsNew(8) As String
FldsNew(0) = "CirculatorPump"
FldsNew(1) = "CirculatorRelays"
FldsNew(2) = "EletricalWiring"
FldsNew(3) = "HotWaterHeaterTankAndCoil"
FldsNew(4) = "PressureReliefValves"
FldsNew(5) = "PurgingValve"
FldsNew(6) = "ZoneDampers"
FldsNew(7) = "ZoneMotors"
FldsNew(8) = "ZoneValve"
Jdx = 0
Do While Jdx <= UBound(FldsNew)
If (MyFld) = FldsNew(Idx) Then
blnFldMatch = True
Exit Do
End If
Jdx = Jdx + 1
Loop
strCrit = "Company = " & Quo & MyCpny & Quo & " and " & "ServicePlan = " & Quo & MyPln & Quo
rstSrc.FindFirst strCrit
If (rstSrc.NoMatch) Then
'Error. Just Bail
GoTo ErrExit
End If
If (Jdx > UBound(FldsNew)) Then
'No match to the bad boys, set return and exit
Tmp = rstSrc(MyFld)
GoTo NormExit
End If
'Here because there IS a match
If (IsNull(rstSrc(MyFld))) Then
Tmp = Null
GoTo NormExit
End If
If (IsMissing(rstSrc(MyFld))) Then
Tmp = Null
GoTo NormExit
End If
If (Len(rstSrc(MyFld)) > 0) Then
Tmp = Trim(rstSrc(MyFld))
GoTo NormExit
End If
NormExit:
If (IsEmpty(Tmp)) Then
Tmp = rstSrc(MyFld)
End If
basChkBlnContent = Tmp
ErrExit:
Exit Function
End Function
-