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

BASIC Source File | 1995-02-26 | 49KB | 1,552 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 * 30
End Type

Type TM_OccursRec
  ID_Wort As Long
  ID_Spy As Long
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 = "\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 L_TmpDrive$
  ChDir (L_TmpVerz$)

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

Function FM_StichwortSuche (ByVal StichWort$, Outline As Outline)
  Dim f1%, f2%, L_W As TM_WordsRec, L_O As TM_OccursRec
  Dim I&, found&
  Dim jj&
  Dim Flg_After%
  Dim Faktor As Integer
  Dim Lesen As Integer
  Dim ABuchstaben As String
  Lesen = False
  Faktor = 200
  ' Dim ABuchstaben as string

  Screen.MousePointer = 11 ' Sanduhr
  StichWort$ = LCase(StichWort$)
  ABuchstaben = Left$(StichWort$, 1)
  f1% = FreeFile
  Open Trim$(GM_DBWorte$) For Random As f1% Len = Len(L_W)
  For jj& = 1 To LOF(f1%) / Len(L_W)
Lesen:

    Get #f1%, jj&, L_W
    If Lesen = False Then
      If ABuchstaben > Left$(L_W.Wort, 1) Then
        jj& = jj& + Faktor
        Lesen = False
        If jj& > LOF(f1%) / Len(L_W) Then
          jj& = jj& - Faktor
          Lesen = True
        End If
        GoTo Lesen
      End If
      If ABuchstaben = Left$(L_W.Wort, 1) Then
        jj& = jj& - Faktor
        Lesen = True
        If jj& < 0 Then
          jj& = 1
        End If
        GoTo Lesen
      End If
      If ABuchstaben < Left$(L_W.Wort, 1) Then
        jj& = jj& - Faktor
        Lesen = True
        If jj& < 0 Then
          jj& = 1
        End If
        GoTo Lesen
      End If
    End If

    If Trim$(L_W.Wort) = StichWort$ Then
      found& = jj&
      FM_StichwortSuche = True
      f2% = FreeFile
      Open GM_DBOccurs For Random As f2% Len = Len(L_O)
      PM_ClsFound
      Flg_After% = False
      ' For I& = 1 To LOF(f2%) / Len(L_O)
      Faktor = 500
      Lesen = False
      For I& = found& To LOF(f2%) / Len(L_O)
Lesen_Zahl:
        Get #f2%, I&, L_O
        ' Debug.Print L_O.ID_Wort
'----------------------------------------------------
' Optimierung
        If Lesen = False Then
            If L_O.ID_Wort = 0 Then
                Lesen = True
                I& = I& - Faktor
                If I& < 0 Then
                  I& = 1
                  Lesen = True
                End If
                GoTo Lesen_Zahl
            End If

          If found& > L_O.ID_Wort Then
            I& = I& + Faktor
            Lesen = False
            If I& > LOF(f2%) / Len(L_W) Then
              I& = I& - Faktor
              Lesen = True
            End If
            GoTo Lesen_Zahl
          End If
          If found& <= L_O.ID_Wort Then
            I& = I& - Faktor
            Lesen = True
            If I& < 0 Then
              I& = 1
              Lesen = True
            End If
            GoTo Lesen_Zahl
          End If
        End If
        If L_O.ID_Wort = found& Then
          Flg_After% = True
          PM_AddFound L_O, Outline
        Else
          If Flg_After% Then Exit For
        End If
      Next I&
      Close f2%
    Else
      If found& > 0 Then Exit For
    End If
    If Chr$(Asc(ABuchstaben) + 1) < Left$(L_W.Wort, 1) And ABuchstaben <> "z" Then
      found& = 0
      Exit For
    End If

  Next jj&
  Close f1%
  Screen.MousePointer = 0 ' Standard
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

Sub Main ()

    GM_Drive$ = Left$(CurDir$, 2)
    ChDrive GM_Drive$
    ChDir "\"


  F_Startup.MousePointer = 11 'Sanduhr
  F_Startup.Show
  P_SetWindowTop F_Startup
  DoEvents

  GM_DBName$ = Trim$(GM_Drive$ & "\SPY.DAT")
  GM_DBWorte$ = Trim$(GM_Drive$ & "\WORDS.DAT")
  GM_DBOccurs$ = Trim$(GM_Drive$ & "\OCCURS.DAT")
  MDICDSpy.Show
  F_Startup.MousePointer = 0 'Standard
  Unload F_Startup
