Function pcDMIS_extract_Number(ByVal aText As String) As Integer
  pcDMIS_extract_Number = 0
  If aText = "" Then Exit Function
  Dim I As Integer
  Dim S As String
    
  S = ""
  For I = 1 To Len(aText)
    If InStr(1, "0123456789", Mid(aText, I, 1)) > 0 Then
      S = S + Mid(aText, I, 1)
    End If
  Next I
  If S <> "" Then pcDMIS_extract_Number = CInt(S)
End Function

Sub Main()
  ' writes all pointdata to excel sheet
  ' the excel sheet must be saved manually
  
  ' constants
    Const sVectorPointName = "PT_"
    Const iStartPointNr = 1 '0 = All
    Const iEndPointNr = 0 '0 = All
  
  ' Dim Something
    Dim pcDMISApp As Object
    Set pcDMISApp = CreateObject("PCDLRN.Application")
    Dim pcDMISPart As Object
    Set pcDMISPart = pcDMISApp.ActivePartProgram
    Dim pcDMISCmds As Object
    Set pcDMISCmds = pcDMISPart.Commands
    Dim pcDMISCmd As Object
  
    Dim objExcel As Object
    Dim objNewBook As Object
    
    Set objExcel = CreateObject("Excel.Application")
    Set objNewBook = objExcel.Workbooks.Add
    
    Dim sPath As String
    Dim iCount, iNumber As Integer
    Dim vTX, vTY, vTZ, vMX, vMY, vMZ As Double
    Dim vMI, vMJ, vMK As Double

  ' write excel heading
    objExcel.ScreenUpdating = False
    objNewBook.Sheets(1).Cells(1, 1).Value = "name"
    objNewBook.Sheets(1).Cells(1, 2).Value = "X-Value"
    objNewBook.Sheets(1).Cells(1, 3).Value = "Y-Value"
    objNewBook.Sheets(1).Cells(1, 4).Value = "Z-Value"
    objNewBook.Sheets(1).Cells(1, 5).Value = "T-Value"
    
  ' search pcDMIS
    iCount = 2
    
    For Each pcDMISCmd In pcDMISCmds
      If pcDMISCmd.Type = 602 Then 'CONTACT_VECTOR_POINT_FEATURE = 602
        iNumber = pcDMIS_extract_Number(pcDMISCmd.ID)
        If (InStr(1, pcDMISCmd.ID, sVectorPointName) > 0) And _
           ((iNumber >= iStartPointNr) Or (iStartPointNr = 0)) And _
           ((iNumber <= iEndPointNr) Or (iEndPointNr = 0)) _
        Then
          ' get some values from command
          vTX = pcDMISCmd.GetText(THEO_X, 0)
          vTY = pcDMISCmd.GetText(THEO_Y, 0)
          vTZ = pcDMISCmd.GetText(THEO_Z, 0)
          vMX = pcDMISCmd.GetText(MEAS_X, 0)
          vMY = pcDMISCmd.GetText(MEAS_Y, 0)
          vMZ = pcDMISCmd.GetText(MEAS_Z, 0)
          vMI = pcDMISCmd.GetText(MEAS_I, 0)
          vMJ = pcDMISCmd.GetText(MEAS_J, 0)
          vMK = pcDMISCmd.GetText(MEAS_K, 0)
          
          ' write to Excel
          objNewBook.Sheets(1).Cells(iCount, 1).Value = pcDMISCmd.ID
          objNewBook.Sheets(1).Cells(iCount, 2).Value = vMX
          objNewBook.Sheets(1).Cells(iCount, 3).Value = vMY
          objNewBook.Sheets(1).Cells(iCount, 4).Value = vMZ
          objNewBook.Sheets(1).Cells(iCount, 5).Value = (((vTX - vMX) * vMI) + ((vTY - vMY) * vMJ) + ((vTZ - vMZ) * vMK)) * -1
          
          ' next excel row
          iCount = iCount + 1
        End If
      End If
    Next pcDMISCmd
    
  ' close excel
    objExcel.ScreenUpdating = True
    objExcel.Visible = True
    sPath = "C:\Users\qs\Desktop\TEST.XLSX"
    'objNewBook.SaveAs sPath
    'objExcel.Quit

  ' unDim Something
    Set objNewBook = Nothing
    Set objExcel = Nothing
    Set pcDMISCmd = Nothing
    Set pcDMISCmds = Nothing
    Set pcDMISPart = Nothing
    Set pcDMISApp = Nothing
End Sub