MapX Tipps 
Public Function IsLayer(Map, Name$) As Boolean
Dim Lyr As MapXLib.Layer
For Each Lyr In Map.Layers
If UCase(Lyr.Name) = UCase(Name) Then IsLayer = True: Exit Function
Next
IsLayer = False
End Function
Public Function IsDataset(Map, Name$) As Boolean
Dim Lyr As MapXLib.Dataset
For Each Lyr In Map.DataSets
If UCase(Lyr.Name) = UCase(Name) Then IsDataset = True: Exit Function
Next
IsDataset = False
End Function
Public Sub MakeDataset(Map, Lyr As Layer, Optional LyrName)
On Error GoTo E1
If IsMissing(LyrName) Then LyrName = Lyr.Name
Map.DataSets.Add miDataSetLayer, Lyr, LyrName
Exit Sub
E1:
If Err.Number <> 1006 And Err.Number <> 1067 Then ShowError "MakeDataset"
End Sub
Private Function lyrPackTable(ByRef m As Map, Lyr As Layer, ByVal FName As String, Optional LayerName As String) As Layer
Dim linfPacked As New LayerInfo
Dim ds As Dataset
For Each ds In m.DataSets
If ds.Layer.Name = Lyr.Name Then Exit For
Next
If ds.Layer.Name <> Lyr.Name Then Exit Function
On Error Resume Next
Kill FName
On Error GoTo 0
linfPacked.Type = miLayerInfoTypeNewTable
linfPacked.AddParameter "Filespec", FName
linfPacked.AddParameter "Fields", ds.fields
linfPacked.AddParameter "Features", Lyr.AllFeatures
If LayerName <> "" Then linfPacked.AddParameter "Name", LayerName
Set lyrPackTable = m.Layers.Add(linfPacked)
End Function
Public Sub AllDatum()
Dim i As Integer, D As New Datum, s$
Open "DatumWGS" For Output As 99
s = "<TABLE BORDER=1><TR><TD>Nr</TD><TD>Ellipsoid</TD><TD>PrimeMeridian</TD><TD>RotateX</TD>"
s = s + "<TD>RotateY</TD><TD>RotateZ</TD><TD>ScaleAdjust</TD><TD>ShiftX</TD><TD>ShiftY</TD>"
s = s + "<TD>ShiftZ</TD></TR><TD>Eccentricity</TD><TD>Flattening</TD><TD>SemiMajorAxis</TD>"
s = s + "<TD>SemiMinorAxis</TD>"
Print #99, s
Do While i < 1111
i = i + 1
If i = 200 Then i = 1000
D.SetFromList i
If D.Ellipsoid <> 28 Then 'WGS84
s = "<TR><TD>" & i & "</TD>"
s = s + "<TD>" & D.Ellipsoid & "</TD>"
s = s + "<TD>" & D.RotateX & "</TD><TD>" & D.RotateY & "</TD><TD>" & D.RotateZ & "</TD>"
s = s + "<TD>" & D.ScaleAdjust & "</TD>"
s = s + "<TD>" & D.ShiftX & "</TD><TD>" & D.ShiftY & "</TD><TD>" & D.ShiftZ & "</TD>"
s = s + "<TD>" & D.Eccentricity & "</TD><TD>" & D.Flattening & "</TD>"
s = s + "<TD>" & D.SemiMajorAxis & "</TD><TD>" & D.SemiMinorAxis & "</TD>"
Print #99, s
End If
Loop: Print #99, "</Table>": Close 99
End Sub
Function FileExist(Datei$) As Boolean
Dim l As Long
On Error Resume Next
If InStr(Datei, "*") Then
If Len(Dir(Datei)) Then FileExist = True
Else
l = FileLen(Datei)
FileExist = Not (Err.Number > 0)
End If
On Error GoTo 0
End Function
Public Sub KillLayer(B$)
Dim A$
A = B & "."
If FileExist(A + "TAB") Then Kill A + "TAB"
If FileExist(A + "DAT") Then Kill A + "DAT"
If FileExist(A + "ID") Then Kill A + "ID"
If FileExist(A + "MAP") Then Kill A + "MAP"
End Sub
Koordinatentransformation mit MapX
Startsystem mit Koordinaten übergeben, Zielsystem ist hier fest (Bessel 3.Streifen).
Public Sub ToGK3(Lsys As String, y#, x#, y3#, x3#)
Dim pt As New Point, ft As New Feature
SetLSys Lsys, Map1
pt.Set y, x: Set ft = Map1.FeatureFactory.CreateSymbol(pt)
SetLSys "DA0", Map1
y3 = ft.CenterX: x3 = ft.CenterY
End Sub
Public Sub SetLSys(a$, Map As MapXLib.Map)
Dim coord As New MapXLib.CoordSys
If a = "" Then Exit Sub
Select Case UCase(Left(a, 2))
Case "GPS": Map.NumericCoordSys.Set 1, 104: Exit Sub
Case "FS": coord.Set 30, 1000, 7, 13.62720367, 52.41864828, 0, 0, 0, 1, 40000, 10000
Case "CA", "CB", "CR": coord.Set 8, 1000, 7, 6, 0, 0, 0, 0, 0, 2500000, 0
Case "DA", "DB", "DR": coord.Set 8, 1000, 7, 9, 0, 0, 0, 0, 0, 3500000, 0
Case "EA", "EB", "ER": coord.Set 8, 1000, 7, 12, 0, 0, 0, 0, 0, 4500000, 0
Case "FA", "FB", "FR": coord.Set 8, 1000, 7, 15, 0, 0, 0, 0, 0, 5500000, 0
Case "CC": coord.Set 8, 1001, 7, 6, 0, 0, 0, 0, 0, 2500000, 0
Case "DC": coord.Set 8, 1001, 7, 9, 0, 0, 0, 0, 0, 3500000, 0
Case "EC": coord.Set 8, 1001, 7, 12, 0, 0, 0, 0, 0, 4500000, 0
Case "FC": coord.Set 8, 1001, 7, 15, 0, 0, 0, 0, 0, 5500000, 0
End Select
Map.NumericCoordSys = coord
AktLsys = a
End Sub
Public Sub ToMdb(f As Form, LayerName$)
Dim ds As MapXLib.Dataset, Lyr As MapXLib.Layer, ftrs As Features, ftr As Feature, rv As RowValue, rvs As RowValues
Dim DsRows As Long, DsCols As Long, i As Long, J As Long
Dim db As Database, dy As Recordset, Sql$, t$, typ%, A$, W%, D%
On Error GoTo E2
'
Set Lyr = frmMain.Map1.Layers(LayerName)
MakeDataset frmMain.Map1, Lyr
Set ds = frmMain.Map1.DataSets.Item(LayerName)
f.Data1.Caption = ds.Name & " Datensätze:" & ds.RowCount
Sql = "CREATE TABLE[" & LayerName & "]("
Set ftrs = Lyr.AllFeatures
DsCols = ds.fields.Count + 1
DsRows = ftrs.Count
For i = 0 To DsCols - 2
t = "[" & ds.fields.Item(i + 1).Name & "]"
'typ = ds.Fields.Item(i + 1).Type
typ = ds.fields.Item(i + 1).TypeEx
Select Case typ
Case 0: A = "Text" 'String
Case 1: A = "Double" 'Numeric
Case 2: A = "Date" 'Datum
Case 3: A = "Long" 'Integer
Case 4: A = "Short" 'SmallInteger
Case 5: A = "Double" 'Double
Case 6: A = "Boolean" 'Boolean
End Select
If typ = 1 Then
W = ds.fields.Item(i + 1).Precision
D = ds.fields.Item(i + 1).Decimals
ElseIf typ = 0 Then
W = ds.fields.Item(i + 1).Width: A = A & "(" & W & ")"
End If
If i > 0 Then Sql = Sql + ","
Sql = Sql + t + A
Next: Sql = Sql + ",[FeatureKey]Long)"
On Error Resume Next
Set db = CreateDatabase(App.Path & "\Mein.mdb", dbLangGeneral, dbVersion30)
'On Error GoTo E2
Set db = OpenDatabase(App.Path & "\Mein.mdb", False, False, "")
db.Execute Sql
db.Execute "Delete * from " & LayerName
db.Execute ("alter table " & LayerName & " add column CenterX double;")
db.Execute ("alter table " & LayerName & " add column CenterY double;")
Set dy = db.OpenRecordset(LayerName)
Lyr.BeginAccess miAccessRead
i = 1
For Each ftr In ftrs
Set rvs = ds.RowValues(ftr)
dy.AddNew
For J = 0 To rvs.Count - 1
Set rv = rvs(J + 1)
If Not IsNull(rv.Value) Then
If dy(J).Type = dbText Then
dy(J) = rv.Value
Else
dy(J) = rv.Value
End If
End If
Next
dy(J) = ftr.FeatureKey: dy("centerx") = ftr.CenterX: dy("centery") = ftr.CenterY: dy.Update
i = i + 1
Next
Lyr.EndAccess miAccessEnd
MsgBox i & " Elemente in Tabelle " & LayerName & " exportiert -- "
e1: On Error GoTo 0: Exit Sub
E2: ShowError: Resume e1
End Sub
Breite und Höhe auf TIF_Header
Sub GetTif(Datei$, W&, H&)
'H. Adelt 20.04.2004
'W=Breite, H=Höhe aus TIF-HEADER
'Datei = "D:\temp\1040\1040eo.tif"
Dim A$, L&
Close 2: Open Datei For Binary As 2
Seek 2, 5: A = Input(4, 2)
L = (Asc(Mid(A, 1, 1)) + Asc(Mid(A, 2)) * 256#) + 21
Seek 2, L: A = Input(4, 2)
W = (Asc(Mid(A, 3, 1)) + Asc(Mid(A, 4)) * 256#)
Seek 2, L + 12: A = Input(4, 2)
H = (Asc(Mid(A, 3, 1)) + Asc(Mid(A, 4)) * 256#): Close 2
End Sub
Dipl.-Ing. Hans Adelt
