Modul Rastri

Iz SDMS
Skoči na: navigacija, iskanje

Vsebina

Opis

Modul Rastri vsebuje vse potrebne rutine za uvoze, pretvorbe in izvoze rasterskih predlog.

Rutine za skenograme GURS

SetGursRootPath

Nastavi izhodiščni direktorij za GURS skenograme

Uvoz rastrov GURS

uvozi skenograme, ki so imenovani po GURS nomenklaturi

Preveri Rastre GURS

Sub PreveriRastreGurs

Sub PreveriRastreGurs
  Dim SL, SL1 As TStringList
  Dim S As String, I, J, K As Long
  S = GursRootPath
  If InputFolder ('Izberi direktorij, od koder naj se začne iskanje rastrov', S) Then
    SL = CreateStringList
    SL1 = CreateStringList
    SL.FindFiles (S, '*.tfw', True)
    SL1.FindFiles (S, '*x15.tfw', True)
    Log ('Start')
    For I = 0 To SL.Count - 1
      If I % 100 = 0 Then Hint ( 'Uvažam datoteko (' + IntToStr (I + 1) + '/' + IntToStr (SL.Count) + '): ' + SL.Strings (I)) EndIf
      S = UpperCase (ExtractFileName (SL.Strings (I)))
      J = Length (S) - 6
      If Copy (S, J, 1) = '-' Then Continue EndIf //razbita
      If Copy (S, J, 3) = 'X03' Then Continue EndIf //3x
      If Copy (S, J, 3) = 'X15' Then
        S = '*' + Copy (S, 1, 5) + '*' + 'X15*'
        K = 0
        For J = 0 To SL1.Count - 1
          If SL1.Strings (J) Like S Then
            K = K + 1
          EndIf
        next
        If K > 1 Then
          Log ('x' + S)
        EndIf
        Continue
      EndIf //15x
      S = '*' + Copy (S, 1, 5) + '*' + 'X15*'
      For J = 0 To SL1.Count - 1
        If SL1.Strings (J) Like S Then
          Log (S)
        EndIf
      next
    Next
    Log ('Stop')
    Hint (  )
    Destroy (SL)
    Destroy (SL1)
    Beep
  EndIf
EndSub

PreglednaKartaOrtofoto

Sub PreglednaKartaOrtofoto (L As TLayer)
Sub PreglednaKartaOrtofoto (L As TLayer)
  Dim S As String, B, B1 As TBitmap, I, J, K, M as Long, X1, Y1, X2, Y2 As Float
  Dim SL, SL1 As TStringList, RL As TRecordList
  L.Filter.clear
  L.Filter.SQL = '([Oleata ID].AsNumber=22)'
  L.Filter.Execute
  SL = L.FilteredRecords.GroupByLists (L.GetField('List 50k'), Nil, Nil)
  SL1 = CreateStringList
  SL1.Add ('15')
  SL1.Add ('0')
  SL1.Add ('0')
  SL1.Add ('-15')
  SL1.Add ()
  SL1.Add ()
  For M = 0 To SL.Count - 1
    RL = SL.AsClass (M)
    RL.GetBounds (Y1, X1, Y2, X2)
    J = (Y2 - Y1) / 2250 * 150
    K = (X2 - X1) / 3000 * 200
    B1 = CreateBitmap
    B1.Width = J
    B1.Height = K
    For I = 0 To RL.Count - 1
      L.CurrentRecord = RL.Items(I)
      B = CreateBitmap
      S = L.GetField ('Ime datoteke').AsString
      B.Load ( S )
      B.Crop (0, 0, 299, 399)
      B.Resize (150, 200)
      J = (L.CurrentRecord.MinY - Y1) / 2250 * 150
      K = (L.CurrentRecord.MinX - X1) / 3000 * 200
      B.Copy (B1, J, B1.Height - K - 200)
      Destroy (B)
    Next
    B1.Save ( GursRootPath + SL.Strings(M) + '.Tif' )
    SL1.Strings(4) = FloatToStr (Y1 + 7.5)
    SL1.Strings(5) = FloatToStr (X2 - 7.5)
    SL1.Save ( GursRootPath + SL.Strings(M) + '.Tfw' )
    Destroy (B1)
  Next
  SL.DestroyObjects
  Destroy (SL1)
EndSub

Rutine za vse skenograme

Uvoz rastrov Tif/Tfw - Jpg/Jgw

Sub UvozRastrovTifTfw (Ekstenzija As String)

Uvozi TIF/TFW oyiroma JPG/JGW skenograme.

Primer klica za TIF/TFW uvoz.

UvozRastrovTifTfw ('tfw')

Primer klica za JPG/JGW uvoz.

UvozRastrovTifTfw ('jgw')

Rutina:

