В приложении Б представлен исходный код разработанных функций и процедур на языке программирования Visual Basic

Public koefX, koefY As Double

Dim maxX, maxY, minX, minY As Double

Dim visNomSkv As Boolean

Public folder As String

Const lenText = 4 / 25.4

Const lenCentr = 0.8 / 25.4

Sub DrawMap()

Dim Dir As String

Dim collFName As New Collection

folder = ThisDocument.Path

Call SearchFiles(idm, collFName)

ReadParamMap

Call DrawKontur(collFName)

End Sub

Sub SearchFiles(ByVal idm As String, Coll As Collection)

Dim i As Integer

Dim sFileName As String

Dim fso As FileSystemObject

Set fso = New FileSystemObject

For i = 1 To 16

sFileName = folder + CStr(i)

If fso.FileExists(sFileName) = True Then

Coll.Add Item:=sFileName

End If

Next

sFileName = folder + "lineust"

If fso.FileExists(sFileName) Then

Coll.Add Item:=sFileName

End If

End Sub

Private Sub ReadParamMap()

Dim xmlDoc As New MSXML.DOMDocument

Dim iNode As IXMLDOMNode

xmlDoc.Load (folder + "option.xml")

Set iRoot = xmlDoc.FirstChild

Set iNode = iRoot.childNodes.Item(FindIndexTag(iRoot, "gran_img"))

maxX = CDbl(iNode.Attributes.getNamedItem("right").nodeValue)

minX = CDbl(iNode.Attributes.getNamedItem("left").nodeValue)

minY = CDbl(iNode.Attributes.getNamedItem("top").nodeValue)

maxY = CDbl(iNode.Attributes.getNamedItem("bottom").nodeValue)

Set iNode = iRoot.childNodes.Item(FindIndexTag(iRoot, "nom_skv"))

visNomSkv = CBool(iNode.Attributes.getNamedItem("visible").nodeValue)

koefX = (maxX - minX) / 190

koefY = (maxY - minY) / 260

If koefX < koefY Then

koefX = koefY

Else

koefY = koefX

End If

End Sub

Sub DrawKontur(Coll As Collection)

Dim shapeObj As Shape

Dim shapeCell As Cell

Dim tipL, pos, k, pointStart, k1, NumPoint As Integer

Dim rast, koorX, koorY, predX, predY As Double

Dim znLine, Str As String

Dim oGnk As New Gnk

Dim oGnkVn As New GnkVn

Dim oGran As New Gran

Dim oIzoPunkt As New IzolPunkt

Dim oVnk As New Vnk

Dim oVnkVn As New VnkVn

Dim oZam As New Zam

Dim oKoor As New Koor

Dim oSkv As New Skv

Dim oHeadMap As New HeadMap

Dim oLegendMap As New LegendMap

Dim CollKoor As New Collection

Dim shapeGroupLine, shapeGroup As Shape

Dim shapeSelection, shapeLine, shapeText As Selection

ActiveWindow.DeselectAll

Set shapeSelection = ActiveWindow.Selection

Set shapeLine = ActiveWindow.Selection

Set shapeText = ActiveWindow.Selection

For i = 1 To Coll.Count

If Coll.Item(i) = folder + "lineust" Then

tipL = 20

Else

a = Split(Coll.Item(i), "\")

tipL = a(UBound(a))

End If

Open Coll.Item(i) For Input As #1

Do While InStr(Str, "->") = 0

Input #1, Str

Loop

Do While Not EOF(1)

b = True

num = 0

Input #1, Str

pos = InStr(Str, " ")

koorX = ConvertX(CDbl(Left(Str, pos - 1)))

Str = Trim(Right(Str, Len(Str) - pos))

pos = InStr(Str, " ")

If pos = 0 Then

pos = Len(Str) + 1

End If

koorY = ConvertY(CDbl(Left(Str, pos - 1)))

pos = InStr(Str, " ")

znLine = Trim(Right(Str, Len(Str) - pos))

If tipL = 5 Then

Set CollKoor = Nothing

Set oKoor = Nothing

oKoor.x = koorX

oKoor.y = koorY

CollKoor.Add Item:=oKoor

End If

predX = koorX

predY = koorY

Select Case tipL

Case 2

oVnk.Init

Case 4

oGran.Init

Case 6

oZam.Init

Case 9

oVnkVn.Init

Case 10, 12

oGnk.Init

Case 11, 13

oGnkVn.Init

Case 14

oIzoPunkt.Init

Case 16

If Not EOF(1) Then

Input #1, Str

End If

If visNomSkv Then

Call oSkv.DrawSkv(shapeLine, shapeText, koorX, koorY, znLine)

Else

Call oSkv.DrawSkv(shapeLine, shapeText, koorX, koorY, "")

End If

End Select

If tipL <> 16 Then

Input #1, Str

k1 = tipL

NumPoint = 1

Do While b = True And InStr(Str, "->") = 0

If EOF(1) Then

b = False

End If

pos = InStr(Str, " ")

koorX = ConvertX(CDbl(Left(Str, pos - 1)))

Str = Trim(Right(Str, Len(Str) - pos))

pos = InStr(Str, " ")

If pos = 0 Then

pos = Len(Str) + 1

End If

koorY = ConvertY(CDbl(Left(Str, pos - 1)))

If znLine <> "" And tipL = 5 Then

Set oKoor = Nothing

oKoor.x = koorX

oKoor.y = koorY

CollKoor.Add Item:=oKoor

End If

Select Case tipL

Case 3, 5, 8, 7, 20

Call DrawObiknLine(shapeLine, koorX, koorY, predX, predY, k1)

Case 2

Call oVnk.DrawFigure(shapeLine, koorX, koorY, predX, predY)

Case 4

Call oGran.DrawLine(shapeLine, koorX, koorY, predX, predY)

Case 6

Call oZam.DrawLine(shapeLine, koorX, koorY, predX, predY)

Case 9

Call oVnkVn.DrawFigure(shapeLine, koorX, koorY, predX, predY)

Case 10, 12

Call oGnk.DrawFigure(shapeLine, koorX, koorY, predX, predY)

Case 11, 13

Call oGnkVn.DrawFigure(shapeLine, koorX, koorY, predX, predY)

Case 14

Call oIzoPunkt.DrawFigure(shapeLine, koorX, koorY, predX, predY)

End Select

predX = koorX

predY = koorY

If b = True Then

Input #1, Str

NumPoint = NumPoint + 1

End If

Loop

If shapeLine.Count > 0 Then

Set shapeGroupLine = shapeLine.Group

shapeSelection.Select shapeGroupLine, visSelect

shapeLine.DeselectAll

End If

If znLine <> "" And tipL = 5 Then

Call DrawText(shapeText, CollKoor, NumPoint, znLine)

End If

End If

Loop

If tipL = 5 Then

Set shapeGroupLine = shapeSelection.Group

shapeGroupLine.Name = "Линии"

shapeSelection.DeselectAll

shapeSelection.Select shapeGroupLine, visSelect

Set shapeGroupLine = shapeText.Group

shapeGroupLine.Name = "Глубины изолиний"

shapeSelection.Select shapeGroupLine, visSelect

shapeLine.DeselectAll

shapeText.DeselectAll

End If

If tipL = 16 Then

Set shapeGroupLine = shapeLine.Group

shapeGroupLine.Name = "Пиктограммы"

shapeSelection.DeselectAll

shapeSelection.Select shapeGroupLine, visSelect

If shapeText.Count <> 0 Then

Set shapeGroupLine = shapeText.Group

shapeGroupLine.Name = "Номера скважин"

shapeSelection.Select shapeGroupLine, visSelect

shapeText.DeselectAll

End If

shapeLine.DeselectAll

End If

If shapeSelection.Count > 0 Then

If shapeSelection.Count = 1 Then

Set shapeGroup = shapeSelection.Item(1)

shapeSelection.DeselectAll

Else

Set shapeGroup = shapeSelection.Group

shapeSelection.DeselectAll

End If

End If

Select Case tipL

Case 6

shapeGroup.Name = "Замещения"

Case 5

shapeGroup.Name = "Изолинии"

Case 2

shapeGroup.Name = "ВНК"

Case 3

shapeGroup.Name = "Разлом"

Case 4

shapeGroup.Name = "Линия выклинивания"

Case 7

shapeGroup.Name = "Гран лиц участков"

Case 8

shapeGroup.Name = "Границы категорий запасов"

Case 9

shapeGroup.Name = "ВНК внутр"

Case 10

shapeGroup.Name = "ГВК"

Case 11

shapeGroup.Name = "ГВК внутр"

Case 12

shapeGroup.Name = "ГНК"

Case 13

shapeGroup.Name = "ГНК внутр"

Case 14

shapeGroup.Name = "Изолинии пунктир"

Case 16

shapeGroup.Name = "Скважины"

Case 20

shapeGroup.Name = "Линии устья"

End Select

Close #1

Next

oHeadMap.DrawHead

oLegendMap.DrawLegend

Set Coll = Nothing

Set CollKoor = Nothing

End Sub

Public Function ConvertX(ByVal koorX As Double) As Double

ConvertX = (koorX - minX) / koefX / 25.4

End Function

Public Function ConvertY(ByVal koorY As Double) As Double

ConvertY = (koorY - minY) / koefY / 25.4

End Function

Sub DrawObiknLine(ByVal shapeLine As Selection, ByVal koorX, koorY, predX, predY As Double, ByVal tipL As Integer)

Dim shapeObj As Shape

Dim shapeCell As Cell

Set shapeObj = ActivePage.DrawLine(predX, predY, koorX, koorY)

Select Case tipL

Case 7, 8

Set shapeCell = shapeObj.Cells("LineColor")

shapeCell.Formula = "RGB(0,255,0)"

Case 3

Set shapeCell = shapeObj.Cells("LineColor")

shapeCell.Formula = "RGB(255,0,0)"

Case 20

Set shapeCell = shapeObj.Cells("LineColor")

shapeCell.Formula = "RGB(0,0,255)"

End Select

shapeLine.Select shapeObj, visSelect

End Sub

Sub DrawText(ByVal shapeText As Selection, ByVal CollKoor As Collection, ByVal NumPoint As Integer, ByVal znLine As String)

Dim predX, predY, koorX, koorY As Double

Dim rast, rastPred, tmp, delX, delY, koef As Double

Dim shapeObj As Shape

Dim k1 As Integer

If NumPoint = 2 Then

predX = CollKoor.Item(1).x

predY = CollKoor.Item(1).y

koorX = CollKoor.Item(2).x

koorY = CollKoor.Item(2).y

pointStart = 2

Set shapeObj = ActivePage.DrawLine(predX, predY, koorX + lenText, koorY)

shapeText.Select shapeObj, visSelect

Else

predX = CollKoor.Item(Round(NumPoint / 2) - 1).x

predY = CollKoor.Item(Round(NumPoint / 2) - 1).y

koorX = CollKoor.Item(Round(NumPoint / 2)).x

koorY = CollKoor.Item(Round(NumPoint / 2)).y

pointStart = Round(NumPoint / 2)

k1 = pointStart

rast = Sqr((koorX - predX) * (koorX - predX) + (koorY - predY) * (koorY - predY))

Do While rast < (lenText) And pointStart < CollKoor.Count

pointStart = pointStart + 1

koorX = CollKoor.Item(pointStart).x

koorY = CollKoor.Item(pointStart).y

rast = Sqr((koorX - predX) * (koorX - predX) + (koorY - predY) * (koorY - predY))

Loop

If koorX < predX Then

tmp = koorX

koorX = predX

predX = tmp

tmp = koorY

koorY = predY

predY = tmp

End If

Call DefineDelXY(predX, predY, koorX, koorY)

If rast < lenText Then

koef = lenText / rast

delY = (predY - koorY) * koef

delX = (koorX - predX) * koef

Set shapeObj = ActivePage.DrawLine(predX, predY, predX + delX, predY - delY)

shapeObj.Text = znLine

shapeObj.LineStyle = "Text Only"

shapeObj.TextStyle = "MapZnLine"

Else

Set shapeObj = ActivePage.DrawLine(predX, predY, koorX, koorY)

shapeObj.Text = znLine

shapeObj.LineStyle = "Text Only"

shapeObj.TextStyle = "MapZnLine"

End If

shapeText.Select shapeObj, visSelect

End If

End Sub

Sub DefineDelXY(predX, predY, koorX, koorY As Double)

Dim ugol, delX, delY, k As Double

k = (koorY - predY) / (predX - koorX)

If k <> 0 Then

ugol = Atn(-1 / k)

Else

ugol = Pi / 2

End If

delY = Sin(ugol) * lenCentr

delX = Cos(ugol) * lenCentr

If predY > koorY Then

predX = predX + delX

predY = predY - delY

koorX = koorX + delX

koorY = koorY - delY

Else

predX = predX - delX

predY = predY + delY

koorX = koorX - delX

koorY = koorY + delY

End If

End Sub

Function FindIndexTag(ByVal iNode As IXMLDOMNode, Name As String) As Integer

Dim i As Integer

Dim z As Boolean

i = 0

z = True

While i < iNode.childNodes.Length And z

If iNode.childNodes.Item(i).nodeName = Name Then

z = False

End If

i = i + 1

Wend

If z = True Then

FindIndexTag = -1

Else

FindIndexTag = i - 1

End If

End Function

Размещено на Allbest.ru