End Sub

Sub P_Show3dObjectPixel (Frm As Form, Ct As Control, Art As Integer)

  Const BLACK = &H0&
  Const WHITE = &HFFFFFF
  Const GRAY = &HC0C0C0
  Const DGRAY = &H808080
  Frm.AutoRedraw = True
  Select Case Art
    Case Is = 0
      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
    Case Is = 1
      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 Select
  Frm.AutoRedraw = False

End Sub

Sub P_Show3dTwips (Frm As Form, Ct As Control, Art As Integer)

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

  Dim I As Integer
  Dim Tx As Integer
  Dim Ty As Integer


  Tx = Screen.TwipsPerPixelX
  Ty = Screen.TwipsPerPixelY

  Frm.AutoRedraw = True
  Select Case Art
    Case Is = 0
        Frm.Line (Ct.Left + (1 * Tx), Ct.Top + (1 * Ty))-(Ct.Width + (0 * Tx) + Ct.Left, Ct.Top + Ct.Height + (0 * Ty)), WHITE, B
        Frm.Line (Ct.Left - (1 * Tx), Ct.Top - (1 * Ty))-(Ct.Width + (1 * Tx) + Ct.Left, Ct.Top + Ct.Height + (1 * Ty)), DGRAY, B
        Frm.Line (Ct.Left - (2 * Tx), Ct.Top - (2 * Ty))-(Ct.Width + Ct.Left + (1 * Tx), Ct.Top + Ct.Height + (1 * Ty)), GRAY, B
    Case Is = 1
        Frm.Line (Ct.Left + (1 * Tx), Ct.Top + (1 * Ty))-(Ct.Width + (0 * Tx) + Ct.Left, Ct.Top + Ct.Height + (0 * Ty)), DGRAY, B
        Frm.Line (Ct.Left - (1 * Tx), Ct.Top - (1 * Ty))-(Ct.Width + (1 * Tx) + Ct.Left, Ct.Top + Ct.Height + (1 * Ty)), WHITE, B
        Frm.Line (Ct.Left - (2 * Tx), Ct.Top - (2 * Ty))-(Ct.Width + Ct.Left + (1 * Tx), Ct.Top + Ct.Height + (1 * Ty)), GRAY, B
  End Select
  Frm.AutoRedraw = False


End Sub

Sub PM_AddFound (L_O As TM_OccursRec, Outline As Outline)
  Dim Res&, I%
 Dim ListIndex%
  On Error GoTo Err_PM_AddFound
  If Outline.ListCount > 0 Then
    For I% = 0 To Outline.ListCount - 1
      If Outline.ItemData(I%) = L_O.ID_Spy Then Exit Sub
    Next I%
  End If
  Res& = FM_LiesDB(L_O.ID_Spy)
  If Asc(GM_DB.Bezeichnung$) <> 0 Then
      Outline.AddItem GM_DB.Bezeichnung$, ListIndex%
      Outline.ItemData(ListIndex%) = Res&
      Outline.PictureType(ListIndex%) = 2
      Outline.Indent(ListIndex%) = 1
      ListIndex% = ListIndex% + 1
  End If
  Exit Sub
Err_PM_AddFound:
  MsgBox "Die Suchfunktion konnte nicht korrekt erfolgen. Stellen Sie sicher, dass der CD-Spy genⁿgend Speicher zur Verfⁿgung hat. Die Suchaktion wurde abgebrochen."
  'Resume
  Exit Sub
End Sub

' --------------------------------------------------------
' 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

