Microstation VBA – Eşyükselti eğrisi seyreltme » PerfectGate Bilişim Topluluğu

Microstation VBA – Eşyükselti eğrisi seyreltme

Yazan: Revne | Tarih

26 Şubat 2009 | Yorum

Yorum Yok

Henüz puan verilmemiş

Loading ...

MicroStation programının içine yazdığım VBA kodunun bir kısmı..
Buradaki kod Coğrafyadan bildiğimiz Eşyukseklik eğrisi için olculen nokları, parametre olarak verilen yumpar değişkenine gore azaltıyor. Eşyukseklik eğrisi daha az veriyle eskine yakın bir dogrultu izliyor. Bu işlem daha sonra yapılacak B-Spline ve Parametre ile eğriyi yumusatma işlemlerinin ilk adımı. Eğer eğride cok fazla nokta varsa yumusatma yapamiyorsunuz.

PLAIN TEXT

Visual Basic:

'Egri Seyreltme
Public Function EgriSeyrelt(ele As Element, yumpar As Double, retCnt As Integer) As Point3d()
  Dim verts() As Point3d, nverts() As Point3d, vstat() As Boolean, cntVert As Integer
  Dim i As Integer, j As Integer, k As Integer
  Dim mes1 As Double, mes2  As Double
  Dim pkes1 As Point3d, pkes2 As Point3d
  Dim ind As Integer
  
  cntVert = ele.AsVertexList.VerticesCount
  ReDim vstat(cntVert) As Boolean
  ReDim nverts(cntVert) As Point3d
  verts = ele.AsVertexList.GetVertices()
  For i = 0 To cntVert - 2
    mes = 0
    For j = i + 2 To cntVert - 1
      mes1 = Point3dDistance(verts(i), verts(j))
      If mes1&gt; yumpar Then Exit For
    Next
    If j = i + 2 Then
      'diger noktaya konumlan
    Else
      j = j - 1 'Onceki nokya cizgi cizilecek
      mes1 = 0
      ind = i + 1
      For k = i + 1 To j
        pkes2 = dikkesen(verts(k), verts(i), verts(j))
        mes2 = Point3dDistance(pkes2, verts(k))
        If (mes2&gt;= mes1) Then ind = k: mes1 = mes2: pkes1 = pkes2
        vstat(k) = True
      Next
      pkes2.x = (verts(ind).x + pkes1.x) / 2#
      pkes2.y = (verts(ind).y + pkes1.y) / 2#
      pkes2.Z = (verts(ind).Z + pkes1.Z) / 2#
      vstat(j - 1) = False
      verts(j - 1) = pkes2
      i = j - 1
    End If
  Next
  retCnt = 0
  For i = 0 To cntVert - 1
    If vstat(i) = False Then
      retCnt = retCnt + 1
      nverts(retCnt) = verts(i)
    End If
  Next
  EgriSeyrelt = nverts
End Function