Hi Vabs
Following is the code:
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
On Sat, Feb 7, 2015 at 9:29 PM, Vaibhav Joshi <v...@vabs.in> wrote:
> Hi
>
> pl send code to test on, also what is your MS office version?
>
> On Thu, Feb 5, 2015 at 2:07 PM, Pravin Gunjal <isk1...@gmail.com> wrote:
>
>> Hi
>>
>> I tried this one and un-ticked MISSING from libraries and tried to Save
>> As the file with existing.
>> Then it says: The file is already exists. Do you want to replace with
>> existing file?
>> When I click on Yes it again says: Unable to remove existing file......
>>
>> Kindly look in to this please.
>>
>> Thanks,
>> Pravin Gunjal.
>>
>>
>> On Tuesday, February 3, 2015 at 9:45:31 PM UTC+5:30, Paul Schreiner wrote:
>>
>>> That usually is a problem with "References".
>>>
>>> try these steps:
>>>
>>> Stop execution of macro
>>> in VB Editor, select Tools-> References...
>>>
>>> you'll find several libraries selected.
>>> But you might see one that says "Missing" (or something like that).
>>>
>>> The problem is that once the compiler hits this missing library, it
>>> stops looking at the others.
>>>
>>> The string manipulation functions like Left() and Right() are in one of
>>> the object libraries and are not being found.
>>>
>>> You won't need all of the ones I have but the references I have selected
>>> in Excel 2010 are:
>>>
>>> Visual Basic for Applications
>>> Microsoft Excel 14.0 Object Library
>>> OLE Automation
>>> Microsoft Office 14.0 Object Library
>>> Microsoft Word 14.0 Object Library
>>> Microsoft Forms 2.0 Object LIbrary
>>>
>>>
>>>
>>> *Paul*
>>> -----------------------------------------
>>>
>>>
>>>
>>>
>>>
>>>
>>>
>>> *"Do all the good you can,By all the means you can,In all the ways you
>>> can,In all the places you can,At all the times you can,To all the people
>>> you can,As long as ever you can." - John Wesley*
>>> -----------------------------------------
>>>
>>> *From:* Pravin Gunjal <isk...@gmail.com>
>>> *To:* Excel Macros <excel-...@googlegroups.com>
>>> *Sent:* Tuesday, February 3, 2015 8:33 AM
>>> *Subject:* $$Excel-Macros$$ Error on saving the DBF file in Excel 2007
>>>
>>> Hi
>>>
>>> I have downloaded the DBF save add-in but while saving got the attached
>>> error in VB.
>>> Could anyone please check and update me on this issue.
>>>
>>> Thank you
>>> Pravin Gunjal
>>> --
>>> Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be?
>>> It's =TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
>>> https://www.facebook.com/discussexcel
>>>
>>> FORUM RULES
>>>
>>> 1) Use concise, accurate thread titles. Poor thread titles, like Please
>>> Help, Urgent, Need Help, Formula Problem, Code Problem, and Need Advice
>>> will not get quick attention or may not be answered.
>>> 2) Don't post a question in the thread of another member.
>>> 3) Don't post questions regarding breaking or bypassing any security
>>> measure.
>>> 4) Acknowledge the responses you receive, good or bad.
>>> 5) Jobs posting is not allowed.
>>> 6) Sharing copyrighted material and their links is not allowed.
>>>
>>> NOTE : Don't ever post confidential data in a workbook. Forum owners and
>>> members are not responsible for any loss.
>>> ---
>>> You received this message because you are subscribed to the Google
>>> Groups "MS EXCEL AND VBA MACROS" group.
>>> To unsubscribe from this group and stop receiving emails from it, send
>>> an email to excel-macros...@googlegroups.com.
>>> To post to this group, send email to excel-...@googlegroups.com.
>>> Visit this group at http://groups.google.com/group/excel-macros.
>>> For more options, visit https://groups.google.com/d/optout.
>>>
>>>
>>> --
>> Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It's
>> =TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
>> https://www.facebook.com/discussexcel
>>
>> FORUM RULES
>>
>> 1) Use concise, accurate thread titles. Poor thread titles, like Please
>> Help, Urgent, Need Help, Formula Problem, Code Problem, and Need Advice
>> will not get quick attention or may not be answered.
>> 2) Don't post a question in the thread of another member.
>> 3) Don't post questions regarding breaking or bypassing any security
>> measure.
>> 4) Acknowledge the responses you receive, good or bad.
>> 5) Jobs posting is not allowed.
>> 6) Sharing copyrighted material and their links is not allowed.
>>
>> NOTE : Don't ever post confidential data in a workbook. Forum owners and
>> members are not responsible for any loss.
>> ---
>> You received this message because you are subscribed to the Google Groups
>> "MS EXCEL AND VBA MACROS" group.
>> To unsubscribe from this group and stop receiving emails from it, send an
>> email to excel-macros+unsubscr...@googlegroups.com.
>> To post to this group, send email to excel-macros@googlegroups.com.
>> Visit this group at http://groups.google.com/group/excel-macros.
>> For more options, visit https://groups.google.com/d/optout.
>>
>
> --
> Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It's
> =TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
> https://www.facebook.com/discussexcel
>
> FORUM RULES
>
> 1) Use concise, accurate thread titles. Poor thread titles, like Please
> Help, Urgent, Need Help, Formula Problem, Code Problem, and Need Advice
> will not get quick attention or may not be answered.
> 2) Don't post a question in the thread of another member.
> 3) Don't post questions regarding breaking or bypassing any security
> measure.
> 4) Acknowledge the responses you receive, good or bad.
> 5) Jobs posting is not allowed.
> 6) Sharing copyrighted material and their links is not allowed.
>
> NOTE : Don't ever post confidential data in a workbook. Forum owners and
> members are not responsible for any loss.
> ---
> You received this message because you are subscribed to a topic in the
> Google Groups "MS EXCEL AND VBA MACROS" group.
> To unsubscribe from this topic, visit
> https://groups.google.com/d/topic/excel-macros/TUr-dtEShQg/unsubscribe.
> To unsubscribe from this group and all its topics, send an email to
> excel-macros+unsubscr...@googlegroups.com.
> To post to this group, send email to excel-macros@googlegroups.com.
> Visit this group at http://groups.google.com/group/excel-macros.
> For more options, visit https://groups.google.com/d/optout.
>
--
Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It’s
=TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to excel-macros+unsubscr...@googlegroups.com.
To post to this group, send email to excel-macros@googlegroups.com.
Visit this group at http://groups.google.com/group/excel-macros.
For more options, visit https://groups.google.com/d/optout.