' --------------------------------------------------------
' Kopiert alle Dateien der globalen Variablen G_CopyFiles
' vom Quellverzeichnis ins Zielverzeichnis. G_CopyFiles
' muss wie folgt aufgebaut sein: Quellverzeichnis,Zielver-
' zeichnis,Datei1,Datei2,...,
' --------------------------------------------------------
Sub PM_CopyFiles ()
  Dim L_Datei
  Dim L_Quellverzeichnis$, L_Zielverzeichnis$
  Screen.MousePointer = 11 ' Sanduhr
  F_CProgress.Show
  L_Quellverzeichnis$ = GM_Drive$ + FM_ParseZeile$(G_CopyFiles$, ",")
  L_Zielverzeichnis$ = FM_ParseZeile$("", "")
  L_Datei = FM_ParseZeile$("", "")
  If L_Datei = GCM_INFOFILENAME Then L_Datei = FM_ParseZeile$("", "")
  Do While L_Datei <> ""
    On Error Resume Next
    ' *** kor. Kurt
    F_CProgress.Lbl_QuellB = FM_ShortFilename$(F_CProgress, (F_CProgress!Lbl_QuellB.Width), UCase$(L_Quellverzeichnis$) & LCase$(L_Datei))
    ' kor. Kurt ***
    F_CProgress.Lbl_ZielB = FM_ShortFilename$(F_CProgress, (F_CProgress!Lbl_ZielB.Width), UCase$(L_Zielverzeichnis) & LCase$(L_Datei))
    F_CProgress.Refresh
    Kill L_Zielverzeichnis$ & L_Datei
    On Error GoTo Fehler_Copy
    FileCopy L_Quellverzeichnis$ & L_Datei, L_Zielverzeichnis$ & L_Datei
    L_Datei = FM_ParseZeile$("", "")
    If L_Datei = GCM_INFOFILENAME Then L_Datei = FM_ParseZeile$("", "")
  Loop
  Unload F_CProgress
  Screen.MousePointer = 0 ' Standard
ende:
Exit Sub


Fehler_Copy:
Unload F_CProgress
Screen.MousePointer = 0
  Select Case Err
    Case Is = 75, 76' Path not found
      MsgBox "Achtung: Ungⁿltiges Verzeichnis!", 16, "Fehler beim Kopieren"

    Case Is = 61
      MsgBox "Achtung: Festplatte voll!", 16, "Fehler beim Kopieren"

    Case Else
      MsgBox "Achtung: Fehler wΣhrend dem Kopieren!", 16, "Fehler beim Kopieren"

  End Select
Resume ende

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
    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
                Exit Sub
            End If
        End If

        begpos = endpos + 1
    Loop

    stat = 0
    If stat <> 0 Then
        Exit Sub
    End If

End Sub

' --------------------------------------------------------
' LΣdt die Datei Dn$ in das Textfeld des Formulars
' EditFile. Ist die Datei Dn$ > 32000 Byte so werden nur
' die ersten 32000 Bytes in das Textfeld geladen und der
' Benutzer auf den Umstand aufmerksam gemacht.
' --------------------------------------------------------
Sub PM_EditFile (dn$)
  Dim L_FileHandle%
  Dim L_LengthOfFile&
  Dim L_EditFile$
  Dim L_Res%
  L_FileHandle% = FreeFile
  L_LengthOfFile& = FileLen(dn$)
  If L_LengthOfFile& > 0 Then
    GM_HugeFile% = (L_LengthOfFile& > 32000)
    ' Erforderlichen Platz bereitstellen
    L_EditFile$ = Space$(FM_Min(L_LengthOfFile&, 32000))
    Open dn$ For Binary As L_FileHandle% Len = FM_Min(L_LengthOfFile&, 32000)
    Get L_FileHandle%, 1, L_EditFile$
    Close L_FileHandle%
    G_EditFile$ = L_EditFile$
    EditFile.Caption = dn$
    EditFile.Show 1
  Else
    Screen.MousePointer = 0
  End If
End Sub

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

End Sub

' --------------------------------------------------------
' Erzeugt die Datenbank. Wird in der Endversion nicht be-
' n÷tigt.
' --------------------------------------------------------
Sub PM_GenerateDB (Pfad$)
  Dim I%, L_Res%, Temp$, ii%
  Dim Start
  Dim fh%
  Dim zeile$
  Dim pos%

 Rem  GoTo SetDAT

  Start = Timer

  If FM_ExistDir(Pfad$) Then
    PM_ClearDB
    PM_ListSubDirs Pfad$, GM_DBAll()
    For I% = 1 To UBound(GM_DBAll)
      GM_DB = GM_DBAll(I%)
      L_Res% = FM_SchreibDB()
    Next I%
  Else
    MsgBox "Der angegebene Pfad existiert nicht! Die Funktion wird abgebrochen!"
    Exit Sub
  End If

' --------------------------------------------------

Exit Sub
' A

' ---------------------------------------------------
' GoTo SetDAT

  Dim db As database
  Dim DS_Worte As Dynaset
  Dim DS_Occurs As Dynaset
  Dim tb As table
  Dim tb_Occurs As table
  Dim Wort$

  Set db = OpenDatabase("\NMCDSPY.MDB")

  Set tb = db.OpenTable("T_Worte")
  tb.Index = "PrimaryKey"  ' Define current index.
  Set tb_Occurs = db.OpenTable("T_Occurs")
  tb_Occurs.Index = "PrimaryKey"

  MDICDSpy.WindowState = 0
  For I% = 1 To UBound(GM_DBAll)
    ChDir (GM_DBAll(I%).Verzeichnis)
    If FM_Exists("WORTE.YZX") Then
      fh% = FreeFile
      Open "WORTE.YZX" For Input As fh%
      db.BeginTrans
      Do While Not EOF(fh%)
        Line Input #fh%, zeile$
        pos% = InStr(zeile$, ",")
        Wort$ = Left$(zeile$, pos% - 1)
        tb.Seek "=", Wort$
        If tb.NoMatch Then
          tb.AddNew
          tb!Wort = Wort$
          tb.Update
          tb.Seek "=", Wort$
        End If
        tb_Occurs.Seek "=", I%, tb!ID
        If tb_Occurs.NoMatch Then
          tb_Occurs.AddNew
          tb_Occurs!ID = I%
          tb_Occurs!ID_Wort = tb!ID
          tb_Occurs.Update
        End If
      Loop
      db.CommitTrans
      Close fh%
      Temp$ = Dir$
    End If
  Next I%
   tb.Close
   tb_Occurs.Close

SetDAT:

  Dim W As TM_WordsRec
  Dim O As TM_OccursRec
  Dim fhW%, fhO%
  Dim cbt&, cnt_W&, cnt_O&

  fhW% = FreeFile
  Kill "\WORDS.DAT"
  Kill "\occurs.DAT"

  Open "\WORDS.DAT" For Random As #fhW% Len = Len(W)
  fhO% = FreeFile

  Open "\OCCURS.DAT" For Random As #fhO% Len = Len(O)
  Set DS_Worte = db.CreateDynaset("Select * from T_Worte order by Wort")
  cnt_W& = 1
  cnt_O& = 1
  DS_Worte.MoveFirst
  Do While Not DS_Worte.EOF
    W.Wort = DS_Worte!Wort & Space$(Len(W))
    Put #fhW%, cnt_W&, W
    Set DS_Occurs = db.CreateDynaset("Select * from T_Occurs where ID_Wort = " & DS_Worte!ID)
    DS_Occurs.MoveFirst
    Do While Not DS_Occurs.EOF
      O.ID_Wort = cnt_W&
      O.ID_Spy = DS_Occurs!ID
      Put #fhO%, cnt_O&, O
      cnt_O& = cnt_O& + 1
      DS_Occurs.MoveNext
    Loop
    DS_Occurs.Close
    cnt_W& = cnt_W& + 1
    DS_Worte.MoveNext
  Loop
  Close
  DS_Worte.Close
  db.Close
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 die ben÷tigten Control-Informationen aus dem
' Initialisierungsfile
' --------------------------------------------------------
' Autor   : NM/ag
' Datum   : 10.2.94
' VB      : 3.0
' --------------------------------------------------------
Sub PM_LiesControl (Ctrl As Control)
  Dim L_Ini_Zeile$, Eigenschaft$
  L_Ini_Zeile$ = F_GetPrivatIni("Einstellungen", Ctrl.Tag)
  Eigenschaft$ = FM_ParseZeile$((L_Ini_Zeile$), GCM_SEPERATOR)
  If TypeOf Ctrl Is Label Then
    If Eigenschaft$ = "" Then Exit Sub
    Ctrl.FontName = Eigenschaft$
    Eigenschaft$ = FM_ParseZeile$("", "")
    If Eigenschaft$ = "" Then Exit Sub
    Ctrl.FontSize = Val(Eigenschaft$)
    Eigenschaft$ = FM_ParseZeile$("", "")
    If Eigenschaft$ = "" Then Exit Sub
    Ctrl.FontBold = Val(Eigenschaft$)
    Eigenschaft$ = FM_ParseZeile$("", "")
    If Eigenschaft$ = "" Then Exit Sub
    Ctrl.ForeColor = Val(Eigenschaft$)
    Eigenschaft$ = FM_ParseZeile$("", "")
    If Eigenschaft$ = "" Then Exit Sub
    Ctrl.BackColor = Val(Eigenschaft$)
  Else
    If Eigenschaft$ = "" Then Exit Sub
    Ctrl.FontName = Eigenschaft$
    Eigenschaft$ = FM_ParseZeile$("", "")
    If Eigenschaft$ = "" Then Exit Sub
    Ctrl.FontSize = Val(Eigenschaft$)
    Eigenschaft$ = FM_ParseZeile$("", "")
    If Eigenschaft$ = "" Then Exit Sub
    Ctrl.FontBold = Val(Eigenschaft$)
    Eigenschaft$ = FM_ParseZeile$("", "")
    If Eigenschaft$ = "" Then Exit Sub
    Ctrl.ForeColor = Val(Eigenschaft$)
    Eigenschaft$ = FM_ParseZeile$("", "")
    If Eigenschaft$ = "" Then Exit Sub
    Ctrl.BackColor = Val(Eigenschaft$)
  End If
End Sub

' --------------------------------------------------------
' Liest die ben÷tigten Formular-Informationen aus dem
' Initialisierungsfile
' --------------------------------------------------------
' Autor   : NM/ag
' Datum   : 10.2.94
' VB      : 3.0
' --------------------------------------------------------
Sub PM_LiesForm (Frm As Form)

  Dim L_Ini_Zeile$, Eigenschaft$
  On Error Resume Next

  L_Ini_Zeile$ = F_GetPrivatIni("Einstellungen", Frm.Tag)
  Eigenschaft$ = FM_ParseZeile$((L_Ini_Zeile$), GCM_SEPERATOR)
  If Eigenschaft$ = "" Then Exit Sub
  Frm.Top = Val(Eigenschaft$)
  Eigenschaft$ = FM_ParseZeile$("", "")
  If Eigenschaft$ = "" Then Exit Sub
  Frm.Left = Val(Eigenschaft$)
  Eigenschaft$ = FM_ParseZeile$("", "")
  If Eigenschaft$ = "" Then Exit Sub
  Frm.Width = Val(Eigenschaft$)
  Eigenschaft$ = FM_ParseZeile$("", "")
  If Eigenschaft$ = "" Then Exit Sub
  Frm.Height = Val(Eigenschaft$)
  Eigenschaft$ = FM_ParseZeile$("", "")
  If Eigenschaft$ = "" Then Exit Sub
  Frm.WindowState = Val(Eigenschaft$)
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

Sub PM_OpenLeaf (OutCtrl As Outline, ID&)
  Dim I%, ii&
  For I% = 0 To OutCtrl.ListCount - 1
    If OutCtrl.ItemData(I%) = ID& Then Exit For
  Next I%
  If I% < OutCtrl.ListCount Then
    If OutCtrl.IsItemVisible(I%) Then Exit Sub
  End If
  ii& = FM_LiesDB(ID&)
  PM_OpenLeaf OutCtrl, (GM_DB.Vater)
  For I% = 0 To OutCtrl.ListCount - 1
    If OutCtrl.ItemData(I%) = GM_DB.Vater Then Exit For
  Next I%
  OutCtrl.Expand(I%) = True

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

