formdxf.frm

从AUTOCAD的DXF图形提取要素坐标xyz

'101659.8312466199
'10
'53811.49816963238
'20
'101660.6375311261
'0
'REGION

Input #10, a
Input #10, a 'REGION
 
If a = "REGION" Then 区域完成 = 1

3333
End If

If a = "AcDbText" Then



'AcDbText
'10
'53774.20122667838
'20
'101647.7849753079
'30
'0.0
'40
'1.5
'1
'1569.632

Input #10, a '10
Input #10, x
Input #10, a '20
Input #10, y



Input #10, a '30
Input #10, a '0.0
Input #10, a '40
Input #10, a '1.5
Input #10, a '1
Input #10, z '1569.632

If Asc(z) >= 45 And Asc(z) <= 57 Then '  -  0  9避免文字字母进入上下线


    If z >= Val(Text1.Text) + Val(Text2.Text) / 2 And z < Val(Text1.Text) + Val(Text2.Text) + Val(Text2.Text) / 5 Then
    
        P01jsq = P01jsq + 1
        '
        
        List1.AddItem "============ " & P01jsq & " =============="
        List1.AddItem "X " & Int(y * 1000) / 1000
        List1.AddItem "Y " & Int(x * 1000) / 1000
        List1.AddItem "Z " & Int(z * 1000) / 1000
        
        ' xy 互换！！
        Write #1, y, x, z
        
        If x < XMIN Then XMIN = x
        If x > XMAX Then XMAX = x
        If y < YMIN Then YMIN = y
        If y > YMAX Then YMAX = y
    
    End If


    If z < Val(Text1.Text) + Val(Text2.Text) / 2 And z > Val(Text1.Text) - Val(Text2.Text) / 5 Then
        P02jsq = P02jsq + 1
        List2.AddItem "============ " & P02jsq & " =============="
        List2.AddItem "X " & Int(y * 1000) / 1000
        List2.AddItem "Y " & Int(x * 1000) / 1000
        List2.AddItem "Z " & Int(z * 1000) / 1000
        ' xy 互换！！
        Write #2, y, x, z
        
        If x < XMIN Then XMIN = x
        If x > XMAX Then XMAX = x
        If y < YMIN Then YMIN = y
        If y > YMAX Then YMAX = y
    
    End If

Else

    If Len(z) > 1 Then
        TXTjsq = TXTjsq + 1
        List4.AddItem "============ " & TXTjsq & " =============="
        
        List4.AddItem "X " & Int(y * 1000) / 1000
        List4.AddItem "Y " & Int(x * 1000) / 1000
        List4.AddItem "T " & z
        ' xy 互换！！
        Write #12, y, x, z 'z=矿岩属性
         
        txtx(TXTjsq) = y
        txty(TXTjsq) = x
        TXTZ(TXTjsq) = z
         
    End If

  End If
End If
200


Loop




Close #10 'DXF
'Close #11 '地质矿岩圈
Close #12 '地质矿岩名称 text
Close #13 '临时地质界线

Close #1 'p01
Close #2 'p02


'清理重复数据，去掉地质圈内的下线：
 
Open filesLS$ For Input As #13 '临时地质界线p03
Open files2$ For Input As #2 '下线
 
i = 0


ReDim dzx(2)
ReDim dzy(2)
ReDim dzz(2)



Do Until EOF(13)

ReDim Preserve dzx(UBound(dzx) + 1)
ReDim Preserve dzy(UBound(dzy) + 1)
ReDim Preserve dzz(UBound(dzz) + 1)
i = i + 1
Input #13, dzx(i), dzy(i), dzz(i)
 
Loop
Close #13


j = i

Do Until EOF(2)    ' 循环至文件尾。

ReDim Preserve dzx(UBound(dzx) + 1)
ReDim Preserve dzy(UBound(dzy) + 1)
ReDim Preserve dzz(UBound(dzz) + 1)

j = j + 1
Input #2, dzx(j), dzy(j), dzz(j)
Loop
Close #2


Close #13
Kill filesLS$
Open filesLS$ For Output As #13 '临时地质界线p03


Dim kk, jsqq

For k = 1 To i ' 地质界线

For kk = i + 1 To j '下线
If dzx(k) = dzx(kk) And dzy(k) = dzy(kk) Then jsqq = 1: GoTo 550

Next kk


If jsqq = 0 Then
Write #13, dzx(k), dzy(k), dzz(k)

End If
550
jsqq = 0

Next k


Close #13
Close #2



'判断地质圈 是否有用：

Close #11
Open filesDZ$ For Output As #11 '地质界线p03

Close #13
Open filesLS$ For Input As #13  'ls地质界线
Dim qsI
Dim QJjsq, LJjsq
QJjsq = j
qsI = 1
i = 0

ReDim poA(1) As POINTAPI


Do Until EOF(13)  'ls地质界线  ' 循环至文件尾。
ReDim Preserve poA(UBound(poA) + 1)

i = i + 1
LJjsq = LJjsq + 1
Input #13, dzx(i), dzy(i), dzz(i)

poA(i).x = dzx(i)
poA(i).y = dzy(i)
z = dzz(i)

If z = 999999999 Then


