Complex Issue-Shape Identification

1

Hello. I have a rather complex issue. When trying to identify a shape, I am not receiving any information for some layers. This only happens with a certain number of layers. Most work fine, but a few don’t. There are 28 shapefiles (layers) with a total of roughly 5000 shapes. Shapes per shapefile/layer range from 2 to 300. This issue arises from a Form_Load event in Access. My code is below. I can’t figure it out! Thank you for reading through this far!!!

Private Sub Form_Load()
On Error GoTo errhandler
Me.Map0.Clear
Application.Echo (False)
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE Master Set [Layer] = null"
DoCmd.RunSQL "UPDATE Master Set [shapeno] = null"
DoCmd.RunSQL "UPDATE jobstable Set [Layer] = null"
DoCmd.RunSQL "UPDATE jobstable Set [shapeno] = null"

DoCmd.SetWarnings True
DoCmd.OpenForm "Main"
Me.Visible = False
Me.Map0.SendSelectBoxFinal = True
Dim mydb As DAO.Database
Set mydb = CurrentDb
Dim gs As GlobalSettings
Set gs = New GlobalSettings
gs.AllowProjectionMismatch = True
gs.ReprojectLayersOnAdding = True
Me.Map0.Projection = tkMapProjection.PROJECTION_GOOGLE_MERCATOR
Me.Map0.TileProvider = tkTileProvider.OpenStreetMap
Me.Map0.KnownExtents = tkKnownExtents.keUSA
Me.Map0.CursorMode = cmPan

Dim sf As New Shapefile
Dim gp As GeoProjection
Set gp = Me.Map0.GeoProjection
Dim index As Integer
Dim lyr As Integer
Dim tx As Integer
Dim lat As Double
Dim lng As Double
Dim utill As MapWinGIS.utils
Set utill = New utils
Dim tff As New GeoProjection
Dim tf As New GeoProjection
Dim y As Integer
Dim shp() As New MapWinGIS.shape
Dim jbs() As String
For Each ctrl In Me.Controls
If TypeName(ctrl) = "Checkbox" Then
ctrl.value = -1
End If
Next
Dim i As Long
'//////////////build job status arrays////////////////////
Dim bidjobs() As String
Dim contractjobs() As String
Dim closedwin() As String
Dim closedloss() As String
Dim jsa As DAO.Recordset
Set jsa = mydb.OpenRecordset("jobstable")
Dim mx As Integer
mx = DMax("[ID]", "jobstable")
Dim t As Integer
Dim x As Integer
'//////////////////% calc////////////////////
'ttjobs = DCount("[ID]", "jobstable")
'ttsubs = DCount("[ID]", "Master", "[lat] > '" & 1 & "'")
'ttall = ttjobs + ttsubs
'//////////////////% calc////////////////////
Forms!Main.Label10.Caption = "Loading Jobs..."
Forms!Main.Repaint
Forms!Main.Refresh
DoEvents

stss = "Bid"
i = 0
t = 0
x = 0
ab:
ReDim Preserve bidjobs(i)
If DLookup("[Status]", "jobstable", "[ID] = " & t & " AND [Status] = '" & stss & "'") = stss Then
bidjobs(i) = t
i = i + 1
End If
t = t + 1
If t > mx Then GoTo nb
GoTo ab
nb:
'//

'//
stss = "Contract"
i = 0
t = 0
abb:
ReDim Preserve contractjobs(i)
If DLookup("[Status]", "jobstable", "[ID] = " & t & " AND [Status] = '" & stss & "'") = stss Then
contractjobs(i) = t
i = i + 1
End If
t = t + 1
If t > mx Then GoTo nbb
GoTo abb
nbb:
'//

'//
stss = "Closed-Win"
i = 0
t = 0
abbb:
ReDim Preserve closedwin(i)
If DLookup("[Status]", "jobstable", "[ID] = " & t & " AND [Status] = '" & stss & "'") = stss Then
closedwin(i) = t
i = i + 1
End If
t = t + 1
If t > mx Then GoTo nbbb
GoTo abbb
nbbb:
'//

'//
stss = "Closed-Loss"
i = 0
t = 0
abbbb:
ReDim Preserve closedloss(i)
If DLookup("[Status]", "jobstable", "[ID] = " & t & " AND [Status] = '" & stss & "'") = stss Then
closedloss(i) = t
i = i + 1
End If
t = t + 1
If t > mx Then GoTo nbbbb
GoTo abbbb
nbbbb:
'//



'//////////////end build job status arrays////////////////////

'////////////////////////bid jobs ////////////////////////

On Error Resume Next
Dim sts As String
sts = "Bid"

Dim sff As New Shapefile
With Me.Map0
       shape = sff.CreateNew("", ShpfileType.SHP_POINT)
    lyr = Me.Map0.AddLayer(sff, True)

For S = LBound(bidjobs) To UBound(bidjobs)
x = bidjobs(S)

sff.DefaultDrawingOptions.SetDefaultPointSymbol (tkDefaultPointSymbol.dpsStar)
sff.DefaultDrawingOptions.PointSize = 10
sff.DefaultDrawingOptions.FillType = ftStandard

ReDim Preserve shp(x)
If IsNull(DLookup("[Latitude]", "jobstable", "[ID] = " & x)) Or IsNull(DLookup("[Longitude]", "jobstable", "[ID] = " & x)) Then GoTo ggg
lat = DLookup("[Latitude]", "jobstable", "[ID] = " & x)
lng = DLookup("[Longitude]", "jobstable", "[ID] = " & x)
    
sff.DefaultDrawingOptions.FillColor = utill.ColorByName(Red)
        sff.Selectable = True
    sff.Identifiable = True
shp(x).Create (ShpfileType.SHP_POINT)

tff.SetWellKnownGeogCS (tkCoordinateSystem.csWGS_84) ' DMS
        tff.StartTransform (Me.Map0.GeoProjection)  ' target is the maps geoprojection
        tx = tff.Transform(lng, lat)
        tff.StopTransform

index = shp(x).AddPoint(lng, lat)
index = sff.EditAddShape(shp(x))


    DoCmd.SetWarnings False
    For Each tdf In mydb.TableDefs


    If tdf.name = "jobstable" Then
strSQL = "UPDATE jobstable Set " & "[shapeno] = " & S & ", [Layer] = " & lyr & _
                " Where [Job Number] = '" & DLookup("[Job Number]", "jobstable", "[ID] = " & x) & "';"
          
           DoCmd.RunSQL strSQL
    End If
    Next
DoCmd.SetWarnings True
'i = i + 1
ggg:
Next
End With
'////////////////////////bid jobs end////////////////////////
'////////////////////////contract jobs ////////////////////////
cj:

    S = Nothing
    shape = Nothing
    shp(x) = Nothing
If IsNull(contractjobs) Then GoTo cw
Dim Utilc As MapWinGIS.utils
Set Utilc = New utils
'On Error Resume Next
sts = "Contract"

Dim sfc As New Shapefile
With Me.Map0
       shape = sfc.CreateNew("", ShpfileType.SHP_POINT)
       lyr = Forms!Map.Map0.AddLayer(sfc, True)


For S = LBound(contractjobs) To UBound(contractjobs) - 1
x = contractjobs(S)

sfc.DefaultDrawingOptions.SetDefaultPointSymbol (tkDefaultPointSymbol.dpsStar)
sfc.DefaultDrawingOptions.PointSize = 10
sfc.DefaultDrawingOptions.FillType = ftStandard

ReDim Preserve shp(x)
If IsNull(DLookup("[Latitude]", "jobstable", "[ID] = " & x)) Or IsNull(DLookup("[Longitude]", "jobstable", "[ID] = " & x)) Then GoTo gc
lat = DLookup("[Latitude]", "jobstable", "[ID] = " & x)
lng = DLookup("[Longitude]", "jobstable", "[ID] = " & x)
    