' --------------------------------------------------------
' Liest die Informationen aus der Datei CDINFO des aktuell
' im Outline-Control markierten Eintrages aus und enabled
' resp. disabled die entsprechenden SchaltflΣchen und be-
' reitet diese auf ihre Aufgabe vor.
' --------------------------------------------------------
Sub PM_ReadCDInfo (OutCtrl As Outline, AktElement As TM_AktElement)
  Dim L_Res&
  Dim L_Position%
  Dim L_CDInfoCommands$
  Dim L_Tmp$
  Dim L_MakDatei$, L_HilfeDatei$
  Dim L_Lbl_Info_Visible%, L_Fil_Projekt_Visible%

  On Error GoTo Err_PM_ReadCDInfo
  ' CDInfo-Datei einlesen
  L_Res& = FM_LiesDB(Val(OutCtrl.ItemData(OutCtrl.ListIndex)))
  PM_LiesCDInfo Trim$(GM_DB.Verzeichnis$)
  ' Infoteil extrahieren
  L_Position% = InStr(UCase$(G_CDInfoFile$), GCM_INFO)
  If L_Position% <> 0 Then
    ' Alle Restlichen Angaben vor Info= extrahieren
    L_CDInfoCommands$ = UCase$(Left$(G_CDInfoFile$, L_Position% - 1))
    AktElement.Info$ = Mid$(G_CDInfoFile$, L_Position% + Len(GCM_INFO))
  Else
    L_CDInfoCommands$ = UCase$(G_CDInfoFile$)
    AktElement.Info$ = ""
  End If
  ' Startknopf enablen falls startbare Datei vorhanden
  L_Position% = InStr(L_CDInfoCommands$, GCM_STARTABLE)
  If L_Position% <> 0 Then
    L_Tmp$ = Mid$(L_CDInfoCommands$ + Chr$(13), L_Position% + Len(GCM_STARTABLE))
    AktElement.Startfile$ = Left$(L_Tmp$, InStr(L_Tmp$, Chr$(13)) - 1)
  Else
    AktElement.Startfile$ = ""
  End If
  ' Demoknopf enablen falls Demo vorhanden
  L_Position% = InStr(L_CDInfoCommands$, GCM_DEMO)
  If L_Position% <> 0 Then
    L_Tmp$ = Mid$(L_CDInfoCommands$ + Chr$(13), L_Position% + Len(GCM_DEMO))
    AktElement.Demofile$ = Left$(L_Tmp$, InStr(L_Tmp$, Chr$(13)) - 1)
  Else
    AktElement.Demofile$ = ""
  End If
  ' Readmeknopf enablen falls Demo vorhanden
  L_Position% = InStr(L_CDInfoCommands$, GCM_README)
  If L_Position% <> 0 Then
    L_Tmp$ = Mid$(L_CDInfoCommands$ + Chr$(13), L_Position% + Len(GCM_README))
    AktElement.Readmefile$ = Left$(L_Tmp$, InStr(L_Tmp$, Chr$(13)) - 1)
  Else
    AktElement.Readmefile$ = ""
  End If
  ' Kopierknopf enablen falls Projekt= vorhanden (Blatt des Baumes)
  L_Position% = InStr(L_CDInfoCommands$, GCM_PROJEKT)
  If L_Position% <> 0 Then
    AktElement.Copy% = True
  Else
    AktElement.Copy% = False
  End If
  ' Codeknopf enablen falls .MAK-Datei vorhanden
  L_Tmp$ = FM_Verz$(GM_DB.Verzeichnis$) + "*.MAK"
  L_MakDatei$ = Dir$(L_Tmp$)
  If L_MakDatei$ <> "" Then
    AktElement.Code% = True
  Else
    AktElement.Code% = False
  End If
  AktElement.Verzeichnis$ = GM_DB.Verzeichnis$
  ' Installknopf enablen falls Setup-Programm vorhanden
  L_Position% = InStr(L_CDInfoCommands$, GCM_INSTALL)
  If L_Position% <> 0 Then
    L_Tmp$ = Mid$(L_CDInfoCommands$ + Chr$(13), L_Position% + Len(GCM_INSTALL))
    AktElement.SetupCommand$ = Left$(L_Tmp$, InStr(L_Tmp$, Chr$(13)) - 1)
  Else
    AktElement.SetupCommand$ = ""
  End If
  ' Hilfedateiknopf enablen falls Hilfedatei vorhanden
  L_Tmp$ = FM_Verz$(GM_DB.Verzeichnis$) + "*.HLP"
  L_HilfeDatei$ = Dir$(L_Tmp$)
  If L_HilfeDatei$ <> "" Then
    AktElement.Hilfefile$ = "WinHelp " & FM_Verz$(GM_DB.Verzeichnis$) & L_HilfeDatei$
  Else
    AktElement.Hilfefile$ = ""
  End If
  Exit Sub
Err_PM_ReadCDInfo:
  Resume Next
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

' --------------------------------------------------------
' Einlesen der Outline-Elemente
' --------------------------------------------------------
Sub PM_ReadItems (OutCtrl As Outline, ByVal Vater&, ByVal ListIndex%, ByVal Ebene%)
  ReDim d(1)
  Dim cnt%, I%, Res%
  PM_GetParents Vater&, d()
  For I% = 1 To UBound(d) - 1
    Res% = FM_LiesDB(CLng(d(I%)))
    If Res% <> 0 Then
      ListIndex% = ListIndex% + 1
      If ListIndex% < OutCtrl.ListCount Then
        If OutCtrl.List(ListIndex%) = "Hilfs" Then
          OutCtrl.List(ListIndex%) = GM_DB.Bezeichnung$
        Else
          OutCtrl.AddItem GM_DB.Bezeichnung, ListIndex%
        End If
      Else
        OutCtrl.AddItem GM_DB.Bezeichnung, ListIndex%
      End If
      OutCtrl.ItemData(ListIndex%) = Res%
      OutCtrl.Indent(ListIndex%) = Ebene%
      If GM_DB.Code = 0 Then
        OutCtrl.PictureType(ListIndex%) = 0
        ListIndex% = ListIndex% + 1
        OutCtrl.AddItem "Hilfs", ListIndex%
        OutCtrl.Indent(ListIndex%) = Ebene% + 1
      Else
        OutCtrl.PictureType(ListIndex%) = 2
      End If
    End If
  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