hRegion = CreatePolygonRgn(poA(qsI), LJjsq + 1 - qsI, ALTERNATE)  '点的区域



Dim T, Tjsq, 矿岩属性

Tjsq = 0
For T = 1 To TXTjsq

If PtInRegion(hRegion, txtx(T), txty(T)) Then           ' 如果(X, Y) 位於 hRegion 所定义的区域之内
Tjsq = Tjsq + 1
矿岩属性 = TXTZ(T)
End If

Next T

If Tjsq = 1 Then '仅有一个点落入圈内，记录圈点'地质界线p03

For T = qsI To LJjsq - 1

Write #11, dzx(T), dzy(T), dzz(T) '地质界线p03  DZz(T)= 1 2 3.

Next T
Write #11, dzx(T), dzy(T), 矿岩属性 '在999999999位置写入矿岩属性

End If
qsI = i + 1

DeleteObject hRegion
End If
Loop

Close #1
Close #11
Close #13

'显示地质图 pic1.scalemode=pixel

1234
Pic1.Cls
Dim xx, yy
xx = XMAX - XMIN
yy = YMAX - YMIN
xx = Pic1.Width - xx
yy = Pic1.Height - yy
XBLC = ((Pic1.Width) / (XMAX - XMIN)): YBLC = ((Pic1.Height) / (YMAX - YMIN))
If XBLC < YBLC Then XYBLC = XBLC Else XYBLC = YBLC

XBLC = XYBLC: YBLC = XYBLC    '.7'wzx
XBLC = XBLC * 0.95
YBLC = YBLC * 0.95

For i = 1 To QJjsq
dzx(i) = (dzx(i) - YMIN + xx) * XBLC
dzy(i) = (dzy(i) - XMIN + yy) * YBLC



Next i


tian

ReDim poA(1) As POINTAPI


Exit Sub


End Sub


Private Sub tian()

'VbFSSolid 0 实线
'VbFSTransparent 1 （缺省值）透明。
'VbHorizontalLine 2 水平直线。
'VbVerticalLine 3 垂直直线。
'VbUpwardDiagonal 4 上斜对角线。
'VbDownwardDiagonal 5 下斜对角线
'VbCross 6 十字线
'VbDiagonalCross 7 交叉对角线
'
'
'说明
'
'如果 FillStyle 设置为 1（透明），则忽略 FillColor 属性，但是 Form 对象除外。


' Case "P03"'地质界线
List3.Clear
List3.AddItem "---地质界线的坐标---"



Close #1
Open filesDZ$ For Input As #1 '地质界线p03


Pic1.DrawStyle = 0
Pic1.DrawWidth = 1
Pic1.ForeColor = RGB(0, 0, 0) ' &H404040

Dim DZjsq '地质圈点
Dim dzLX '类型
dzLX = 0



i = 0
Dim dzks, dzjs '地质开始 结束
dzks = 1
Dim d, e
Do Until EOF(1)
i = i + 1

Input #1, dzx(i), dzy(i), dzz(i)
d = d + 1
e = e + 1
List3.AddItem "============ " & d & " =============="


List3.AddItem "X " & Int(dzx(i) * 1000) / 1000
List3.AddItem "Y " & Int(dzy(i) * 1000) / 1000



dzx(i) = (dzx(i) - YMIN) * XBLC
dzy(i) = (dzy(i) - XMIN) * YBLC


dzx(i) = Pic1.Height - dzx(i) - 20



If dzz(i) = 1 Then '数据的DZz(j)存有分块编号123。。。123。。。

dzks = i
Pic1.PSet (dzy(i), dzx(i))
End If


DZjsq = DZjsq + 1  '地质圈点



If Asc(dzz(i)) > 57 Then   'DZz(I)是文字字母 MFea-k .....原来是 999999999 改为字母


dzLX = dzLX + 1
dzjs = i

d = 0

Pic1.ForeColor = RGB(0, 0, 0)

Pic1.DrawWidth = 1


For i = dzks To dzjs
d = d + 1
'
Pic1.Line -(dzy(i), dzx(i))


 
Next i

Pic1.Line -(dzy(dzks), dzx(dzks))

d = 0
End If


Loop

List3.AddItem "====== 地质边界点 " & dzjs & " 个======"

 
Randomize
 
Pic1.FillStyle = 0 ' nFillStyle

 
Pic1.FillStyle = 0         ' 将填充方式设置为不透明的实体!!!!  1=透明的,没填
'=======================================================
 
Pic1.DrawWidth = 1
 

For j = 1 To TXTjsq



txtx(j) = (txtx(j) - YMIN) * XBLC
txty(j) = (txty(j) - XMIN) * YBLC

txtx(j) = Pic1.Height - txtx(j) - 20

 
Pic1.FillColor = color(j)
 


ExtFloodFill Pic1.hdc, txty(j), txtx(j), Pic1.Point(txty(j), txtx(j)), 2


Pic1.CurrentX = txty(j)
Pic1.CurrentY = txtx(j)
Pic1.ForeColor = RGB(0, 0, 0)

Pic1.Print TXTZ(j)

Next j

DeleteObject hdc


Pic1.FillStyle = 1
End Sub