📄 frmmain.frm
字号:
TabIndex = 13
Top = 720
Width = 270
End
End
End
Begin VB.Line lnFirWhite
BorderColor = &H00FFFFFF&
X1 = 75
X2 = 1890
Y1 = 585
Y2 = 585
End
Begin VB.Line lnFirBlack
BorderColor = &H00808080&
X1 = 75
X2 = 1890
Y1 = 705
Y2 = 705
End
Begin VB.Line lnSecWhite
BorderColor = &H00FFFFFF&
X1 = 75
X2 = 1890
Y1 = 675
Y2 = 675
End
Begin VB.Image imgSplitter
Height = 4725
Left = 2715
MouseIcon = "frmMain.frx":BC26
MousePointer = 99 'Custom
Top = 525
Width = 60
End
Begin VB.Line lnLeft
BorderColor = &H00FFFFFF&
X1 = 2880
X2 = 2880
Y1 = 525
Y2 = 5250
End
Begin VB.Line lnSecBlack
BorderColor = &H00808080&
X1 = 75
X2 = 1890
Y1 = 615
Y2 = 615
End
Begin VB.Menu mnuFile
Caption = "文件(&F)"
Begin VB.Menu mnuNew
Caption = "新建(&N)"
Shortcut = ^N
End
Begin VB.Menu mnuOpen
Caption = "打开(&O)..."
End
Begin VB.Menu mnuClose
Caption = "关闭(&C)"
End
Begin VB.Menu mnu1
Caption = "-"
End
Begin VB.Menu mnuTidyup
Caption = "数据库整理(&T)"
End
Begin VB.Menu mnuBackup
Caption = "数据库备份(&B)..."
End
Begin VB.Menu mnuRestore
Caption = "数据库恢复(&R)..."
End
Begin VB.Menu mnu7
Caption = "-"
End
Begin VB.Menu mnuSyslog
Caption = "系统日志(&S)..."
End
Begin VB.Menu mnuOption
Caption = "选项(&P)..."
End
Begin VB.Menu mnu2
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "退出(&E)"
Shortcut = ^Q
End
End
Begin VB.Menu mnuEdit
Caption = "编辑(&E)"
Begin VB.Menu mnuFeatureStyle
Caption = "风格(&F)..."
Enabled = 0 'False
End
Begin VB.Menu mnuEditOptions
Caption = "编辑选项(&E)..."
Enabled = 0 'False
End
Begin VB.Menu mnuLayerControl
Caption = "图层控制(&L)..."
End
Begin VB.Menu mnu3
Caption = "-"
End
Begin VB.Menu mnuSelectAll
Caption = "全选(&A)"
Shortcut = ^A
End
Begin VB.Menu mnuDelete
Caption = "删除(&D)"
Shortcut = {DEL}
End
End
Begin VB.Menu mnuView
Caption = "视图(&V)"
Begin VB.Menu mnuShowToolbar
Caption = "显示工具条(&S)"
Checked = -1 'True
End
Begin VB.Menu mnuShowText
Caption = "显示文本标签(&T)"
Checked = -1 'True
End
Begin VB.Menu mnu4
Caption = "-"
End
Begin VB.Menu mnuFullMap
Caption = "全视图(&F)"
Shortcut = {F4}
End
Begin VB.Menu mnuFlush
Caption = "刷新(&R)"
Shortcut = {F5}
End
Begin VB.Menu mnuShowNodes
Caption = "显示端点(&N)"
Checked = -1 'True
Shortcut = {F6}
End
Begin VB.Menu mnuShowLabel
Caption = "显示标签(&L)"
Shortcut = {F7}
End
Begin VB.Menu mnuTX
Caption = "房屋套型标注(&B)"
End
End
Begin VB.Menu mnuTools
Caption = "工具(&T)"
Begin VB.Menu mnuConvertToRegion
Caption = "转成区域(&R)"
End
Begin VB.Menu mnuCombine
Caption = "区域合并(&B)"
End
Begin VB.Menu mnuWall
Caption = "生成墙体(&Q)"
End
Begin VB.Menu mnu5
Caption = "-"
End
Begin VB.Menu mnuMaxRing
Caption = "生成墙体(&M)"
End
Begin VB.Menu mnuTriangle
Caption = "三角形角度计算(&T)..."
End
End
Begin VB.Menu mnuProp
Caption = "属性(&P)"
Begin VB.Menu mnuLayerSet
Caption = "层数设置(&L)..."
End
Begin VB.Menu mnuProperties
Caption = "类型设置(&P)..."
End
Begin VB.Menu mnuProporte
Caption = "分摊(&D)..."
End
Begin VB.Menu mnuWallFT
Caption = "墙体分摊(&W)"
Enabled = 0 'False
End
Begin VB.Menu mnuAttach
Caption = "阳台、阁楼归属(&G)"
End
Begin VB.Menu mnu6
Caption = "-"
End
Begin VB.Menu mnuCalcArea
Caption = "面积计算(&C)"
End
Begin VB.Menu mnuAreaDisp
Caption = "面积计算报表(&A)"
End
Begin VB.Menu mnuPrintMap
Caption = "打印图纸(&E)"
End
End
Begin VB.Menu mnuHelp
Caption = "帮助(&H)"
Begin VB.Menu mnuCalc
Caption = "计算器(&C)..."
End
Begin VB.Menu mnuAbout
Caption = "关于(&A)..."
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long
Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
'Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const SW_SHOW = 5
'用于记录窗体大小和位置
Dim WorkHeight As Double
Dim WorkWidth As Double
Dim WorkLeft As Double
Dim WorkTop As Double
Dim sglSplitLimit As Double
'Custom Tools
Const ctLineTool = 500 '直线
Const ctPointTool = 501
Const ctPolyLineTool = 502 '折线
Const ctPolygonTool = 503 '区域
Const ctArcTool = 504 '画圆弧
Const ctPointSelectTool = 505 '点选构面
Const ctGenWallTool = 506 '生成墙体
'SHORTEST_DISTANCE是Pixel为Unit的
Dim SHORTEST_DISTANCE As Single
Const SHORTEST_TIME As Long = 150
Const BLOCK_SIZE As Long = 102400
Dim MAP_WIDTH As Long
Dim MAP_HEIGHT As Long
'以下是用来记录PolyLine、Polygon的Points
Dim NewPts As New MapXLib.Points
Dim nPt As New MapXLib.Point
Private Sub Form_Load()
Dim newLayer As Layer
Dim theArea As rect
On Error GoTo ErrHandler
Screen.MousePointer = 11
'取得工作区的大小
theArea = GetWorkArea()
'设置应用程序的主窗口的大小
Me.Left = theArea.Left * Screen.TwipsPerPixelX
Me.Top = theArea.Top * Screen.TwipsPerPixelX
Me.Width = (theArea.Right - theArea.Left) * Screen.TwipsPerPixelX
Me.Height = (theArea.Bottom - theArea.Top) * Screen.TwipsPerPixelY
sglSplitLimit = SSTabWks.Left + SSTabWks.Width
'记录下工作区
WorkLeft = Me.Left
WorkTop = Me.Top
WorkHeight = Me.Height
WorkWidth = Me.Width
'get mnuShowToolbar.checked's value
mnuShowToolbar.Checked = CBool(GetSetting("Personnal Programming", "Toolbar", "IsHided", "1"))
tbToolbar.Visible = mnuShowToolbar.Checked
'get mnuShowTetx.checked's value
mnuShowText.Checked = CBool(GetSetting("Personnal Programming", "Toolbar", "IsTextLabel", "1"))
SetToolbarTextLabel mnuShowText.Checked
'-------------------------------------------------
'the following code is relationed to the map
'------------------------------------------------------
'---------------------------
MAP_WIDTH = 400
MAP_HEIGHT = 300
SHORTEST_DISTANCE = MAP_WIDTH / SHORTEST_TIME
'disable the buttons or enable the button
Call UpdateToolbarButtons
'设置MAP参数
Call InitMap
'------------------------------------------------
'强制重画一下各个控件
SizeControls imgSplitter.Left
'--------------------------
Screen.MousePointer = 0
Exit Sub
ErrHandler:
Screen.MousePointer = 0
ErrMessageBox "frmMain::Load()", Me.Caption
End Sub
Private Sub Form_Resize()
'限制窗口的大小
If Me.WindowState <> 1 Then
If Me.Width < WorkWidth Then Me.Width = WorkWidth
If Me.Height < WorkHeight Then Me.Height = WorkHeight
Me.Left = WorkLeft
Me.Top = WorkTop
End If
'resize the controls
SizeControls imgSplitter.Left
'Resize the picture so that it takes up the entire window
' If Me.ScaleWidth > 0 And Me.ScaleHeight > 0 Then
' '-------resize the picture------------------------
' Picture1.Left = 0
' Picture1.Width = Me.ScaleWidth
' If tbToolbar.Visible Then
' Picture1.Top = tbToolbar.Height
' Picture1.Height = Me.ScaleHeight - tbToolbar.Height - sbStatusBar.Height
' Else
' Picture1.Top = 0
' Picture1.Height = Me.ScaleHeight - -sbStatusBar.Height
' End If
' 'resize the panels of the statusbar
' Call SeperateStatusBar(Me.ScaleWidth)
' End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Dim i As Integer
'关闭图形文件
Call CloseCurrentMap
'close all sub forms
For i = Forms.Count - 1 To 1 Step -1
Unload Forms(i)
Next
'断开数据库连接
If Not MAP_CONN Is Nothing Then
If MAP_CONN.State = adStateOpen Then
MAP_CONN.Close
End If
Set MAP_CONN = Nothing
End If
'save the toolbar's information
SaveSetting "Personnal Programming", "Toolbar", "IsHided", CStr(mnuShowToolbar.Checked)
SaveSetting "Personnal Programming", "Toolbar", "IsTextLabel", CStr(mnuShowText.Checked)
'--------------
End
End Sub
Private Sub imgSplitter_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
With imgSplitter
picSplitter.Move .Left, .Top, .Width, .Height
End With
picSplitter.Visible = True
End Sub
Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim sglPos As Single
If (Button And vbLeftButton) > 0 Then
sglPos = X + imgSplitter.Left
If sglPos >= 0 Then
picSplitter.Left = sglPos
Else
picSplitter.Left = 0
End If
End If
End Sub
Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If picSplitter.Left < sglSplitLimit Then
picSplitter.Left = sglSplitLimit
Else
If picSplitter.Left > (Me.ScaleWidth - sglSplitLimit) Then
picSplitter.Left = Me.ScaleWidth - sglSplitLimit
End If
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -