none
Excel VBA - Automatically save dbf (overwrite, etc) with FileFilter RRS feed

  • Question

  • I found this VBA (see below), which opens a save as prompt in the .dbf format, however, what I would like is this...

    When I run the code, I want the code to automatically save the spreadsheet over itself in a pre-specified path (it will already have a file name and the path would be embedded in the vba) and save as a .dbf file with NO further user interaction (no "SAVE AS" prompt).  Is this possible to do with .dbf?

    -----------------------------------------------------

    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

    Monday, July 29, 2013 8:33 PM

Answers

  • Sub MySaveDbf() Dim filename As Variant Dim temp As Variant Dim currentFile As String Dim defaultFile As String '******************** 'Added below portion Dim sPath As String sPath = "G:" 'Remember to set the path.I used G drive as sample 'Added above portion currentFile = ActiveWorkbook.Name temp = Split(currentFile, ".") temp(UBound(temp)) = "dbf" defaultFile = Join(temp, ".") If defaultFile = "dbf" Then defaultFile = ActiveWorkbook.Name & ".dbf" End If '******************** 'Changed below portion filename = sPath & "\" & defaultFile 'Changed above portion If filename = False Then Exit Sub Call DoSaveDefault(filename) End Sub

    Only changed the function savedbf and used as sub.As it was called from context menu function can do the conversion to dbf.But otherwise by design Function can't change any userinterface.

    I have converted it to SUB so that you can directly use from Macro and clearly identified where I had customized for you. You only need to call the above sub.

    I am grateful to you for sharing these nice code.And I salute the creator of this code.


    Best Regards,
    Asadulla Javed, Kolkata
    ---------------------------------------------------------------------------------------------
    Please do not forget to click “Vote as Helpful” if any post helps you and "Mark as Answer”if it solves the issue.


    Wednesday, August 7, 2013 3:22 PM
    Answerer

