Hi there,

this code (VBA, Access XP, should run on Access 2003 too) imports a shapefile to an Access-table, using 'serializetostring' for the geometry.
It also imports all fields.
It was a bit tricky because the 'field.type' only recognizes 'string', 'integer' and 'double' (as mentioned in the documentation). It also recognizes 'boolean'....

So maybe someone has use for this....

Comments and suggestions are welcome!

Option Compare Database
Option Explicit

Private Sub cmd_Load_Click()

    Dim sf As New MapWinGIS.Shapefile
    Dim tb As New MapWinGIS.Table
    Dim NewTable As TableDef
    Dim i As Long, x As Long
    Dim rs As DAO.Recordset
    Dim success As Boolean
    Dim delTable As Boolean
    Dim tblfields As Object
    Dim fldType As FieldType
    Dim NewTableName As String
    Dim f
    Dim fs As Object
    Dim oFileDialog As FileDialog
    Dim shpFileName As String
    Dim dbfFileName
    
'Selecting a File
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    
    Set oFileDialog = Application.FileDialog(msoFileDialogFilePicker)
    oFileDialog.Filters.Add "All files", "*.*" 'adding a filter for all-files
    oFileDialog.Filters.Add "Shapefile", "*.shp", 1 'adding a filter for *.shp
    oFileDialog.InitialFileName = Application.CurrentProject.Path 'start in the actual folder
    
    With oFileDialog
        .Title = "Select Shapefile to load"
        .ButtonName = "Select"
        .AllowMultiSelect = False
        If .Show = True Then
            Dim vItem As Variant
            For Each vItem In .SelectedItems
                shpFileName = vItem 'this is the complete paht of the selected shapefile
                Set f = fs.GetFile(vItem)
                If Left(f.Type, 3) <> "SHP" Then 'checking filetype to assure its a shapefile (just very basic)
                    MsgBox "This seems to be no Shapefile!", vbExclamation, "Exiting!"
                    Exit Sub
                End If
                dbfFileName = Left(shpFileName, (Len(shpFileName) - 4)) & ".dbf" 'setting the name of corresponding *.dbf
            Next
            
        End If
    End With
    If LenB(shpFileName) = 0 Then 'if nothing is selected exit
        MsgBox "No File selected", vbExclamation, "Exiting!"
        Exit Sub
    End If
    
    NewTableName = InputBox("Please enter a table name:", "New Tablenname", Left(f.Name, (Len(f.Name) - 4))) ' enter the name of the new table
    delTable = False 'setting the tag for deletion of existing table
    For i = 0 To CurrentDb.TableDefs.Count - 1
        If CurrentDb.TableDefs(i).Name = NewTableName Then 'check if the table already exist and ask user what to do
            Select Case MsgBox("A table with the given name (" & NewTableName & ") already exists in this database!" _
                               & vbCrLf & "Replace?" _
                               , vbYesNo Or vbExclamation Or vbDefaultButton1, "Table exists!")
            
                Case vbYes
                    delTable = True 'if the table is to be replace set the tag correspondingly
                Case vbNo
                    Exit Sub 'stop if table isn't to be replaced
            End Select
            
        End If
    Next i
    
    If delTable Then 'if tag is set to replace, delete table
        DoCmd.DeleteObject acTable, NewTableName
    End If
            
    DoCmd.Hourglass True 'set the hourglass-cursor to show busy-mode...
            
    success = tb.Open(dbfFileName) 'open the dbf
    If Not success Then
        MsgBox "*.dbf can't be read! Maybe missing or disrupted!", vbCritical, "Exiting!"
        Exit Sub
    End If
    
    
    CurrentDb.CreateTableDef (NewTableName) 'create the new table
    
    Set NewTable = CurrentDb.CreateTableDef(NewTableName)

    sf.Open (shpFileName) 'open the shapefile
   
    For i = 0 To tb.NumFields - 1 'add a field to the new tabel for every field in the dbf
        
        Select Case tb.Field(i).Type 'specify the field-type by the fieldtypes in the dbf
            Case 0
                If tb.Field(i).Width > 255 Then 'if its a string and size is over 255 make a memo-field
                    fldType = dbMemo
                Else
                    fldType = dbText
                End If
                
            Case 2
                If tb.Field(i).Precision > 0 Then 'if its a number-field use presision to decide between double and integer
                    fldType = dbDouble
                Else
                    fldType = dbLong
                End If
            
            Case 3
                fldType = dbBoolean
            
            Case Else
                MsgBox "Unknown field-type!", vbCritical, "Exiting!" 'oops
                Exit Sub
        End Select
        
        AppendDeleteField NewTable, "APPEND", _
        tb.Field(i).Name, fldType, tb.Field(i).Width 'append the fields using sub appendeletefield
    
    Next i
    
        AppendDeleteField NewTable, "APPEND", _
        "mem_GEOMETRIE", dbMemo, 0 'append the field for string-geometrie, use memo-field because of length
    
    
CurrentDb.TableDefs.Append NewTable 'now really add the new table

Set rs = CurrentDb.OpenRecordset(NewTableName, dbopendynaset) 'open the new table for adding data
    
    For i = 0 To sf.NumShapes - 1 'for every shape in the shapefile add a record to the new table
        rs.AddNew
        For x = 0 To rs.Fields.Count - 1
            If LenB(tb.CellValue(x, i)) > 0 Then 'if the field in the dbf contains data, add it, else don't bother
                rs.Fields(x) = tb.CellValue(x, i)
            End If
        Next x
        rs.Fields("mem_GEOMETRIE") = sf.Shape(i).SerializeToString 'add the geometry to the geometry-field
        rs.Update
    Next
DoCmd.Hourglass False 'so were done, remove the hourglass-cursor
    
    rs.Close
    Set rs = Nothing
    tb.Close
    sf.Close
    
    
    MsgBox "Done!", vbInformation

End Sub

Sub AppendDeleteField(tdfTemp As TableDef, _
    strCommand As String, strName As String, _
    Optional varType, Optional varSize)
'This code is taken out of the Microsoft Visual Basic Help!
    With tdfTemp

        ' Check first to see if the TableDef object is
        ' updatable. If it isn't, control is passed back to
        ' the calling procedure.
        If .Updatable = False Then
            MsgBox "TableDef not Updatable! " & _
                "Unable to complete task."
            Exit Sub
        End If

        ' Depending on the passed data, append or delete a
        ' field to the Fields collection of the specified
        ' TableDef object.
        If strCommand = "APPEND" Then
            .Fields.Append .CreateField(strName, _
                varType, varSize)
        Else
            If strCommand = "DELETE" Then .Fields.Delete _
                strName
        End If

    End With

End Sub

Sincerely
fredericus

Thanks Fredericus,

The code looks great.
Thanks for sharing.

Paul

--
Don't forget to read the new documentation: www.mapwindow.org/documentation/mapwingis4.8
Join us Google+: MapWindow GIS Google+ Community
Join the MapWindow Group on LinkedIn! LinkedIn - MapWindow Group

Download the latest beta installer at:
tinyurl.com/mwMonthly 32-Bit
tinyurl.com/mwMonthlyx64 64-Bit
Follow me on Twitter MapWindow_nl to read when a new installer is published.

---
Paul Meems
The Netherlands
[www.bontepaarden.nl]
Release manager, configuration manager and
forum moderator of MapWindow GIS

Owner of MapWindow.nl - Support for
Dutch speaking users: www.mapwindow.nl

*******
Everything I say or write is my personal opinion and
not the opinion of the company I work for.
*******
View my profile on LinkedIn