📄 newproject.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form FrmNewProject
Caption = "新建项目"
ClientHeight = 3210
ClientLeft = 4560
ClientTop = 4530
ClientWidth = 5415
Icon = "newproject.frx":0000
LinkTopic = "Form2"
ScaleHeight = 3210
ScaleWidth = 5415
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton cmdnext
Caption = "确定(&Ok)"
Default = -1 'True
Height = 375
Left = 3240
TabIndex = 9
Top = 2640
Width = 1095
End
Begin VB.Frame Frame2
Caption = "新建项目："
Height = 2295
Left = 1560
TabIndex = 2
Top = 120
Width = 3735
Begin VB.CommandButton cmdbrow
Caption = "..."
Height = 255
Left = 3240
TabIndex = 8
Top = 1200
Width = 375
End
Begin VB.TextBox txtdir
Height = 285
Left = 1080
TabIndex = 7
Top = 1200
Width = 2055
End
Begin VB.TextBox txtname
Height = 285
Left = 1080
TabIndex = 4
Text = "NewProject"
Top = 840
Width = 2055
End
Begin VB.Label Label4
Caption = "警告：原目录中若有同名项目文件，系统将自动覆盖！"
Height = 375
Left = 120
TabIndex = 10
Top = 1680
Width = 3495
End
Begin VB.Label Label3
Caption = "保存位置："
Height = 255
Left = 120
TabIndex = 6
Top = 1200
Width = 1095
End
Begin VB.Label Label2
Caption = "项目名称："
Height = 255
Left = 120
TabIndex = 5
Top = 840
Width = 975
End
Begin VB.Label Label1
Caption = "请输入项目名称及保存目录："
Height = 255
Left = 120
TabIndex = 3
Top = 360
Width = 3495
End
End
Begin VB.CommandButton Cancel
Caption = "取消(&C)"
Height = 375
Left = 4440
TabIndex = 1
Top = 2640
Width = 855
End
Begin VB.PictureBox Picture1
Height = 3015
Left = 120
Picture = "newproject.frx":014A
ScaleHeight = 2955
ScaleWidth = 1275
TabIndex = 0
Top = 120
Width = 1335
End
Begin MSComDlg.CommonDialog dlgCommonDialog
Left = 2040
Top = 2520
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
End
Attribute VB_Name = "FrmNewProject"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*********************************************************************
'*
'* 本源码完全免费，共交通同仁学习参考 *
'* www.tranbbs.com *
'* Developed by Yang Ming *
'* Nanjing Institute of City Transportation Planning *
'* 请保留本版权信息，谢谢合作 *
'* 中国交通技术论坛 *
'* *
'* *
'*********************************************************************
Private Sub Cancel_Click()
Unload Me
End Sub
Private Sub cmdbrow_Click()
Dim tt
Newpath = BrowseForFolder(FrmNewProject.hWnd, "请选择项目保存路径：")
If Trim(Newpath) <> "" Then
tt = ReadIndex("Rec")
WriteIndex "P" + Trim(tt), Newpath
WriteIndex "Rec", Str(Val(tt) + 1)
txtdir.Text = Newpath
If Right(txtdir.Text, 1) <> "\" Then
txtdir.Text = txtdir.Text & "\"
End If
End If
End Sub
Private Sub cmdNext_Click()
ProjectPath = txtdir.Text '项目路径
Dim Lyr_Node As mapxlib.Layer
Dim LayerInfo_Node As New mapxlib.LayerInfo
Dim Flds_Node As New mapxlib.Fields
Dim Lyr_link As mapxlib.Layer
Dim LayerInfo_link As New mapxlib.LayerInfo
Dim Flds_link As New mapxlib.Fields
Dim Lyr_Image As mapxlib.Layer
Dim LayerInfo_Image As New mapxlib.LayerInfo
Dim Flds_Image As New mapxlib.Fields
ProjectName = txtname.Text
Dim DBStr As Database, DBWor As Workspace
If txtname <> "" And txtdir <> "" Then
MDBPath = txtdir & txtname & ".mdb"
NodeTablePath = txtdir & "node.tab"
LinkTablePath = txtdir & "link.tab"
'清除原来图层
Set mDbBiblio = Nothing
Main.Mapshow.Datasets.RemoveAll
Main.Mapshow.Layers.RemoveAll
Main.Mapshow.Refresh
If Dir(MDBPath) <> "" Then
Kill (MDBPath)
End If
If Dir(NodeTablePath) <> "" Then
Kill (NodeTablePath)
End If
If Dir(LinkTablePath) <> "" Then
Kill (LinkTablePath)
End If
Flds_Node.AddStringField "NodeID", 10
LayerInfo_Node.Type = miLayerInfoTypeNewTable
LayerInfo_Node.AddParameter "FileSpec", NodeTablePath
LayerInfo_Node.AddParameter "NAME", "Node"
LayerInfo_Node.AddParameter "Fields", Flds_Node
Set Lyr_Node = Main.Mapshow.Layers.Add(LayerInfo_Node, 1)
Lyr_Node.KeyField = "NodeID"
Flds_link.AddStringField "LinkID", 10
LayerInfo_link.Type = miLayerInfoTypeNewTable
LayerInfo_link.AddParameter "FileSpec", LinkTablePath
LayerInfo_link.AddParameter "NAME", "Link"
LayerInfo_link.AddParameter "Fields", Flds_link
Set Lyr_link = Main.Mapshow.Layers.Add(LayerInfo_link, 1)
Lyr_link.KeyField = "LinkID"
Set DBWor = DBEngine.Workspaces(0)
Set DBStr = DBWor.CreateDatabase(MDBPath, dbLangGeneral, dbVersion30)
Set mDbBiblio = DBEngine.Workspaces(0).OpenDatabase(MDBPath)
'创建表和基本字段
Dim Node_Table As TableDef
Dim Link_Table As TableDef
Dim Fid(1 To 10) As Field
Set Node_Table = mDbBiblio.CreateTableDef("Nodes")
Set Fid(1) = Node_Table.CreateField("NodeId", dbLong)
Set Fid(2) = Node_Table.CreateField("NodeX", dbLong)
Set Fid(3) = Node_Table.CreateField("NodeY", dbLong)
Set Fid(4) = Node_Table.CreateField("NodeType", dbText)
Set Fid(5) = Node_Table.CreateField("CrossType", dbText)
For i = 1 To 5
Node_Table.Fields.Append Fid(i)
Next i
mDbBiblio.TableDefs.Append Node_Table
Set Link_Table = mDbBiblio.CreateTableDef("Links")
Set Fid(1) = Link_Table.CreateField("LinkId", dbLong)
Set Fid(2) = Link_Table.CreateField("NodeI", dbLong)
Set Fid(3) = Link_Table.CreateField("NodeJ", dbLong)
Set Fid(4) = Link_Table.CreateField("LinkType", dbText)
Set Fid(5) = Link_Table.CreateField("Length", dbLong)
Set Fid(6) = Link_Table.CreateField("Mode", dbText)
Set Fid(7) = Link_Table.CreateField("NetworkType", dbText)
Set Fid(8) = Link_Table.CreateField("LaneNum", dbLong)
For i = 1 To 8
Link_Table.Fields.Append Fid(i)
Next i
mDbBiblio.TableDefs.Append Link_Table
NodeRadius = 2
NodeColor = 255
LinkWidth = 1
LinkColor = miColorBlue
'创建项目设置文件并初始化设置文件
Open ProjectPath & "setup.ini" For Output As #1
Write #1, NodeRadius, NodeColor, LinkWidth, LinkColor
Close #1
End If
Call MnuControl
Unload Me
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -