📄 formdxf.frm
字号:
VERSION 5.00
Begin VB.Form DXFtoXYZ
BorderStyle = 1 'Fixed Single
Caption = "Form16"
ClientHeight = 8355
ClientLeft = 45
ClientTop = 435
ClientWidth = 10680
Icon = "FormDXF.frx":0000
LinkTopic = "Form16"
MaxButton = 0 'False
ScaleHeight = 557
ScaleMode = 3 'Pixel
ScaleWidth = 712
ShowInTaskbar = 0 'False
WhatsThisHelp = -1 'True
WindowState = 2 'Maximized
Begin VB.PictureBox Pic1
Appearance = 0 'Flat
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 10875
Left = 3630
ScaleHeight = 723
ScaleMode = 3 'Pixel
ScaleWidth = 769
TabIndex = 20
Top = 30
Width = 11565
End
Begin VB.PictureBox picControls
Height = 10980
Left = 30
ScaleHeight = 728
ScaleMode = 3 'Pixel
ScaleWidth = 230
TabIndex = 0
Top = 60
Width = 3510
Begin VB.CommandButton Command1
Caption = "退 出"
Height = 375
Left = 120
TabIndex = 21
Top = 10440
Width = 3255
End
Begin VB.ListBox List4
BackColor = &H0000FFFF&
Height = 1140
Left = 90
TabIndex = 19
Top = 9240
Width = 3315
End
Begin VB.TextBox Text3
BackColor = &H00FFFFC0&
Height = 270
Left = 2760
TabIndex = 17
Text = "70"
Top = 390
Width = 585
End
Begin VB.FileListBox File1
Height = 1350
Left = 90
Pattern = "*.dxf"
TabIndex = 14
Top = 3000
Width = 3255
End
Begin VB.DirListBox Dir1
Height = 1560
Left = 90
TabIndex = 13
Top = 1260
Width = 3315
End
Begin VB.DriveListBox Drive1
Height = 300
Left = 90
TabIndex = 12
Top = 750
Width = 3315
End
Begin VB.ListBox List1
BackColor = &H00C0C0FF&
ForeColor = &H00000000&
Height = 1575
IntegralHeight = 0 'False
Left = 90
TabIndex = 11
Top = 4560
Width = 3285
End
Begin VB.ListBox List2
BackColor = &H00FFFFC0&
ForeColor = &H00C00000&
Height = 1500
Left = 90
TabIndex = 10
Top = 6150
Width = 3285
End
Begin VB.ListBox List3
BackColor = &H0080FF80&
Height = 1500
Left = 90
TabIndex = 9
Top = 7680
Width = 3285
End
Begin VB.TextBox Text2
BackColor = &H00FFFFC0&
Height = 270
Left = 1500
TabIndex = 8
Text = "14"
Top = 390
Width = 855
End
Begin VB.TextBox Text1
BackColor = &H00FFFFC0&
Height = 270
Left = 120
TabIndex = 7
Text = "1570"
Top = 390
Width = 1095
End
Begin VB.Frame frameMouse
Caption = "Mouse"
Height = 615
Left = 150
TabIndex = 1
Top = 840
Visible = 0 'False
Width = 3225
Begin VB.CommandButton cmdZoomIn
Caption = "+"
Height = 255
Left = 2250
TabIndex = 6
Top = 240
Width = 255
End
Begin VB.CommandButton cmdZoomOut
Caption = "-"
Height = 255
Left = 2730
TabIndex = 5
Top = 240
Width = 255
End
Begin VB.OptionButton optMouse
Caption = " Zoom"
Height = 255
Index = 1
Left = 1110
TabIndex = 4
Top = 240
Width = 855
End
Begin VB.OptionButton optMouse
Caption = "Center"
Height = 255
Index = 4
Left = 3600
TabIndex = 3
Top = 240
Width = 855
End
Begin VB.OptionButton optMouse
Caption = "Pan"
Height = 255
Index = 0
Left = 120
TabIndex = 2
Top = 240
Value = -1 'True
Width = 735
End
End
Begin VB.Label Label1
Caption = "坡面角度"
Height = 225
Left = 2640
TabIndex = 18
Top = 150
Width = 765
End
Begin VB.Label Label8
Caption = "设计段高m"
Height = 255
Left = 1500
TabIndex = 16
Top = 150
Width = 975
End
Begin VB.Label Label7
Caption = "设计底板高程m"
Height = 255
Left = 90
TabIndex = 15
Top = 150
Width = 1335
End
End
End
Attribute VB_Name = "DXFtoXYZ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim i, j, k, dzx(), dzy(), dzz(), color(50)
Const ALTERNATE = 1
Const WINDING = 2
Private Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer '-32767
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Dim hRegion
Dim XMIN, YMIN, XMAX, YMAX, zmin, zmax
Dim TXTjsq, DZXjsq
Dim txtx(1000) As Long
Dim txty(1000) As Long
Dim TXTZ(1000)
Dim XBLC, YBLC, XYBLC
Dim f$, files$, files1$, files2$, files0$, files3$, files4$, filesDZ$, filesKY$, filesLS$
Private Sub Command1_Click()
Unload DXFtoXYZ
End Sub
'
Sub Dir1_Change()
Dir1.Path = App.Path & "\地质\"
File1.Path = Dir1.Path
End Sub
'
Private Sub Drive1_Change()
Dir1.Path = App.Path & "\地质\"
File1.Path = Dir1.Path
End Sub
Private Sub File1_Click()
'Pic1.Top = 4
'Pic1.Left = 4
'Pic1.Width = 1009
'Pic1.Height = 725
Dim wjdata
wjdata = File1.Path & "\" & File1.FileName
wjdata = Trim(wjdata)
wjdata = Mid(wjdata, 1, Len(wjdata) - 4)
files$ = App.Path & "\测量\" & Mid(File1.FileName, 1, Len(File1.FileName) - 4)
f$ = files$
files0$ = f$ & "_.PPP"
files1$ = f$ & "_P01.TXT"
files2$ = f$ & "_P02.TXT"
files3$ = f$ & "_P04.TXT" 'CIRCLE
files4$ = f & "_P08.TXT" '接图
filesDZ$ = f$ & "_P03.TXT" '地质界限
filesKY$ = f$ & "_P06.TXT" '矿岩名称
filesLS$ = f$ & "_.TMP" '临时文件
List1.Clear
List2.Clear
List3.Clear
List4.Clear
List1.AddItem "---上崖点三维坐标---"
List2.AddItem "---下崖点三维坐标---"
List3.AddItem "---地质界线的坐标---"
List4.AddItem "---矿岩文字坐标 文字---"
Dim JSQ1, DS, a, z
color(1) = 8421631
color(2) = 33023
color(3) = 49344
color(4) = 32768
color(5) = 4210688
color(6) = 12640511
color(7) = 8454143
color(8) = 65280
color(9) = 12632064
color(10) = 8388608
color(11) = 4194368
color(12) = 8421631
color(13) = 255
color(14) = 192
color(15) = 128
color(16) = 64
color(17) = 12640511
color(18) = 8438015
color(19) = 33023
color(20) = 16576
color(21) = 16512
color(22) = 4210816
color(23) = 12648447
color(24) = 8454143
color(25) = 65535
color(26) = 49344
color(27) = 32896
color(28) = 16448
color(29) = 12648384
color(30) = 8454016
color(31) = 65280
color(32) = 49152
color(33) = 32768
color(34) = 16384
color(35) = 16777152
color(36) = 16777088
color(37) = 16776960
color(38) = 12632064
color(39) = 8421376
color(40) = 4210688
color(41) = 16761024
color(42) = 16744576
color(43) = 16711680
color(44) = 12582912
color(45) = 8388608
color(46) = 4194304
color(47) = 16761087
color(48) = 16744703
color(49) = 16711935
color(50) = 12583104
Dim JSQP1
Dim JSQP2
Dim LS(4)
Dim JSQK1
Dim P01jsq, P02jsq, P04jsq, PLSjsq
zmax = -99988499: zmin = 999884999
XMAX = -99999327: XMIN = 999327659
YMAX = -99999327: YMIN = 999993276
Close #1
Close #2
Close #10
Close #11
Close #12
Open File1.Path & "\" & File1.FileName For Input As #10
Open files1$ For Output As #1
Open files2$ For Output As #2
Open filesKY$ For Output As #12 '地质矿岩名称 textp012
Open filesLS$ For Output As #13 '临时地质界线
' 坐标X 坐标Y 坐标Z 地名 ------ 用空格分隔
Dim b, c, x, y, X0, Y0, bPolylineJSQ, 区域完成
区域完成 = 0
TXTjsq = 0
Do While Not EOF(10)
Line Input #10, a
'*************************************************************
If a = "AcDbPolyline" Then
If 区域完成 = 1 Then GoTo 3333
bPolylineJSQ = bPolylineJSQ + 1
'AcDbPolyline
'90
'6
'70
'0
'43
'0.0
'10
'53875.81153293069
'20
'101658.3819921133
Input #10, a '90
Input #10, DZXjsq '6
Input #10, a '70
Input #10, a '0
Input #10, a '43
Input #10, a '0.0
For i = 1 To DZXjsq - 1
List3.AddItem "============ " & i & "/" & DZXjsq & " =============="
Input #10, a '10
Input #10, x
Input #10, a '20
Input #10, y
Write #13, y, x, i '序号
Next i
Input #10, a '10
Input #10, x
Input #10, a '20
Input #10, y
Write #13, y, x, 999999999 '999999999结束标志
If x < XMIN Then XMIN = x
If x > XMAX Then XMAX = x
If y < YMIN Then YMIN = y
If y > YMAX Then YMAX = y
'10
'53794.83441722048
'20
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -