Programming Tool Box/SIMS_2.iso/code/cdspy/pars_my.bas

BASIC Source File | 1995-02-27 | 27KB | 878 lines

' Variablendeklaration erzwingen
Option Explicit
' Textvergleiche erfolgen ohne Rⁿcksicht auf Gross/Kleinschreibung
Option Compare Text

' ----------------------------
' - Benutzerdefinierte Typen -
' ----------------------------

Type TM_OutlineRec
  Bezeichnung As String * 25
  hat_unter_obj As Integer
  Vaterobj As Long
  Kind As Long
  Vor As Long
  Nach As Long
  Pfad As String * 128
  Ebene As Integer
  Visible As Integer
End Type

Type TM_DBRec
  Bezeichnung As String * 35
  Vater As Long
  Verzeichnis As String * 128
  Code As Integer
End Type

Type TM_WordsRec
  wort As String * 50
End Type

Type TM_OccursRec
  ID_Wort As Long
  ID_Spy As Long
  filename As String * 12
End Type

Type TM_Worte
  wort As String * 50
  ID As Long
End Type

Type TM_AktElement
  Info As String
  Startfile As String
  Demofile As String
  Readmefile As String
  Verzeichnis As String
  Code As Integer
  SetupCommand As String
  Hilfefile As String
  Copy As Integer
End Type

' ---------------------
' - globale Variablen -
' ---------------------

' zuletzt mit FM_LiesDB gelesenen Datensatz
Global GM_DB As TM_DBRec
' gesamte Datenbank
Global GM_DBAll() As TM_DBRec
' Pfad der Datei CDINFO
Global G_CDInfoFile As String
' diverses
Global G_Control As Control
' Pfad des im Editor anzuzeigenden Files
Global G_EditFile As String
' Liste der zu kopierenden Dateien
Global G_CopyFiles As String
' Liste aller benutzer W÷rter (Wird in der prod. Version nicht ben÷tigt!)
Global G_Worte() As TM_Worte
' CD-Laufwerk
Global GM_Drive As String * 2
' Spy-Datenbank Dateiname
Global GM_DBName As String * 12
' W÷rterdatenbank Dateiname
Global GM_DBWorte As String * 40
' Vorkommendatenbank Dateiname
Global GM_DBOccurs As String * 40
' Array das alle gefundenen Stichwortpositionen enthΣlt
Global GM_Occurs() As TM_OccursRec
' Flags
Global GM_Refresh As Integer
' Aktuell ausgewΣhltes Element
Global GM_AktElement As TM_AktElement
' Suchtext nach dem die aktuelle Suche erfolgt
Global GM_Searchtext As String
' Dateihandle fⁿr die Datenbank SPY.DAT
Global GM_FH_DBName As Integer
' Fensterbezeichnung fⁿr F_Search
Global GM_Searchtitle As String
' Suchstring um im Editor weitersuchen zu k÷nnen
Global GM_SeekString As String
' Flag, ob der Editor ein ⁿbergrosses File enthΣlt
Global GM_HugeFile As Integer

' ----------------------
' - globale Konstanten -
' ----------------------

' Dateinamen
Global Const GCM_INFOFILENAME = "CDINFO.TXT"
Global Const GCM_DBNAME = "N:\SPY.DAT"

' CDInfo.TXT Topics
Global Const GCM_VERZEICHNIS = "VERZEICHNIS="
Global Const GCM_PROJEKT = "PROJEKT="
Global Const GCM_INFO = "INFO="
Global Const GCM_DEMO = "DEMO="
Global Const GCM_INSTALL = "INSTALL="
Global Const GCM_STARTABLE = "STARTABLE="
Global Const GCM_README = "README="

' Allgemeine Konstanten
Global Const GCM_SEPERATOR = ","
Global Const GCM_OWNER_ERROR = 32767

' INI-Datei Topics
Global Const GCM_EINSTELLUNGEN = "Einstellungen"
Global Const GCM_SPLITT = "Splitt"

' SchaltflΣchen im Cmd_Array
Global Const GCM_CMD_INFO = 0
Global Const GCM_CMD_START = 1
Global Const GCM_CMD_DEMO = 2
Global Const GCM_CMD_COPY = 3
Global Const GCM_CMD_INSTALL = 4
Global Const GCM_CMD_CODE = 5
Global Const GCM_CMD_HILFE = 6
Global Const GCM_CMD_README = 7

