Function savedbf() As Boolean
Dim filename As Variant
Dim temp As Variant
Dim currentFile As String
Dim defaultFile As String
currentFile = ActiveWorkbook.Name
temp = Split(currentFile, ".")
temp(UBound(temp)) = "dbf"
defaultFile = Join(temp, ".")
If defaultFile = "dbf" Then
defaultFile = ActiveWorkbook.Name & ".dbf"
End If
filename = Application.GetSaveAsFilename(InitialFileName:=defaultFile, FileFilter:="DBF 4 (dBASE IV) (*.dbf),*.dbf", Title:="Save As DBF")
If filename = False Then Exit Function
savedbf = DoSaveDefault(filename)
End Function
Function DoSaveDefault(ByVal filename As String)
' Declare DB vars
Dim path As Variant
Dim file As Variant
Dim tfile As Variant
Dim table As Variant
Dim dbConn As ADODB.Connection
' Initialize DB vars
path = Split(filename, "\")
file = path(UBound(path))
file = Replace(Left(file, Len(file) - 4), ".", "_") & Right(file, 4)
tfile = "__T_DB__.dbf"
path(UBound(path)) = ""
path = Join(path, "\")
table = Left(tfile, 8)
filename = path & file
' Check if file exists
On Error Resume Next
GetAttr filename
If Err.Number = 0 Then
Dim mbResult As VbMsgBoxResult
mbResult = MsgBox("The file " & file & " already exists. Do you want to replace the existing file?", _
VbMsgBoxStyle.vbYesNo + VbMsgBoxStyle.vbExclamation, "File Exists")
If mbResult = vbNo Then
DoSaveDefault = False
Exit Function
Else
SetAttr filename, vbNormal
Kill filename
End If
End If
Err.Number = 0
GetAttr filename
If Err.Number = 0 Then
MsgBox "Unable to remove existing file " & file & ".", vbExclamation, "Error Removing File"
DoSaveDefault = False
Exit Function
End If
On Error GoTo 0
' Open DB connection
Set dbConn = New ADODB.Connection
dbConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & path & ";Extended Properties=""DBASE IV;"";"
' Declare excel vars
Dim dataRange As Range
Set dataRange = Selection
If dataRange.Areas.Count > 1 Then
MsgBox "The command you chose cannot be performed with multiple selections. Select a single range and click the command again.", _
VbMsgBoxStyle.vbCritical, "Error Saving File"
DoSaveDefault = False
Exit Function
End If
' Expand selection if single cell (Expands selection using the Excel 2003 save DBF behavior)
'If dataRange.Cells.Count = 1 Then
' If IsEmpty(dataRange.Cells(1).Value) Then
' MsgBox "The command could not be completed by using the range specified. Select a single cell within the range and try the command again.", _
' VbMsgBoxStyle.vbExclamation, "Error Saving File"
' DoSaveDefault = False
' Exit Function
' Else
' Set dataRange = dataRange.CurrentRegion
' End If
'End If
' Expand selection if single cell (Differs from normal Excel 2003 behavior by not stopping at blank rows and columns)
If dataRange.Cells.Count = 1 Then
Dim row1 As Integer
Dim rowN As Integer
Dim col1 As Integer
Dim colN As Integer
Dim cellFirst As Range
Dim cellLast As Range
row1 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlNext).row
col1 = ActiveSheet.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
rowN = ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
colN = ActiveSheet.Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Set cellFirst = ActiveSheet.Cells(row1, col1)
Set cellLast = ActiveSheet.Cells(rowN, colN)
Set dataRange = ActiveSheet.Range(cellFirst.Address, cellLast.Address)
End If
' Declare data vars
Dim i As Integer
Dim j As Integer
Dim numCols As Integer
Dim numDataCols As Integer
Dim numRows As Long
Dim createString As String
Dim fieldpos(), fieldvals(), fieldtypes(), fieldnames(), fieldactive()
numCols = dataRange.Columns.Count
numDataCols = 0
numRows = dataRange.Rows.Count
ReDim fieldtypes(0 To numCols - 1)
ReDim fieldnames(0 To numCols - 1)
ReDim fieldactive(0 To numCols - 1)
' Fill field names
i = 0
For Each c In dataRange.Rows(1).Columns
' Mark column active if not blank
If WorksheetFunction.CountA(c.EntireColumn) > 0 Then
fieldactive(i) = True
numDataCols = numDataCols + 1
If VarType(c.Value) = vbString Then
fieldnames(i) = Left(Replace(c.Value, " ", "_"), 10)
Else
fieldnames(i) = "N" & c.Column
End If
Else
fieldactive(i) = False
End If
i = i + 1
Next
' Fill field positions
ReDim fieldpos(0 To numDataCols - 1)
ReDim fieldvals(0 To numDataCols - 1)
For i = 0 To numDataCols - 1
fieldpos(i) = i
Next
' Fill field types
If dataRange.Rows.Count < 2 Then
For i = 0 To numCols - 1
If fieldactive(i) Then
fieldtypes(i) = vbString
End If
Next
Else
i = 0
For Each c In dataRange.Rows(2).Columns
If fieldactive(i) Then
fieldtypes(i) = VarType(c.Value)
End If
i = i + 1
Next
End If
' Create table
Dim cat As ADOX.Catalog
Dim tbl As ADOX.table
Dim col As ADOX.Column
Set cat = New ADOX.Catalog
cat.ActiveConnection = dbConn
Set tbl = New ADOX.table
tbl.Name = table
For i = 0 To numCols - 1
' Only add non-blank columns
If fieldactive(i) Then
Set col = New ADOX.Column
col.Name = fieldnames(i)
fillColumnType col, fieldtypes(i), dataRange.Columns(i + 1)
tbl.Columns.Append col
Set col = Nothing
End If
Next
On Error Resume Next
cat.Tables.Delete table
On Error GoTo 0
cat.Tables.Append tbl
' Populate table
Dim rs As ADODB.Recordset
Dim r As Range
Dim row As Long
Set rs = New ADODB.Recordset
rs.Open table, dbConn, adOpenDynamic, adLockPessimistic, adCmdTable
If rs.LockType = LockTypeEnum.adLockReadOnly Then
MsgBox "The recordset is read-only.", vbExclamation, "Error Inserting Record"
End If
For row = 2 To numRows
Set r = dataRange.Rows(row)
' Only add non-blank rows
If WorksheetFunction.CountA(r.EntireRow) > 0 Then
i = 0
j = 0
For Each c In r.Cells
If fieldactive(i) Then
fieldvals(j) = getValByVbType(c.Text, fieldtypes(i))
j = j + 1
End If
i = i + 1
Next
rs.AddNew fieldpos, fieldvals
End If
Next
' Close the recordset and connection
rs.Close
dbConn.Close
' Copy file to final destination (this is necessary because the Jet driver limits
' the filename to 8 chars before the extension)
Dim fs As Scripting.FileSystemObject
Set fs = New Scripting.FileSystemObject
fs.CopyFile path & tfile, filename
Set fs = Nothing
Kill path & tfile
DoSaveDefault = True
End Function
Function fillColumnType(col As ADOX.Column, ByVal vtype As Integer, colrange As Range) As Boolean
Select Case vtype
Case vbInteger, vbLong, vbByte
col.Type = adInteger
Case vbSingle, vbDouble, vbDouble
fillColNumberType col, colrange
Case vbCurrency
col.Type = adCurrency
Case vbDate
col.Type = adDate
Case vbBoolean
col.Type = adBoolean
Case vbString
fillColStringType col, colrange
Case Else
col.Type = adWChar
col.Precision = 32
End Select
getAdoTypeFromVbType = True
End Function
Function getValByVbType(ByVal s As String, ByVal t As Integer)
Dim result As Variant
result = Null
On Error Resume Next
Select Case t
Case vbInteger, vbLong, vbByte
result = CInt(s)
Case vbSingle, vbDouble, vbCurrency, vbDecimal
If CInt(s) <> CDec(s) Then
result = CDec(s)
Else
result = CInt(s)
End If
Case vbDate
result = CDate(s)
Case vbBoolean
result = CInt(s) <> 0
Case vbString
result = s
Case Else
result = Null
End Select
On Error GoTo 0
getValByVbType = result
End Function
Function fillColStringType(col As ADOX.Column, r As Range) As Boolean
Dim lenshort As Integer
Dim lenlong As Integer
Dim l As Integer
lenshort = Len(r.Cells(2).Text)
lenlong = lenshort
For Each c In r.Cells
If c.row > 1 Then
l = Len(c.Text)
If l < lenshort Then
lenshort = l
End If
If l > lenlong Then
lenlong = l
End If
End If
Next
If lenlong > 254 Then
col.Type = adLongVarWChar
ElseIf lenlong > 128 And lenlong < 255 Then
col.Type = adWChar
col.Precision = 254
ElseIf lenshort = lenlong And lenlong < 17 Then
col.Type = adWChar
col.Precision = lenlong
Else
col.Type = adWChar
col.Precision = ceilPow2(lenlong)
End If
fillColStringType = True
End Function
Function fillColNumberType(col As ADOX.Column, r As Range) As Boolean
Dim hasDecimal As Boolean
Dim t As Boolean
hasDecimal = False
On Error Resume Next
For Each c In r.Cells
If c.row > 1 Then
t = val(c.Text) <> Int(val(c.Text))
If Err.Number = 0 And t Then
hasDecimal = True
Exit For
End If
End If
Next
On Error GoTo 0
If hasDecimal Then
col.Type = adNumeric
col.Precision = 11
col.NumericScale = 4
Else
col.Type = adInteger
End If
fillColNumberType = True
End Function
Function ceilPow2(x As Integer)
Dim i As Integer
i = 2
Do While i < x
i = i * 2
Loop
ceilPow2 = i
End Function