Sub UvozRastrovTifTfw (Ekstenzija As String)
  Dim L As TLayer, D As TDataSet, Fld As TField, RL As TEditRecord
  Dim B As Boolean, S As String
  Dim SL, FL As TStringList
  Dim I, IW, IH As Long
  Dim PYDim, PXDim, PXOrg, PYOrg, X1, X2, Y1, Y2 As Float
  L = Layers.SelectObject ( 'Izberi plast, v katero naj se uvozijo rastri' )
  If L = Nil Then Exit EndIf
  If L.DataSetCount = 0 Then Exit EndIf
  D = L.DataSets ( 0 )
  If D.FieldCount = 0 Then Exit EndIf
  Fld = D.Fields ( 0 )
  If InputYesNo ('Pozor', 'Ali želiš izbrisati že uvožene rastre?', B) Then
    If B Then
      L.DeleteAllData (False)
    EndIf
  Else
    Exit
  EndIf
  S = GursRootPath
  If InputFolder ('Izberi direktorij, od koder naj se začne iskanje rastrov', S) Then
    SL = CreateStringList
    SL.FindFiles (S, '*.' + Ekstenzija, True)
    FL = CreateStringList
    L.BeginMultipleUpdate
    For I = 0 To SL.Count - 1
      Hint ( 'Uvažam datoteko (' + IntToStr (I + 1) + '/' + IntToStr (SL.Count) + '): ' + SL.Strings (I))
      FL.Load (SL.Strings (I))
      S = ChangeFileExt (SL.Strings (I), '.tif')
      If Not FileExists(S) Then S = ChangeFileExt (SL.Strings (I), '.jpg') EndIf
      If ImageInfo ( S , IW , IH ) Then
        PYDim = StrToFloat (FL.Strings (0))
        PXDim = StrToFloat (FL.Strings (3))
        PYOrg = StrToFloat (FL.Strings (4))
        PXOrg = StrToFloat (FL.Strings (5))
        Y1 = PYOrg - PYDim / 2 + PYDim * IW
        Y2 = PYOrg - PYDim / 2
        X1 = PXOrg - PXDim / 2 + PXDim * IH
        X2 = PXOrg - PXDim / 2
        RL = L.EditRecord
        RL.Append
        RL.SetMap (Y1, X1, Y2, X2)
        RL.AutoCentroid
        RL.FldAsString (Fld) = ExtractRelativePath (GursRootPath, S)
        RL.Update
      EndIf
    Next
    L.EndMultipleUpdate
    L.Optimize
    Hint (  )
    FL.Destroy
    SL.Destroy
    Beep
    Redraw
  EndIf
EndSub

Uvoz rastrov GeoTiff

Sub UvozRastrovGeoTiff

Uvozi Tif datoteke, ki imajo v TIFF tagu shranjeno informacijo o lokaciji.

Rutina:

Sub UvozRastrovGeoTiff
  Dim L As TLayer, D As TDataSet, Fld As TField, RL As TEditRecord
  Dim B As Boolean, S As String
  Dim SL As TStringList, Bi AS TBitmap
  Dim I As Long, Y1, X1, Y2, X2 As Float
  L = Layers.SelectObject ( 'Izberi plast, v katero naj se uvozijo rastri' )
  If L = Nil Then Exit EndIf
  If L.DataSetCount = 0 Then Exit EndIf
  D = L.DataSets ( 0 )
  If D.FieldCount = 0 Then Exit EndIf
  Fld = D.Fields ( 0 )
  If InputYesNo ('Pozor', 'Ali želiš izbrisati že uvožene rastre?', B) Then
    If B Then
      L.DeleteAllData (False)
    EndIf
  Else
    Exit
  EndIf
  S = GursRootPath
  If InputFolder ('Izberi direktorij, od koder naj se začne iskanje rastrov', S) Then
    SL = CreateStringList
    SL.FindFiles (S, '*.tif', True)
    L.BeginMultipleUpdate
    For I = 0 To SL.Count - 1
      Hint ( 'Uvažam datoteko (' + IntToStr (I + 1) + '/' + IntToStr (SL.Count) + '): ' + SL.Strings (I))
      Bi = CreateBitmap
      Bi.Load (SL.Strings (I))
      If Bi.GetGeoInfo (Y1, X1, Y2, X2) Then
        RL = L.EditRecord
        RL.Append
        RL.SetMap (Y1, X1, Y2, X2)
        RL.AutoCentroid
        RL.FldAsString (Fld) = ExtractRelativePath (GursRootPath, SL.Strings (I))
        RL.Update
      EndIf
      Destroy (Bi)
    Next
    L.EndMultipleUpdate
    L.Optimize
    Hint (  )
    Destroy (SL)
    Beep
    Redraw
  EndIf
EndSub

Rutine za izvoz

OknoVTifTfw

Sub OknoVTifTfw (DL As TDrawList, PixDim AS Float)

Naredi Tif in TFW datoteko za okno. Program najprej vpraša za okno, ki se izvozi, potem pa še za datoteko, v katero zapiše slike. Potem program nariše tematiko v to Tif datoteko in naredi še Tfw datoteko, ki vsebuje podatke o lokaciji okna za uvoze v druge programe.

DL je tematika, ki se izriše v datoteko.

PixDim je velikost točke na sliki v metrih.

Primer za izris trenutne tematike z velikostjo točke 0.5 metra:

OknoVTifTfw (Drawlist, 0.5)

Primer za izris poljubne tematike z velikostjo točke 10 metrov:

OknoVTifTfw ([Tematika], 10)

Rutina:

// Naredi Tif in TFW datoteko za okno
Sub OknoVTifTfw (DL As TDrawList, PixDim AS Float)
  Dim Y1, X1, Y2, X2 As Float, S, S1 As String, SL As TStringList
  If InputWindow ('Vnesi območje za izvoz okna', Y1, X1, Y2, X2) Then
    If InputFile ('Določi datoteko za izvoz slike', S) Then
      S1 = ChangeFileExt (ExtractFileName (S), )
      Grid = False
      Coor = False
      Border = False
      DL.SaveImage (ChangeFileExt (S, '.tif'), Y1, X1, Y2, X2, PixDim)
      SL = CreateStringList
      SL.Add (FloatToStr (PixDim))
      SL.Add ('0.0')
      SL.Add ('0.0')
      SL.Add (FloatToStr (-PixDim))
      SL.Add (FloatToStr (MinValue (Y1, Y2) + pixdim/2))
      SL.Add (FloatToStr (MaxValue (X1, X2) - pixdim/2))
      SL.Save (ChangeFileExt (S, '.tfw'))
      Destroy (SL)
    EndIf
  EndIf
EndSub

OknoVJpgJgw

Sub OknoVJpgJgw (DL As TDrawList, PixDim AS Float)

Naredi JPG in JGW datoteko za okno. Program najprej vpraša za okno, ki se izvozi, potem pa še za datoteko, v katero zapiše slike. Potem program nariše tematiko v to Jpg datoteko in naredi še Jgw datoteko, ki vsebuje podatke o lokaciji okna za uvoze v druge programe.

DL je tematika, ki se izriše v datoteko.

PixDim je velikost točke na sliki v metrih.

Primer za izris trenutne tematike z velikostjo točke 0.5 metra:

OknoVJpgJgw (Drawlist, 0.5)

Primer za izris poljubne tematike z velikostjo točke 10 metrov:

OknoVJpgJgw ([Tematika], 10)

Rutina:

// Naredi JPG in JGW datoteko za okno
Sub OknoVJpgJgw (DL As TDrawList, PixDim AS Float)
  Dim Y1, X1, Y2, X2 As Float, S, S1 As String, SL As TStringList
  If InputWindow ('Vnesi območje za izvoz okna', Y1, X1, Y2, X2) Then
    If InputFile ('Določi datoteko za izvoz slike', S) Then
      S1 = ChangeFileExt (ExtractFileName (S), )
      Grid = False
      Coor = False
      Border = False
      DL.SaveImage (ChangeFileExt (S, '.jpg'), Y1, X1, Y2, X2, PixDim)
      SL = CreateStringList
      SL.Add (FloatToStr (PixDim))
      SL.Add ('0.0')
      SL.Add ('0.0')
      SL.Add (FloatToStr (-PixDim))
      SL.Add (FloatToStr (MinValue (Y1, Y2) + pixdim/2))
      SL.Add (FloatToStr (MaxValue (X1, X2) - pixdim/2))
      SL.Save (ChangeFileExt (S, '.jgw'))
      Destroy (SL)
    EndIf
  EndIf
EndSub

IzvozTfw

Naredi TFW datoteke za skenograme v določeni plasti.

Sub IzvozTfw
  Dim I, IW, IH As Long, L As TLayer, F As TField, R As TRecord, SL As TStringList
  If Not SelectLayerFromTreeField (L, F) Then Exit EndIf
  SL = CreateStringList
  For I = 0 To L.AllRecords.Count - 1
    R = L.AllRecords.Items (I)
    F.CurrentRecord = R
    Hint (F.AsString)
    If FileExists (F.AsString) Then
    If ImageInfo (F.AsString, IW , IH ) Then
      SL.Clear
      SL.Add (FloatToStr ((R.MaxY - R.MinY) / IW))
      SL.Add ('0.0')
      SL.Add ('0.0')
      SL.Add (FloatToStr ((R.MinX - R.MaxX) / IH))
      SL.Add (FloatToStr (R.MinY))
      SL.Add (FloatToStr (R.MaxX))
      SL.Save (ChangeFileExt (F.AsString, '.tfw'))
      Hint (ChangeFileExt (F.AsString, '.tfw'))
    EndIf
    EndIf
  Next
  Destroy (SL)
EndSub
Osebna orodja