Modul Rastri
Iz SDMS
Jump to navigationJump to searchVsebina
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