All replies

  • See if below helps:

    Sub savedbf()
         
         Dim sFileNameOnly As String
         Dim sFileName As String
         Dim sPath As String
         
         Dim Temp As Variant
         
         'set the path here.I used the present path.
         'It can be promopted to user by GetSaveAsFilename or
         'Application.FileDialogs method.for details pls
         'refer object browser of VBE
         'Or you can provide a fixed path like C:\Picture\DBF
         
         sPath = ActiveWorkbook.Path
         sFileName = ActiveWorkbook.Name
         sFileNameOnly = Left(sFileName, InStr(sFileName, ".") - 1)
              
         ActiveWorkbook.SaveAs filename:=sPath _
           & "\" & sFileNameOnly,FileFormat:=xlDbf2
     
     End Sub


    Best Regards,
    Asadulla Javed, Kolkata
    ---------------------------------------------------------------------------------------------
    Please do not forget to click “Vote as Helpful” if any post helps you and "Mark as Answer”if it solves the issue.


    Tuesday, July 30, 2013 9:33 AM
    Answerer
  • Thank you for the reply!

    I placed the code you provided into a new module and ran it.  I received the following error:

    Run-time error '1004':

    Method 'SaveAs' of object'_Workbook' failed

    When I choose "Debug", it highlights these lines of code:

         ActiveWorkbook.SaveAs filename:=sPath _
           & "\" & sFileNameOnly, FileFormat:=xlDBF2

    I believe DBF is not a standard format with this version of Excel (2007).  I had to add it in via this Add-In:

    SaveDBFIV.xlam

    Might this be related to the error?


    • Edited by Drivium Tuesday, July 30, 2013 2:35 PM Added excel version
    Tuesday, July 30, 2013 2:25 PM
  • I think you are correct. I tested with a diff format.

    Hope the add-in helps


    Best Regards,
    Asadulla Javed, Kolkata
    ---------------------------------------------------------------------------------------------
    Please do not forget to click “Vote as Helpful” if any post helps you and "Mark as Answer”if it solves the issue.

    Tuesday, July 30, 2013 3:12 PM
    Answerer
  • So, is there no way to accomplish this, then?  I can't say for certain the add in is causing the error, just throwing that out there.  Any idea why this error might be occuring and is there a way to make your code work for my purpose?

    thx

    Tuesday, July 30, 2013 3:26 PM
  • 1.This fileformat not supported in Office 2007 onwards.You can install pre-2007 office version and convert to dbf

    2.Another option is search internet and download some add-in (Maybe woth some price)

    3.Not sure but if you can install the VFoxPro in pc then you can open  dbf file in VFP and later convert to other format (csv/txt ...)

    My code will help you convert to any file format.But you need to get is supported by Office package first.


    Best Regards,
    Asadulla Javed, Kolkata
    ---------------------------------------------------------------------------------------------
    Please do not forget to click “Vote as Helpful” if any post helps you and "Mark as Answer”if it solves the issue.

    Wednesday, July 31, 2013 6:08 AM
    Answerer
  • I have the add-in installed.  I can save as .DBF through the context menus, but I don't know how to do it programmatically (through VBA). 
    Thursday, August 1, 2013 4:57 PM
  • If it is possible by context menu then some routine is there.

    But it depends on the creator of the add-in: if he has exposed as class or just calling a routine.Check in object browser & references if any library/object exposed.


    Best Regards,
    Asadulla Javed, Kolkata
    ---------------------------------------------------------------------------------------------
    Please do not forget to click “Vote as Helpful” if any post helps you and "Mark as Answer”if it solves the issue.

    Friday, August 2, 2013 7:37 AM
    Answerer
  • This is the code that the add-in adds:

    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
    Is there any way to tweak any portion of this to accomplish what I want?  thx
    Tuesday, August 6, 2013 10:53 PM
  • Sub MySaveDbf() Dim filename As Variant Dim temp As Variant Dim currentFile As String Dim defaultFile As String '******************** 'Added below portion Dim sPath As String sPath = "G:" 'Remember to set the path.I used G drive as sample 'Added above portion currentFile = ActiveWorkbook.Name temp = Split(currentFile, ".") temp(UBound(temp)) = "dbf" defaultFile = Join(temp, ".") If defaultFile = "dbf" Then defaultFile = ActiveWorkbook.Name & ".dbf" End If '******************** 'Changed below portion filename = sPath & "\" & defaultFile 'Changed above portion If filename = False Then Exit Sub Call DoSaveDefault(filename) End Sub

    Only changed the function savedbf and used as sub.As it was called from context menu function can do the conversion to dbf.But otherwise by design Function can't change any userinterface.

    I have converted it to SUB so that you can directly use from Macro and clearly identified where I had customized for you. You only need to call the above sub.

    I am grateful to you for sharing these nice code.And I salute the creator of this code.


    Best Regards,
    Asadulla Javed, Kolkata
    ---------------------------------------------------------------------------------------------
    Please do not forget to click “Vote as Helpful” if any post helps you and "Mark as Answer”if it solves the issue.


    Wednesday, August 7, 2013 3:22 PM
    Answerer
  • It works!  Thank you!

    The only thing is it's not keeping the filename correct.  For example, I had an excel spreadsheet named "ArcMAPXY.xlsm" and when I ran the macro, it named the file  as "APXY_dbf.dbf" - which is weird!  It added an undercore and the extension to the file name.

    I'm just happy that it's working.  Thanks again.

    Just tried again and it's working...I must have messed something up...  working now

    Thank you!!

    • Edited by Drivium Thursday, August 8, 2013 4:18 PM
    Wednesday, August 7, 2013 8:45 PM
  • Hello folks,

    I tried your macro Under Office 365 and I had this error:

    'Type defini par l'utilisateur non defini'

    I could translate by

    'User-defined type not defined'

    On line:

    Function fillColumnType(col As ADOX.Column, ByVal vtype As Integer, colrange As Range) As Boolean

    Thank you for answers

    -------

    Michel, France

    • Edited by Mic94 Friday, November 15, 2013 9:26 AM
    Friday, November 15, 2013 9:25 AM
  • hi im a newbie and want to use macro to save my microsoft excell to .dbf files. can you help me thanks
    you can email me at jvs_pkmn@yahoo.com I totally have no idea on how to use it. maybe you can help me how to enter this code. thanks in advance
    Monday, October 17, 2016 1:05 PM
  • Not sure OP will check this thread. Try posting a new thread. The above code uses certain Add-in which does the job.

    Best Regards,
    Asadulla Javed,
    Jadavpore & Asansol

    Monday, October 17, 2016 2:43 PM
    Answerer