' Konstanten fⁿr Textboxhandling
Global Const ON_TAB = 1
Global Const ON_ALT = 2
Global Const ON_MOUSE = 3
Global Const ON_ELSE = 4

' allgemeine Konstanten
Global Const GCM_ENABLE = -1
Global Const GCM_DISABLE = 0
Global Const GCM_STICHWORTSUCHE = "Stichwortsuche"
Global Const GCM_TITELTEXTSUCHE = "Titeltextsuche"

' ---------------------
' - API-Deklarationen -
' ---------------------

Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As String) As Long
Declare Function GetModuleUsage Lib "KERNEL" (ByVal InstanceID%) As Integer
Declare Function EnableWindow% Lib "User" (ByVal hWnd%, ByVal aBOOL%)
Declare Function GetProfileString Lib "Kernel" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer) As Integer
Declare Function GetAsyncKeyState Lib "User" (ByVal vKey As Integer) As Integer

' ------------------------------------------------------------------
' Erzeugt das ⁿbergebene Unterverzeichnis verz$.
' ------------------------------------------------------------------
Function FM_CreateDirectory (verz$)
  Dim L_TmpVerz$, L_Verz$, L_Res%, L_TmpDrive$

  On Error GoTo Err_FM_CreateDirectory
  If FM_ExistDir(verz$) Then
    FM_CreateDirectory = 2
    Exit Function
  End If
  L_Res% = True
  L_TmpDrive$ = CurDir$
  ChDrive verz$
  L_TmpVerz$ = CurDir$
  ChDir "\"
  L_Verz$ = FM_ParseZeile(verz$, "\")
  Do While L_Verz$ <> ""
    L_Verz$ = Left$(FM_ParseZeile("", ""), 8)
    If L_Verz$ <> "" Then
      MkDir (L_Verz$)
      ChDir (L_Verz$)
    End If
  Loop
  ChDrive verz$
  ChDir (L_TmpVerz$)
  ChDir (L_TmpDrive$)
Ende_FM_CreateDirectory:
    FM_CreateDirectory = L_Res%
  Exit Function
Err_FM_CreateDirectory:
  Select Case Err
    Case Is = 75
      Resume Next
    Case Else
      MsgBox "Das gewⁿnschte Verzeichnis konnte gar nicht oder nur teilweise erstellt werden! Die Funktion wird abgebrochen!", 48, "Fehler"
  End Select
  L_Res% = False
  Resume Ende_FM_CreateDirectory
End Function

' --------------------------------------------------------
' True, wenn das Verzeichnis Dirn$ existiert, sonst false
' --------------------------------------------------------
Function FM_ExistDir% (Dirn$)
  Dim L_Dir$
  On Error Resume Next
  L_Dir$ = Dir$(Dirn$, 16)
  If (Err <> 0) Or (L_Dir$ = "") Then
    FM_ExistDir% = False
  Else
    FM_ExistDir% = True
  End If
End Function

' --------------------------------------------------------
' Liefert True, wenn die Datei Dn$ existiert sonst false
' --------------------------------------------------------
Function FM_exists% (dn$)
  Dim L_Dir$
  On Error Resume Next
  L_Dir$ = Dir$(dn$, 32)
  FM_exists = Not ((Err <> 0) Or (L_Dir$ = "") Or (Right$(dn$, 1) = "\"))
End Function

Function FM_GetAktInfo () As String
  FM_GetAktInfo = GM_AktElement.Info$
End Function

Function FM_GotFocusON ()
  Const KEY_TAB = &H9
  Const KEY_MENU = &H12
  Const KEY_LBUTTON = &H1
  If GetAsyncKeyState(KEY_MENU) = &H8001 Then
    FM_GotFocusON = ON_TAB
  ElseIf GetAsyncKeyState(KEY_MENU) = &H8001 Then
    FM_GotFocusON = ON_ALT
  ElseIf GetAsyncKeyState(KEY_LBUTTON) = &H8001 Then
    FM_GotFocusON = ON_MOUSE
  Else
    FM_GotFocusON = ON_ELSE
  End If
End Function

' --------------------------------------------------------
' Liest aus der Datei GCM_DBNAME den Datensatz an der
' Stelle ID& und liefert entweder die Position des ge-
' lesenen Datensatzes oder 0 zurⁿck (Positionen von 1 bis)
' --------------------------------------------------------
Function FM_LiesDB (ID&)
  On Error Resume Next
  If ID& > 0 Then
    If ID& <= UBound(GM_DBAll) Then
      If GM_DBAll(ID&).Verzeichnis <> "" Then
        Get #GM_FH_DBName%, ID&, GM_DB
      Else
        GM_DB = GM_DBAll(ID&)
      End If
      FM_LiesDB = ID&
    Else
      FM_LiesDB = 0
    End If
  End If
End Function

' --------------------------------------------------------
' Liefert die gr÷ssere der beiden Zahlen x und y
' --------------------------------------------------------
Function FM_Max (x, Y)
  If x > Y Then
    FM_Max = x
  Else
    FM_Max = Y
  End If
End Function

' --------------------------------------------------------
' Liefert die kleinere der beiden Zahlen x und y
' --------------------------------------------------------
Function FM_Min (x, Y)
  If x < Y Then
    FM_Min = x
  Else
    FM_Min = Y
  End If
End Function

' --------------------------------------------------------
' Die Funktion Parse_Zeile liefert aus einer gegebenen
' Zeile die Zeichenkette bis zum ersten Zeichen ch$ zurⁿck
' und reduziert die Zeile auf den nachfolgenden Teil der
' Zeile ▄ber den Parameter Zeile$ wird die Zeile zur Initia-
' lisierung ⁿbergeben. Zum Abrufen der Werte wird ein
' Leerstring als Zeile$ ⁿbergeben
' --------------------------------------------------------
Function FM_ParseZeile$ (zeile$, ch$)
  Static L_Txt$, L_Zch$
  Dim L_Tmp$
  ' Eine Zeile$ ungleich "" bedeutet Initialisierung
  If zeile$ <> "" Then
    ' Zeile initialisieren
    L_Txt$ = zeile$ + ch$
    L_Zch$ = ch$
  End If
  If Trim$(L_Txt$) <> "" Then
    ' Zeichenkette bis zum ersten Separator bestimmen
    L_Tmp$ = Left$(L_Txt$, InStr(L_Txt$, L_Zch$) - 1)
    ' Zeile auf Teil nach erstem Separator reduzieren
    L_Txt$ = LTrim$(Mid$(L_Txt$, InStr(L_Txt$, L_Zch$) + 1))
  End If
  FM_ParseZeile$ = L_Tmp$
End Function

' ------------------------------------------------------------------------
' Liefert True, wenn die Formen bei einem Refresh neue Daten holen sollen
' ------------------------------------------------------------------------
Function FM_Refresh% ()
  FM_Refresh% = GM_Refresh%
End Function

' --------------------------------------------------------
' HΣngt den Datensatz GM_DB an die Datenbank GCM_DBNAME an
' und liefert die Position des geschriebenen Datensatzes
' zurⁿck
' --------------------------------------------------------
Function FM_SchreibDB ()
  Dim L_FilePosition%
  L_FilePosition% = (LOF(GM_FH_DBName%) / Len(GM_DB)) + 1
  Put #GM_FH_DBName%, L_FilePosition%, GM_DB
  FM_SchreibDB = L_FilePosition%
End Function

' --------------------------------------------------------
' Kⁿrzt den Dateinamen in Filename$ so, dass dieser in
' den ⁿbergebenen Label hineinpasst.
' --------------------------------------------------------
Function FM_ShortFilename$ (Bezeichner As Form, MaxLΣnge%, filename$)
  Dim L_Filename$
  Dim L_Pos%, L_Pos2%
  If Bezeichner.TextWidth(filename$) <= MaxLΣnge% Then
    L_Filename$ = filename$
  Else
    L_Filename$ = filename$
    L_Pos% = InStr(L_Filename$, "\")
    L_Pos2% = InStr(L_Pos% + 1, L_Filename$, "\")
    Do While L_Pos% > 0 And L_Pos2% > 0 And Bezeichner.TextWidth(L_Filename$) > MaxLΣnge%
      L_Filename$ = Left$(L_Filename$, L_Pos%) & "..." & Mid$(L_Filename$, L_Pos2%)
      L_Pos2% = InStr(L_Pos% + 5, L_Filename$, "\")
    Loop
  End If
  FM_ShortFilename$ = L_Filename$
End Function

' --------------------------------------------------------
' Liefert die Zeichenkette Verz$ mit abschliessendem \
' falls dieser nicht bereits vorhanden ist
' --------------------------------------------------------
Function FM_Verz$ (verz$)
  Dim L_Verz$
  L_Verz$ = Trim$(verz$)
  If Right$(L_Verz$, 1) <> "\" Then
    L_Verz$ = L_Verz$ + "\"
  End If
  FM_Verz$ = L_Verz$
End Function

' --------------------------------------------------------
' L÷scht die Datenbank GCM_DBNAME
' --------------------------------------------------------
Sub PM_ClearDB ()
  Close
  Kill GCM_DBNAME
  Open GCM_DBNAME For Random As GM_FH_DBName% Len = Len(GM_DB)
End Sub

' ----------------------------------------------------------------------
' L÷scht das globale Array der gefundenen Stichworte
' ----------------------------------------------------------------------
Sub PM_ClsFound ()
  ReDim GM_Occurs(0)
End Sub

' --------------------------------------------------------
'
' --------------------------------------------------------
Sub PM_DateiKopieren ()
Rem kopieren der Dateien von der CD aufs Ziellaufwerk

Dim Pfad$
Dim zielpfad$
Dim doscommand$
Dim filename$
Dim stat As Integer
Dim Msg$
Dim begpos As Integer
Dim endpos As Integer
Dim temppath$
Dim file$
Dim filelist$
Dim i As Integer
Dim Ct As Integer
Dim index As Integer
Dim G_Laufwerk$

    On Error Resume Next

Rem kopieren
    ' bilden des Quellpfades
    'F_copy.MousePointer = 11
    'Pfad$ = G_Laufwerk$ + F_Main.Data1.Recordset.Fields("Pfad") + "\"
    'zielpfad$ = Trim$(F_copy.Text1.Text)
    If Right$(zielpfad$, 1) <> "\" Then
        If Right$(zielpfad$, 3) = "*.*" Then
            zielpfad$ = Left$(zielpfad$, Len(zielpfad$) - 3)
        Else
            zielpfad$ = zielpfad$ + "\"
        End If
    End If

    begpos = 4
    Do While begpos < Len(zielpfad$)       ' directories suchen und erstellen
        endpos = InStr(begpos, zielpfad$, "\")
        If endpos = 0 Then
            Exit Do
        End If
        temppath$ = Mid$(zielpfad$, 1, endpos - 1)
        MkDir temppath$                     ' Make new directory.
        Msg$ = ""
        If Err = 75 And endpos = Len(zielpfad$) Then Msg$ = temppath$ & " Verzeichnis existiert bereits." + Chr$(13) + "(bestehende Dateien werden ⁿberschrieben)"' Check if directory exists.
        If Err = 57 Then Msg$ = "GerΣte Ein-/Ausgabefehler."
        If Err = 61 Then Msg$ = "DatentrΣger voll."
        If Err = 76 Then Msg$ = "Pfad nicht gefunden."
        If Err = 70 Then Msg$ = "Zugriff nicht gestattet."
        Err = 0
        If Msg$ <> "" Then
            stat = MsgBox(Msg$, 49, "CD Spy")
            If stat = 2 Then
                'F_copy.MousePointer = 0
                Exit Sub
            End If
        End If

        begpos = endpos + 1
    Loop

    stat = 0
    'P_Copyfiles Pfad$, zielpfad$, stat            ' Dateien kopieren
    If stat <> 0 Then
        'F_copy.MousePointer = 0
        Exit Sub
    End If

    'F_copy.Hide

    'F_copy.Text1.SetFocus                   ' nicht kopieren
    'F_copy.MousePointer = 0

End Sub

' --------------------------------------------------------
' Kopiert die gewⁿnschten Dateien
' --------------------------------------------------------
Sub PM_FileCopy ()

End Sub

' --------------------------------------------------------
' Analysiert den Inhalt der aktuellen Datei CDINFO.TXT in
' die Struktur d ein.
' #miki
' --------------------------------------------------------
Sub PM_GetCDINFO (d As TM_DBRec)
  Dim L_Tmp$, L_FileHandle%, L_Zeile$, L_Pos%, L_CDInfoDatei$
  L_CDInfoDatei$ = FM_Verz$(d.Verzeichnis$) + GCM_INFOFILENAME
  L_FileHandle% = FreeFile
  On Error Resume Next
  Open L_CDInfoDatei$ For Input As L_FileHandle%
  ' Konnte Datei nicht ge÷ffnet werden Abbruch
  If Err <> 0 Then Exit Sub
  If Not EOF(L_FileHandle%) Then
    Line Input #L_FileHandle%, L_Zeile$
    L_Pos% = InStr(UCase$(L_Zeile$), GCM_VERZEICHNIS)
    If L_Pos% Then
      d.Bezeichnung$ = Mid$(L_Zeile$, L_Pos% + Len(GCM_VERZEICHNIS))
    End If
    If Not EOF(L_FileHandle%) Then
      Line Input #L_FileHandle%, L_Zeile$
      L_Pos% = InStr(UCase$(L_Zeile$), GCM_PROJEKT)
      If L_Pos% Then
        d.Code = 1
      Else
        d.Code = 0
      End If
    End If
  End If
  Close L_FileHandle%
End Sub

' --------------------------------------------------------
' Liefert im Array d() alle VΣter
' --------------------------------------------------------
Sub PM_GetParents (ID&, d())
  Dim i%
  For i% = 1 To LOF(GM_FH_DBName%) / Len(GM_DB)
    Get GM_FH_DBName%, i%, GM_DB
    If GM_DB.Vater = ID& Then
      d(UBound(d)) = i%
      ReDim Preserve d(UBound(d) + 1)
    End If
  Next i%
End Sub

' --------------------------------------------------------
' Liest die Datei CDINFO im Verzeichnis$ in die globale
' Variable G_CDInfoFile$ ein
' --------------------------------------------------------
Sub PM_LiesCDInfo (Verzeichnis$)
  Dim L_FileHandle%
  Dim L_LΣnge&
  Dim L_CDInfoFilename$
  On Error Resume Next
  L_CDInfoFilename$ = FM_Verz$(Verzeichnis$) & GCM_INFOFILENAME
  L_LΣnge& = FileLen(L_CDInfoFilename$)
  G_CDInfoFile$ = Space$(L_LΣnge&)
  L_FileHandle% = FreeFile
  Open L_CDInfoFilename$ For Binary As L_FileHandle% Len = L_LΣnge&
  Get #L_FileHandle%, , G_CDInfoFile$
  Close L_FileHandle%
End Sub

' --------------------------------------------------------
' Liest den Verzeichnisbaum vom Verzeichnis Path$ an in
' das Array d ein. Wird fⁿr die Endversion nicht ben÷tigt
' --------------------------------------------------------
Sub PM_ListSubDirs (path$, d() As TM_DBRec)
  Const ATTR_DIRECTORY = 16
  Dim position%, Count%, Vater%

  Dim i, dirname

  On Error Resume Next
  If Right$(path$, 1) <> "\" Then path$ = path$ + "\"
  If FM_ExistDir(path$) Then
    position% = 1
    Count% = 1
    dirname = Dir(path, ATTR_DIRECTORY) ' Erster Verzeichnisname

    'Alle Verzeichnisse innerhalb dieses Verzeichnisses in D() speichern
    ReDim d(Count%)
    d(Count%).Verzeichnis$ = path$
    d(Count%).Vater = 0
    'PM_GetCDINFO d(Count%)
    Count% = Count% + 1
    Do
      Do While dirname <> ""
        DoEvents
        If dirname <> "." And dirname <> ".." Then
          If (GetAttr(path + dirname) And ATTR_DIRECTORY) = ATTR_DIRECTORY Then
            ReDim Preserve d(Count%)
            d(Count%).Verzeichnis = path + dirname
            d(Count%).Vater = position%
            PM_GetCDINFO d(Count%)
            Count% = Count% + 1
          End If
        End If
        dirname = Dir   ' Get another directory name.
      Loop
      position% = position% + 1
      If position% >= Count% Then Exit Do
      path$ = Trim$(d(position%).Verzeichnis$) + "\"
      dirname = Dir(path, ATTR_DIRECTORY)
    Loop
  End If
End Sub

Sub PM_LookforExt (ReSourceName$)
  Dim nItemFound As Integer
  Dim AppPathSize As Long
  Dim sExtType, ApptoLaunch  As String
  Dim sAssocApp$
  Dim LaunchApp, Y As Integer
  On Error GoTo Err_PM_LookforExt
  sExtType = Right$(ReSourceName, 3)  ' Extension lesen
  ' ⁿbereinstimmenden Eintrag in WIN.INI [Extensions] suchen
  sAssocApp = Space$(256)
  nItemFound = GetProfileString("Extensions", ByVal sExtType, "", sAssocApp, Len(sAssocApp))
  If nItemFound = 0 Then
    GoTo Err_PM_LookforExt
  Else
    ' Applikationsname und Pfad extrahieren
    sAssocApp = RTrim(sAssocApp)
    AppPathSize = Len(sAssocApp)
    AppPathSize = AppPathSize - 6
    ApptoLaunch = Left(sAssocApp, AppPathSize)
    LaunchApp = Shell((ApptoLaunch + ReSourceName), 1)
    Do While GetModuleUsage(LaunchApp) > 0
      Y% = DoEvents()
    Loop
  End If
  Exit Sub
Err_PM_LookforExt:
  Error GCM_OWNER_ERROR
  Exit Sub
End Sub

Sub PM_NewWord (wort$, DS_Worte As Dynaset, DS_Occurs As Dynaset, VerzPos%)
  Dim i%, ub%
  On Error Resume Next
  DS_Worte.AddNew
  DS_Worte!wort = wort$
  DS_Worte.Update
  If Err <> 0 Then
    Err = 0
    DS_Worte.FindFirst ("Wort = '" & wort$ & "'")
  Else
    DS_Worte.MoveLast
  End If
  DS_Occurs.AddNew
  DS_Occurs!ID = VerzPos%
  DS_Occurs!ID_Wort = DS_Worte!ID
  DS_Occurs.Update
End Sub

' --------------------------------------------------------
' Zerlegt den ⁿbergebenen String in einzelne Worte und
' fⁿgt diese an die globale W÷rterliste G_Worte an.
' --------------------------------------------------------
Sub PM_Parse (x As String, DS_Worte As Dynaset, DS_Occurs As Dynaset, VerzPos%)
  Dim i%, zch%, l%
  Dim wort$, zeichen$
  For i% = 1 To Len(x)
    zeichen$ = Mid$(x, i%, 1)
    zch% = Asc(UCase$(zeichen$))
    If zch% >= 65 And zch% <= 90 Or zch% = 196 Or zch% = 214 Or zch% = 220 Then
      wort$ = wort$ + zeichen$
      l% = l% + 1
    Else
      If Trim(wort$) <> "" And l% > 2 And l% < 51 Then
        PM_NewWord LCase(wort$), DS_Worte, DS_Occurs, VerzPos%
      End If
      wort$ = ""
      l% = 0
    End If
  Next i%
End Sub

Sub PM_ReadDBAll ()
  Dim i&, Res&
  For i& = 1 To UBound(GM_DBAll)
    Res& = FM_LiesDB(i&)
    GM_DBAll(i&) = GM_DB
    DoEvents
  Next i&
End Sub

' -----------------------------------------------------------------------
' Bestimmt, ob eine Form tatsΣchlich in einem Refresh Ereignis neue Daten
' anzeigen soll.
' -----------------------------------------------------------------------
Sub PM_Refresh (mode As Integer)
  GM_Refresh% = mode%
End Sub

Sub PM_RefreshForms ()
  Dim i%
  On Error Resume Next
  PM_Refresh GCM_ENABLE
  For i% = 0 To Forms.Count
    Forms(i%).Refresh
  Next i%
  PM_Refresh GCM_DISABLE
End Sub

Sub PM_ScanFile (filename$, DS_Worte As Dynaset, DS_Occurs As Dynaset, VerzPos%)
  Dim FileHandle%
  Dim zeile$
  Dim i%
  Const LC_MAX = 32000
  'Debug.Print "Scanstart : "; Timer
  ReDim G_Worte(0)
  FileHandle% = FreeFile
  Open filename$ For Binary As FileHandle%
  For i% = 1 To LOF(FileHandle%) \ LC_MAX
    zeile$ = Space$(LC_MAX)
    Get #FileHandle%, (i% - 1) * LC_MAX + 1, zeile$
    PM_Parse zeile$, DS_Worte, DS_Occurs, VerzPos%
  Next i%
  zeile$ = Space$((LOF(FileHandle%) Mod LC_MAX))
  Get #FileHandle%, (i% - 1) * LC_MAX + 1, zeile$
  PM_Parse zeile$, DS_Worte, DS_Occurs, VerzPos%
  Close FileHandle%
  Debug.Print "Scanend : "; Timer
End Sub

' --------------------------------------------------------
' Positioniert das Steuerelement Cntrl auf den Eintrag$
' --------------------------------------------------------
Sub PM_SeekList (Cntrl As Control, Eintrag$)
  Const LC_CB_FINDSTRINGEXACT = &H400 + 24
  ' SendMessage liefert die Position resp. -1 des Eintrages
  Cntrl.ListIndex = SendMessage(Cntrl.hWnd, LC_CB_FINDSTRINGEXACT, -1, Eintrag$)
End Sub

' --------------------------------------------------------
' Schⁿtzt die ⁿbergebene Textbox vor dem ⁿberschreiben
' --------------------------------------------------------
Sub PM_SetReadOnly (Ctrl As TextBox)
  Dim Res&
  Const WM_USER = &H400
  Const EM_SETREADONLY = WM_USER + 31
  Res& = SendMessage(Ctrl.hWnd, EM_SETREADONLY, -1, "")
End Sub

' --------------------------------------------------------
' Wartet bis das Programm beendet worden ist
' --------------------------------------------------------
Sub PM_ShellAndWait (CommandString$)
  Dim L_ID%
  L_ID% = Shell(CommandString$, 2)
  Do
    DoEvents
  Loop Until GetModuleUsage(L_ID%) = 0
End Sub

' --------------------------------------------------------
' 3D-Effekt auf Formen mit ScaleMode = Pixel
' --------------------------------------------------------
Sub PM_show3d (Frm As Form)
' Colors

Const BLACK = &H0&
Const WHITE = &HFFFFFF
Const GRAY = &HC0C0C0
Const DGRAY = &H808080

Dim Ct As Control
Dim i As Integer

Frm.AutoRedraw = True
Frm.Cls
' Zeichne Formular
Frm.BackColor = &HC0C0C0
If Frm.BorderStyle = 0 Or Frm.BorderStyle = 1 Or Frm.BorderStyle = 3 Then
    Frm.DrawWidth = 2
    Frm.Line (0, 0)-(Frm.ScaleWidth, Frm.ScaleHeight), DGRAY, B
    Frm.DrawWidth = 1
    Frm.Line (0, 0)-(Frm.ScaleWidth, Frm.ScaleHeight), WHITE, B
End If

For i = 0 To Frm.Controls.Count - 1
    Set Ct = Frm.Controls(i)
    If Ct.Visible Then
      If TypeOf Ct Is Shape Then
          Ct.Visible = False
          Frm.DrawWidth = 2
          Frm.Line (Ct.Left, Ct.Top)-(Ct.Width + 1 + Ct.Left, Ct.Top + Ct.Height), DGRAY, B
          Frm.DrawWidth = 1
          Frm.Line (Ct.Left - 1, Ct.Top - 1)-(Ct.Width + Ct.Left, Ct.Top + Ct.Height - 1), WHITE, B
      End If
      If TypeOf Ct Is PictureBox Then
          Frm.Line (Ct.Left + (1), Ct.Top + (1))-(Ct.Width + Ct.Left, Ct.Top + Ct.Height), WHITE, B
          Frm.Line (Ct.Left - (1), Ct.Top - (1))-(Ct.Width + (1) + Ct.Left, Ct.Top + Ct.Height + (1)), DGRAY, B
          Frm.Line (Ct.Left - (2), Ct.Top - (2))-(Ct.Width + Ct.Left + (1), Ct.Top + Ct.Height + (1)), GRAY, B
      End If
      If TypeOf Ct Is Label Then

          Frm.FontSize = Ct.FontSize
          Frm.FontName = Ct.FontName
          Frm.FontBold = Ct.FontBold
          Ct.Visible = False
          Frm.CurrentX = Ct.Left + 1
          Frm.CurrentY = Ct.Top + 1
          Frm.ForeColor = WHITE
          Frm.Print Ct.Caption
          Frm.CurrentX = Ct.Left
          Frm.CurrentY = Ct.Top
          Frm.ForeColor = BLACK
          Frm.Print Ct.Caption
          Ct.Visible = True
      End If
      If TypeOf Ct Is TextBox Then
          Frm.Line (Ct.Left + 1, Ct.Top + 1)-(Ct.Width + Ct.Left, Ct.Top + Ct.Height), WHITE, B
          Frm.Line (Ct.Left - 1, Ct.Top - 1)-(Ct.Width + 1 + Ct.Left, Ct.Top + Ct.Height + 1), DGRAY, B
          Frm.Line (Ct.Left - 2, Ct.Top - 2)-(Ct.Width + Ct.Left + 1, Ct.Top + Ct.Height + 1), GRAY, B
      End If
      If TypeOf Ct Is ListBox Then
          Frm.Line (Ct.Left + 1, Ct.Top + 1)-(Ct.Width + Ct.Left, Ct.Top + Ct.Height), DGRAY, B
          Frm.Line (Ct.Left - 1, Ct.Top - 1)-(Ct.Width + 1 + Ct.Left, Ct.Top + Ct.Height + 1), WHITE, B
          Frm.Line (Ct.Left - 2, Ct.Top - 2)-(Ct.Width + Ct.Left + 1, Ct.Top + Ct.Height + 1), GRAY, B
      End If
      If TypeOf Ct Is ComboBox Then
          Frm.Line (Ct.Left + 1, Ct.Top + 1)-(Ct.Width + Ct.Left, Ct.Top + Ct.Height), DGRAY, B
          Frm.Line (Ct.Left - 1, Ct.Top - 1)-(Ct.Width + 1 + Ct.Left, Ct.Top + Ct.Height + 1), WHITE, B
          Frm.Line (Ct.Left - 2, Ct.Top - 2)-(Ct.Width + Ct.Left + 1, Ct.Top + Ct.Height + 1), GRAY, B
      End If
      If TypeOf Ct Is Line Then
          Ct.Visible = False
          Frm.Line (Ct.X1 + 1, Ct.Y1 + 1)-(Ct.X2 + 1, Ct.Y2 + 1), DGRAY
          Frm.Line (Ct.X1, Ct.Y1)-(Ct.X2, Ct.Y2), WHITE
      End If
    End If
Next i
Frm.AutoRedraw = False

End Sub

Sub PM_UpdateOccurs (ID_Spy&, filename$)
  Dim i%, ii%
  Dim FileHandle%
  Dim L_Occurs As TM_OccursRec
  FileHandle% = FreeFile
  Open "C:\OCCURS.DAT" For Random As FileHandle% Len = Len(L_Occurs)
  ii% = LOF(FileHandle%) / Len(L_Occurs) + 1
  For i% = 1 To UBound(G_Worte)
    L_Occurs.ID_Wort = G_Worte(i%).ID
    L_Occurs.ID_Spy = ID_Spy&
    L_Occurs.filename$ = filename$
    Put FileHandle%, ii%, L_Occurs
    ii% = ii% + 1
  Next i%
  Close FileHandle%
End Sub

Sub PM_UpdateWords ()
  Dim i%, ii%
  Dim FileHandle%
  Dim L_Words As TM_WordsRec
  Dim found%

  Dim db As database, ds As Dynaset

  Debug.Print "Start: "; Timer
  Set db = OpenDatabase("C:\TEMP.MDB")
  Set ds = db.CreateDynaset("t")

  FileHandle% = FreeFile
  Open "C:\WORDS.DAT" For Random As FileHandle% Len = Len(L_Words)

  On Error Resume Next
  ds.BeginTrans

  For i% = 1 To UBound(G_Worte)
    ds.AddNew
    ds!wort = G_Worte(i%).wort
    ds.Update
    If Err = 0 Then ' Bereits vorhandenes Wort
      ds.MoveLast
      G_Worte(i%).ID& = ds!ID
    End If
  Next i%

  For i% = 1 To UBound(G_Worte)
    If G_Worte(i%).ID& = 0 Then
      L_Words.wort$ = G_Worte(i%).wort$
      G_Worte(i%).ID& = ii% + i%
      Put #FileHandle%, ii% + i%, L_Words
    End If
  Next i%
  Close FileHandle%
  ds.CommitTrans
  ds.Close
  db.Close
  Debug.Print "End : "; Timer

  'For i% = 1 To UBound(G_Worte)
  '  For ii% = 1 To LOF(FileHandle%) / Len(L_Words)
  '    Get #FileHandle%, ii%, L_Words
  '    If L_Words.wort = G_Worte(i%).wort$ Then
  '      G_Worte(i%).ID& = ii%
  '      found% = True
  '      Exit For
  '    End If
  '  Next ii%
  '  If Not found% Then
  '    L_Words.wort = G_Worte(i%).wort$
  '    Put #FileHandle%, LOF(FileHandle%) / Len(L_Words) + 1, L_Words
  '    G_Worte(i%).ID = LOF(FileHandle%) / Len(L_Words)
  '  End If
  '  found% = False
  'Next i%
End Sub