Hi Vabs
Any updates on this please.
Regards
Pravin Gunjal
On Wednesday, February 11, 2015 at 5:00:32 PM UTC+5:30, Pravin Gunjal wrote:
>
> 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)
> ...
--
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.
