?? 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 + -