sfc.DefaultDrawingOptions.FillColor = Utilc.ColorByName(Orange)
        sfc.Selectable = True
    sfc.Identifiable = True

       
shp(x).Create (ShpfileType.SHP_POINT)

tff.SetWellKnownGeogCS (tkCoordinateSystem.csWGS_84) ' DMS
        tff.StartTransform (Me.Map0.GeoProjection)  ' target is the maps geoprojection
        tx = tff.Transform(lng, lat)
        tff.StopTransform

index = shp(x).AddPoint(lng, lat)
index = sfc.EditAddShape(shp(x))

  sfc.Selectable = True
    sfc.Identifiable = True

    DoCmd.SetWarnings False
    For Each tdf In mydb.TableDefs

    If tdf.name = "jobstable" Then
strSQL = "UPDATE jobstable Set " & "[shapeno] = " & S & ", [Layer] = " & lyr & _
                " Where [Job Number] = '" & DLookup("[Job Number]", "jobstable", "[ID] = " & x) & "';"
            
           DoCmd.RunSQL strSQL
    End If
    Next
DoCmd.SetWarnings True
gc:
Next
End With
'////////////////////////contract jobs end////////////////////////
'////////////////////////Closed-Win jobs ////////////////////////
cw:
    S = Nothing
    shape = Nothing
    shp(x) = Nothing
If IsNull(closedwin) Then GoTo cl
Dim Utilcw As MapWinGIS.utils
Set Utilcw = New utils
'On Error Resume Next
sts = "Closed-Win"

Dim sfcw As New Shapefile
With Me.Map0
       shape = sfcw.CreateNew("", ShpfileType.SHP_POINT)
       lyr = Forms!Map.Map0.AddLayer(sfcw, True)

For S = LBound(closedwin) To UBound(closedwin) - 1
x = closedwin(S)

sfcw.DefaultDrawingOptions.SetDefaultPointSymbol (tkDefaultPointSymbol.dpsStar)
sfcw.DefaultDrawingOptions.PointSize = 10
sfcw.DefaultDrawingOptions.FillType = ftStandard

ReDim Preserve shp(x)
If IsNull(DLookup("[Latitude]", "jobstable", "[ID] = " & x)) Or IsNull(DLookup("[Longitude]", "jobstable", "[ID] = " & x)) Then GoTo gcl
lat = DLookup("[Latitude]", "jobstable", "[ID] = " & x)
lng = DLookup("[Longitude]", "jobstable", "[ID] = " & x)
    
sfcw.DefaultDrawingOptions.FillColor = Utilcw.ColorByName(DarkOrchid)
        sfcw.Selectable = True
    sfcw.Identifiable = True
shp(x).Create (ShpfileType.SHP_POINT)

tff.SetWellKnownGeogCS (tkCoordinateSystem.csWGS_84)
        tff.StartTransform (Me.Map0.GeoProjection)
        tx = tff.Transform(lng, lat)
        tff.StopTransform

index = shp(x).AddPoint(lng, lat)
index = sfcw.EditAddShape(shp(x))

  sfcw.Selectable = True
    sfcw.Identifiable = True

    DoCmd.SetWarnings False
    For Each tdf In mydb.TableDefs

    If tdf.name = "jobstable" Then
strSQL = "UPDATE jobstable Set " & "[shapeno] = " & S & ", [Layer] = " & lyr & _
                " Where [Job Number] = '" & DLookup("[Job Number]", "jobstable", "[ID] = " & x) & "';"
           
           DoCmd.RunSQL strSQL
    End If
    Next
DoCmd.SetWarnings True
gcl:
Next
End With
'////////////////////////Closed-Win jobs end////////////////////////
'////////////////////////Closed-Loss jobs ////////////////////////
cl:
    S = Nothing
    shape = Nothing
    shp(x) = Nothing
If IsNull(closedloss) Then GoTo subcons
Dim utilcl As MapWinGIS.utils
Set utilcl = New utils
'On Error Resume Next
sts = "Closed-Loss"

