请教高人指教!!我写了一个新建图层的代码,新建图层之后,当我再打开的时候,并不能正确打开原来新建的图层,我的系统已经与自己做的数据库正确连接,而且在下面的Private Sub OKButton_Click()这个函数中,当我在系统中设置这些文本点击确定之后,我所设置的内容在数据库中并没有更新,我自己没有发现代码中的问题,请教高人指点,谢谢!!!
Private Sub mnuNew_Click()
Dim Lyr As MapXLib.Layer
Dim LyrName As String '图层名
Dim FwZL As String '房屋座落
Dim LyrLineName As String '线层名
Dim tbFn As String '图层表文件名
Dim tbFnLine As String '线层表文件名
Dim szSQL As String
Dim rs As ADODB.Recordset
Dim frm As frmSetWidthHeight
Dim LyrInfo As New MapXLib.LayerInfo
Dim flds As New MapXLib.Fields
Dim fs As Scripting.FileSystemObject
On Error GoTo ErrHandler
'设置边框及座落
Set frm = New frmSetWidthHeight
Load frm
frm.Show vbModal
If frm.IsCanceled Then
Exit Sub
End If
MAP_WIDTH = frm.MapWidth
MAP_HEIGHT = frm.MapHeight
SHORTEST_DISTANCE = MAP_WIDTH / SHORTEST_TIME
FwZL = frm.MapLocation
'----------------------------
Screen.MousePointer = 11
'-----------------------------------------------------------------------
'根据数据库的集合生成新的Layer Name
'-----------------------------------------------------------------------
'打开数据库记录集合
szSQL = "SELECT Max(LyrName) as LayerName FROM tbTable"
Set rs = New ADODB.Recordset
rs.Open szSQL, MAP_CONN, adOpenKeyset, adLockPessimistic, adCmdText
rs.MoveFirst
'generate the new layer name
If IsNull(rs("LayerName").Value) Then
LyrName = ""
Else
LyrName = CStr(rs("LayerName").Value)
End If
LyrName = GetNewLayerName(rs("LayerName"))
tbFn = TABLE_PATH & LyrName & ".tab"
LyrLineName = LyrName & "L"
tbFnLine = TABLE_PATH & LyrLineName & ".tab"
'关闭图形文件
Call CloseCurrentMap
'----------------------------
'建边框
Call SetNumreicCoordSys(MAP_WIDTH, MAP_HEIGHT)
SetMapBorder Map1, MAP_WIDTH, MAP_HEIGHT
'创建面图图层
Set fs = New Scripting.FileSystemObject
'------------------------
If fs.FileExists(tbFn) Then
fs.DeleteFile tbFn
End If
Set Lyr = Map1.Layers.CreateLayer(LyrName, tbFn, 2)
Lyr.Editable = False
Lyr.ShowNodes = True
Lyr.Selectable = False
'创建线图图层
'------------------------
If fs.FileExists(tbFnLine) Then
fs.DeleteFile (tbFnLine)
End If
Set fs = Nothing
flds.AddNumericField "DIST", 10, 2
LyrInfo.Type = miLayerInfoTypeNewTable
LyrInfo.AddParameter "FileSpec", tbFnLine
LyrInfo.AddParameter "Name", LyrLineName
LyrInfo.AddParameter "Fields", flds
Set Lyr = Map1.Layers.Add(LyrInfo, 1)
Map1.DataSets.Add miDataSetLayer, Lyr, "DISTANCE"
On Error Resume Next
Lyr.Editable = True
Lyr.ShowNodes = True
Lyr.Selectable = True
'set the current layer name
CURRENT_LAYER = LyrLineName
REGION_LAYER = LyrName
LINE_LAYER = LyrLineName
On Error GoTo ErrHandler
'在数据库里添加一条记录
MAP_CONN.Execute "INSERT INTO tbTable(LyrName,zl,width,height) " & _
" VALUES('" & REGION_LAYER & "','" & FwZL & "'," & CStr(MAP_WIDTH) & "," & CStr(MAP_HEIGHT) & ")"
'refresh the buttons
Call UpdateToolbarButtons
'close the rs
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
'--------------------
Call UpdateSystemTitle
'----------------------------------
SendKeys "{F4}"
'----------------------------------
Screen.MousePointer = 0
Exit Sub
ErrHandler:
Screen.MousePointer = 0
Map1.MousePointer = miArrowCursor
If Not fs Is Nothing Then
Set fs = Nothing
End If
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
'MsgBox "不能创建新图，可能的原因是系统日期设置不正确！", vbOKOnly + vbInformation, Me.Caption
ErrMessageBox "New", Me.Caption
End SubPrivate Sub SetMapBorder(MapX45 As Map, ByVal aWidth As Double, ByVal aHeight As Double)
Dim tbBorder As String '边框文件名
Dim LyrBorder As String '层名
Dim files As Scripting.FileSystemObject
Dim LyrInfo As New MapXLib.LayerInfo
Dim Lyr As MapXLib.Layer
Dim pts As Points
Dim f As Feature
Dim pt As Point
tbBorder = TABLE_PATH & "border.tab"
LyrBorder = "Border"
'先判断文件是否存在
Set files = New Scripting.FileSystemObject
If files.FileExists(tbBorder) Then
'删除Border图层
files.DeleteFile TABLE_PATH & "border.*"
End If
Set Lyr = Map1.Layers.CreateLayer(LyrBorder, tbBorder)
Lyr.Editable = False
Lyr.ShowNodes = False
Lyr.Selectable = False
'画边框
DrawBorder MapX45, Lyr, aWidth, aHeight
End Sub
Private Sub DrawBorder(MapX45 As Map, Lyr As MapXLib.Layer, ByVal aWidth As Double, ByVal aHeight As Double)
Dim f As New Feature
Dim fs As Features
Dim pts As New Points
Dim pt As New Point
Dim lsty As MapXLib.Style
Dim sp As Long
sp = 0.1
Set fs = Lyr.AllFeatures
'行删除Features
For Each f In fs
Lyr.DeleteFeature (f.FeatureKey)
Next
'画线
pt.Set 0, 0
pts.Add pt
pt.Set aWidth - sp, 0
pts.Add pt
f.Attach MapX45
f.Type = miFeatureTypeLine
f.Parts.Add pts
Set lsty = f.Style
lsty.LineColor = RGB(255, 0, 0)
lsty.LineStyle = 63
Lyr.AddFeature f
'-----------------
f.Parts.RemoveAll
pts.RemoveAll
pt.Set 0, 0
pts.Add pt
pt.Set 0, aHeight - sp
pts.Add pt
f.Attach MapX45
f.Type = miFeatureTypeLine
f.Parts.Add pts
Set lsty = f.Style
lsty.LineColor = RGB(255, 0, 0)
lsty.LineStyle = 63
Lyr.AddFeature f
'-----------------
f.Parts.RemoveAll
pts.RemoveAll
pt.Set aWidth - sp, 0
pts.Add pt
pt.Set aWidth - sp, aHeight - sp
pts.Add pt
f.Attach MapX45
f.Type = miFeatureTypeLine
f.Parts.Add pts
Set lsty = f.Style
lsty.LineColor = RGB(255, 0, 0)
lsty.LineStyle = 63
Lyr.AddFeature f
'---------------------------
f.Parts.RemoveAll
pts.RemoveAll
pt.Set aWidth - sp, aHeight - sp
pts.Add pt
pt.Set 0, aHeight - sp
pts.Add pt
f.Attach MapX45
f.Type = miFeatureTypeLine
f.Parts.Add pts
Set lsty = f.Style
lsty.LineColor = RGB(255, 0, 0)
lsty.LineStyle = 63
Lyr.AddFeature f
End SubPrivate Sub OKButton_Click()
Dim szSQL As String
On Error Resume Next
'save the modification
szSQL = "UPDATE tbTable SET zl='" & txtLocation.Text & "'," & _
"Bjcdw='" & txtBjcdw.Text & "'," & _
"Cly='" & txtCly.Text & "'," & _
"Hyy='" & txtHyy.Text & "'," & _
"Jzmc='" & txtJzmc.Text & "'," & _
"Memo='" & txtMemo.Text & "' " & _
"WHERE LyrName='" & REGION_LAYER & "'"
MAP_CONN.Execute szSQL
Unload Me
End Sub
Private Sub mnuNew_Click()
Dim Lyr As MapXLib.Layer
Dim LyrName As String '图层名
Dim FwZL As String '房屋座落
Dim LyrLineName As String '线层名
Dim tbFn As String '图层表文件名
Dim tbFnLine As String '线层表文件名
Dim szSQL As String
Dim rs As ADODB.Recordset
Dim frm As frmSetWidthHeight
Dim LyrInfo As New MapXLib.LayerInfo
Dim flds As New MapXLib.Fields
Dim fs As Scripting.FileSystemObject
On Error GoTo ErrHandler
'设置边框及座落
Set frm = New frmSetWidthHeight
Load frm
frm.Show vbModal
If frm.IsCanceled Then
Exit Sub
End If
MAP_WIDTH = frm.MapWidth
MAP_HEIGHT = frm.MapHeight
SHORTEST_DISTANCE = MAP_WIDTH / SHORTEST_TIME
FwZL = frm.MapLocation
'----------------------------
Screen.MousePointer = 11
'-----------------------------------------------------------------------
'根据数据库的集合生成新的Layer Name
'-----------------------------------------------------------------------
'打开数据库记录集合
szSQL = "SELECT Max(LyrName) as LayerName FROM tbTable"
Set rs = New ADODB.Recordset
rs.Open szSQL, MAP_CONN, adOpenKeyset, adLockPessimistic, adCmdText
rs.MoveFirst
'generate the new layer name
If IsNull(rs("LayerName").Value) Then
LyrName = ""
Else
LyrName = CStr(rs("LayerName").Value)
End If
LyrName = GetNewLayerName(rs("LayerName"))
tbFn = TABLE_PATH & LyrName & ".tab"
LyrLineName = LyrName & "L"
tbFnLine = TABLE_PATH & LyrLineName & ".tab"
'关闭图形文件
Call CloseCurrentMap
'----------------------------
'建边框
Call SetNumreicCoordSys(MAP_WIDTH, MAP_HEIGHT)
SetMapBorder Map1, MAP_WIDTH, MAP_HEIGHT
'创建面图图层
Set fs = New Scripting.FileSystemObject
'------------------------
If fs.FileExists(tbFn) Then
fs.DeleteFile tbFn
End If
Set Lyr = Map1.Layers.CreateLayer(LyrName, tbFn, 2)
Lyr.Editable = False
Lyr.ShowNodes = True
Lyr.Selectable = False
'创建线图图层
'------------------------
If fs.FileExists(tbFnLine) Then
fs.DeleteFile (tbFnLine)
End If
Set fs = Nothing
flds.AddNumericField "DIST", 10, 2
LyrInfo.Type = miLayerInfoTypeNewTable
LyrInfo.AddParameter "FileSpec", tbFnLine
LyrInfo.AddParameter "Name", LyrLineName
LyrInfo.AddParameter "Fields", flds
Set Lyr = Map1.Layers.Add(LyrInfo, 1)
Map1.DataSets.Add miDataSetLayer, Lyr, "DISTANCE"
On Error Resume Next
Lyr.Editable = True
Lyr.ShowNodes = True
Lyr.Selectable = True
'set the current layer name
CURRENT_LAYER = LyrLineName
REGION_LAYER = LyrName
LINE_LAYER = LyrLineName
On Error GoTo ErrHandler
'在数据库里添加一条记录
MAP_CONN.Execute "INSERT INTO tbTable(LyrName,zl,width,height) " & _
" VALUES('" & REGION_LAYER & "','" & FwZL & "'," & CStr(MAP_WIDTH) & "," & CStr(MAP_HEIGHT) & ")"
'refresh the buttons
Call UpdateToolbarButtons
'close the rs
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
'--------------------
Call UpdateSystemTitle
'----------------------------------
SendKeys "{F4}"
'----------------------------------
Screen.MousePointer = 0
Exit Sub
ErrHandler:
Screen.MousePointer = 0
Map1.MousePointer = miArrowCursor
If Not fs Is Nothing Then
Set fs = Nothing
End If
If Not rs Is Nothing Then
If rs.State = adStateOpen Then
rs.Close
End If
Set rs = Nothing
End If
'MsgBox "不能创建新图，可能的原因是系统日期设置不正确！", vbOKOnly + vbInformation, Me.Caption
ErrMessageBox "New", Me.Caption
End SubPrivate Sub SetMapBorder(MapX45 As Map, ByVal aWidth As Double, ByVal aHeight As Double)
Dim tbBorder As String '边框文件名
Dim LyrBorder As String '层名
Dim files As Scripting.FileSystemObject
Dim LyrInfo As New MapXLib.LayerInfo
Dim Lyr As MapXLib.Layer
Dim pts As Points
Dim f As Feature
Dim pt As Point
tbBorder = TABLE_PATH & "border.tab"
LyrBorder = "Border"
'先判断文件是否存在
Set files = New Scripting.FileSystemObject
If files.FileExists(tbBorder) Then
'删除Border图层
files.DeleteFile TABLE_PATH & "border.*"
End If
Set Lyr = Map1.Layers.CreateLayer(LyrBorder, tbBorder)
Lyr.Editable = False
Lyr.ShowNodes = False
Lyr.Selectable = False
'画边框
DrawBorder MapX45, Lyr, aWidth, aHeight
End Sub
Private Sub DrawBorder(MapX45 As Map, Lyr As MapXLib.Layer, ByVal aWidth As Double, ByVal aHeight As Double)
Dim f As New Feature
Dim fs As Features
Dim pts As New Points
Dim pt As New Point
Dim lsty As MapXLib.Style
Dim sp As Long
sp = 0.1
Set fs = Lyr.AllFeatures
'行删除Features
For Each f In fs
Lyr.DeleteFeature (f.FeatureKey)
Next
'画线
pt.Set 0, 0
pts.Add pt
pt.Set aWidth - sp, 0
pts.Add pt
f.Attach MapX45
f.Type = miFeatureTypeLine
f.Parts.Add pts
Set lsty = f.Style
lsty.LineColor = RGB(255, 0, 0)
lsty.LineStyle = 63
Lyr.AddFeature f
'-----------------
f.Parts.RemoveAll
pts.RemoveAll
pt.Set 0, 0
pts.Add pt
pt.Set 0, aHeight - sp
pts.Add pt
f.Attach MapX45
f.Type = miFeatureTypeLine
f.Parts.Add pts
Set lsty = f.Style
lsty.LineColor = RGB(255, 0, 0)
lsty.LineStyle = 63
Lyr.AddFeature f
'-----------------
f.Parts.RemoveAll
pts.RemoveAll
pt.Set aWidth - sp, 0
pts.Add pt
pt.Set aWidth - sp, aHeight - sp
pts.Add pt
f.Attach MapX45
f.Type = miFeatureTypeLine
f.Parts.Add pts
Set lsty = f.Style
lsty.LineColor = RGB(255, 0, 0)
lsty.LineStyle = 63
Lyr.AddFeature f
'---------------------------
f.Parts.RemoveAll
pts.RemoveAll
pt.Set aWidth - sp, aHeight - sp
pts.Add pt
pt.Set 0, aHeight - sp
pts.Add pt
f.Attach MapX45
f.Type = miFeatureTypeLine
f.Parts.Add pts
Set lsty = f.Style
lsty.LineColor = RGB(255, 0, 0)
lsty.LineStyle = 63
Lyr.AddFeature f
End SubPrivate Sub OKButton_Click()
Dim szSQL As String
On Error Resume Next
'save the modification
szSQL = "UPDATE tbTable SET zl='" & txtLocation.Text & "'," & _
"Bjcdw='" & txtBjcdw.Text & "'," & _
"Cly='" & txtCly.Text & "'," & _
"Hyy='" & txtHyy.Text & "'," & _
"Jzmc='" & txtJzmc.Text & "'," & _
"Memo='" & txtMemo.Text & "' " & _
"WHERE LyrName='" & REGION_LAYER & "'"
MAP_CONN.Execute szSQL
Unload Me
End Sub
解决方案 »
免费领取超大流量手机卡，每月29元包185G流量+100分钟通话, 中国电信官方发货