' --------------------------------------------------------
' Speichert die ben÷tigten Control-Informationen im
' Initialisierungsfile ab
' --------------------------------------------------------
' Autor   : NM/ag
' Datum   : 10.2.94
' Version : 1.0
' --------------------------------------------------------
Sub PM_SchreibControl (Ctrl As Control)
  Dim L_Ini_Zeile$
  If TypeOf Ctrl Is Label Then
    L_Ini_Zeile$ = Ctrl.FontName & GCM_SEPERATOR
    L_Ini_Zeile$ = L_Ini_Zeile$ & Trim$(Str$(Ctrl.FontSize)) & GCM_SEPERATOR
    L_Ini_Zeile$ = L_Ini_Zeile$ & Ctrl.FontBold & GCM_SEPERATOR
    L_Ini_Zeile$ = L_Ini_Zeile$ & Ctrl.ForeColor & GCM_SEPERATOR
    L_Ini_Zeile$ = L_Ini_Zeile$ & Ctrl.BackColor
  Else
    L_Ini_Zeile$ = Ctrl.FontName & GCM_SEPERATOR
    L_Ini_Zeile$ = L_Ini_Zeile$ & Trim$(Str$(Ctrl.FontSize)) & GCM_SEPERATOR
    L_Ini_Zeile$ = L_Ini_Zeile$ & Ctrl.FontBold & GCM_SEPERATOR
    L_Ini_Zeile$ = L_Ini_Zeile$ & Ctrl.ForeColor & GCM_SEPERATOR
    L_Ini_Zeile$ = L_Ini_Zeile$ & Ctrl.BackColor
  End If
  P_WritePrivatInit GCM_EINSTELLUNGEN, (Ctrl.Tag), L_Ini_Zeile$
End Sub

' --------------------------------------------------------
' Speichert die ben÷tigten Formular-Informationen im
' Initialisierungsfile ab
' --------------------------------------------------------
' Autor   : NM/ag
' Datum   : 10.2.94
' Version : 1.0
' --------------------------------------------------------
Sub PM_SchreibForm (Frm As Form)
  Dim L_Ini_Zeile$, L_tmp_State%
  L_tmp_State% = Frm.WindowState
  Frm.WindowState = 0
  L_Ini_Zeile$ = Frm.Top & GCM_SEPERATOR
  L_Ini_Zeile$ = L_Ini_Zeile$ & Frm.Left & GCM_SEPERATOR
  L_Ini_Zeile$ = L_Ini_Zeile$ & Frm.Width & GCM_SEPERATOR
  L_Ini_Zeile$ = L_Ini_Zeile$ & Frm.Height & GCM_SEPERATOR
  L_Ini_Zeile$ = L_Ini_Zeile$ & L_tmp_State%
  P_WritePrivatInit GCM_EINSTELLUNGEN, (Frm.Tag), L_Ini_Zeile$
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$, 1)
  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_ShowToolbox (mode As Integer)
  Dim I%
  Static CMDEnables(7) As Integer
  If mode Then
    F_Toolbox.Show
    For I% = 0 To 7
      MDICDSpy!MnuSetupItem(I%).Visible = CMDEnables(I%)
    Next I%
    MDICDSpy!MnuSetupTrenn.Visible = True
  Else
    F_Toolbox.Hide
    For I% = 0 To 7
       CMDEnables(I%) = MDICDSpy!MnuSetupItem(I%).Visible
       MDICDSpy!MnuSetupItem(I%).Visible = False
    Next I%
    MDICDSpy!MnuSetupTrenn.Visible = False
  End If
End Sub

' -----------------------------------------------------------------------
' Schaltet den ⁿbergebenen Befehl in der Toolbox auf aktiv resp. inaktiv
' -----------------------------------------------------------------------
Sub PM_Switch (Button As Integer, mode As Integer)
  F_Toolbox.Cmd_Array(Button%).Enabled = mode%
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&
    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

End Sub