Dim sfcl As New Shapefile
With Me.Map0
       shape = sfcl.CreateNew("", ShpfileType.SHP_POINT)
       lyr = Forms!Map.Map0.AddLayer(sfcl, True)

For S = LBound(closedloss) To UBound(closedloss) - 1
x = closedloss(S)

sfcl.DefaultDrawingOptions.SetDefaultPointSymbol (tkDefaultPointSymbol.dpsStar)
sfcl.DefaultDrawingOptions.PointSize = 10
sfcl.DefaultDrawingOptions.FillType = ftStandard

ReDim Preserve shp(x)
If IsNull(DLookup("[Latitude]", "jobstable", "[ID] = " & x)) Or IsNull(DLookup("[Longitude]", "jobstable", "[ID] = " & x)) Then GoTo gcf
lat = DLookup("[Latitude]", "jobstable", "[ID] = " & x)
lng = DLookup("[Longitude]", "jobstable", "[ID] = " & x)
    
sfcl.DefaultDrawingOptions.FillColor = utilcl.ColorByName(LightGray)
        sfcl.Selectable = True
    sfcl.Identifiable = True

       
shp(x).Create (ShpfileType.SHP_POINT)

tff.SetWellKnownGeogCS (tkCoordinateSystem.csWGS_84)
        tff.StartTransform (Me.Map0.GeoProjection)
        tx = tff.Transform(lng, lat)
        tff.StopTransform

index = shp(x).AddPoint(lng, lat)
index = sfcl.EditAddShape(shp(x))

  sfcl.Selectable = True
    sfcl.Identifiable = True

    DoCmd.SetWarnings False
    For Each tdf In mydb.TableDefs

    If tdf.name = "jobstable" Then
strSQL = "UPDATE jobstable Set " & "[shapeno] = " & S & ", [Layer] = " & lyr & _
                " Where [Job Number] = '" & DLookup("[Job Number]", "jobstable", "[ID] = " & x) & "';"
      
           DoCmd.RunSQL strSQL
    End If
    Next
DoCmd.SetWarnings True
gcf:
Next
End With
'\\\\\\\\\\\\\\\\\\\\\\\\\\Closed-Loss jobs end\\\\\\\\\\\\\\\\\\\\\\\\\\
subcons:

'On Error Resume Next
'///////////////////////Subcontractors///////////////////////////////
'Build sub array*************************************************************************************************************

lyrlkup = 0
Dim ddivv() As String
Dim lyrclr As String
mxdiv = DCount("[ID]", "CSI Divisions")
aaaa:

lyrlkup = lyrlkup + 1

If lyrlkup > mxdiv Then GoTo feats
stss = DLookup("[Description]", "CSI Divisions", "[Lyrlookup] = " & lyrlkup)

mx = DMax("[ID]", "Master", "[CSI Division] = '" & stss & "'")
mnn = DMin("[ID]", "Master", "[CSI Division] = '" & stss & "'")
i = 0
t = mnn
bbbb:
ReDim Preserve ddivv(i)
If DLookup("[CSI Division]", "Master", "[ID] = " & t & " AND [CSI Division] = '" & stss & "'") = stss Then
ddivv(i) = t
i = i + 1
End If
t = t + 1
If t > mx Then GoTo cccc
GoTo bbbb
cccc:
GoSub mapsubs
GoTo aaaa

'Map Subcontractors************************************************************************************************************
mapsubs:

Set sf = Nothing
Set shape = Nothing
Set shp(x) = Nothing
Dim sfsub As Integer
cnt = 0
'lyrclr = DLookup("[LayerColor]", "CSI Divisions", "[Lyrlookup] = " & lyrlkup)
divi = DLookup("[Description]", "CSI Divisions", "[Lyrlookup] = " & lyrlkup)
z = DCount("[CSI Division]", "Master", "[CSI Division] = '" & divi & "'")

If z = 0 Then Return
If DLookup("[Description]", "CSI Divisions", "[Lyrlookup] = " & lyrlkup) = "none" Then Return


sfsub = DCount("[ID]", "Status") + DLookup("Lyrlookup", "CSI Divisions", "[Description] = '" & divi & "'") - 2
Debug.Print "Division = " & divi & " .  lyrlkup = " & lyrlkup & ". Maplayer = " & sfsub
Set sf = Forms!Map.Map0.Shapefile(sfsub)
sf.Identifiable = True
sf.Selectable = True
With Me.Map0
       shape = sf.CreateNew("", ShpfileType.SHP_POINT)
       lyr = Me.Map0.AddLayer(sf, True)
For S = LBound(ddivv) To UBound(ddivv) - 1
x = ddivv(S)
ReDim Preserve shp(x)
If IsNull(DLookup("[lat]", "Master", "[ID] = " & x)) Or IsNull(DLookup("[lng]", "Master", "[ID] = " & x)) Then GoTo divx
lat = DLookup("[lat]", "Master", "[ID] = " & x)
lng = DLookup("[lng]", "Master", "[ID] = " & x)
        tf.SetWellKnownGeogCS (tkCoordinateSystem.csWGS_84)
        tf.StartTransform (Me.Map0.GeoProjection)
        tx = tf.Transform(lng, lat)
        tf.StopTransform
sf.DefaultDrawingOptions.FillColor = utill.ColorByName(Blue)
sf.Identifiable = True
sf.Selectable = True
        shp(x).Create (ShpfileType.SHP_POINT)
       index = shp(x).AddPoint(lng, lat)
       index = sf.EditAddShape(shp(x))
       sf.Selectable = True
       sf.SelectionColor = vbGreen
DoCmd.SetWarnings False
    For Each tdf In mydb.TableDefs
    If tdf.name = "Master" Then
strSQL = "UPDATE Master Set " & "shapeno = " & cnt & _
                " Where Subcontractor = '" & DLookup("[Subcontractor]", "Master", "[ID] = " & x) & "';"
           DoCmd.RunSQL strSQL
    End If
    Next

    For Each tdf In mydb.TableDefs

    If tdf.name = "Master" Then
strSQL = "UPDATE Master Set " & "Layer = " & sfsub & _
                " Where Subcontractor = '" & DLookup("[Subcontractor]", "Master", "[ID] = " & x) & "';"
           DoCmd.RunSQL strSQL
    End If
    Next
DoCmd.SetWarnings True
cnt = cnt + 1
divx:
Next

End With

If lyrlkup > mxdiv Then GoTo feats
Forms!Main.Label10.Caption = "Loading " & divi & " Subcontractors..."
Forms!Main.Repaint
Forms!Main.Refresh
DoEvents
GoTo aaaa

'\\\\\\\\\\\\\\\\\\\\\\\\end Subcontractors\\\\\\\\\\\\\\\\\\\\\\\\

feats:
'//////////////////////populate job list//////////////////////
cntrct = """Contract"""
bdd = """Bid"""
For Each SubForm In Me
For Each ctrl In SubForm.Controls
If ctrl.name = "List99" Then
   ctrl.RowSource = "SELECT [ID], [Job Number], [Job Name], [Status] From jobstable WHERE ((([Status]) In (" & cntrct & "," & bdd & "))) ORDER BY [Job Number] DESC;"
End If
Next
Next

DoCmd.Close acForm, "Main"

Me.Visible = True
Application.Echo (True)

Set sf = Nothing
Set shape = Nothing
Set shp(x) = Nothing


Exit Sub
errhandler:
MsgBox Prompt:="Fatal Error Detected" & vbNewLine & Me.name & vbNewLine & "Error" & err.Number & ": " & err.Description, Buttons:=vbCritical, Title:="Error Handler: Error" & err.Number
If Environ("username") = "mradtke" Then Exit Sub
Application.Quit

End Sub
3

I figured it out. Thanks to anyone who looked in to it!

4

@mikeradtke Would you mind telling us how you figured it out so others can use this topic as a reference?

1 Like
7

I was a away from this forum for a couple months while working on this project. Since then 10,000 shapes were added and I revamped the code. I don’t remember how I figured this one out, sorry!

1 Like