home *** CD-ROM | disk | FTP | other *** search
- Option Explicit
-
- 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 * 25
- Vater As Long
- Verzeichnis As String * 128
- Code As Integer
- End Type
-
- Global GM_Outline() As TM_OutlineRec
- Global GM_DB As TM_DBRec
-
- Global Const GCM_INFOFILENAME = "CDINFO.TXT"
- 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_DBNAME = "SPY.DAT"
- Global Const GCM_EINSTELLUNGEN = "Einstellungen"
- Global Const GCM_SEPERATOR = ","
- ' SchaltflΣchen im Cmd_Array
- Global Const GCM_CMD_INFO = 0
- Global Const GCM_CMD_DEMO = 1
- Global Const GCM_CMD_COPY = 2
- Global Const GCM_CMD_INSTALL = 3
- Global Const GCM_CMD_CODE = 4
- Global Const GCM_CMD_HILFE = 5
-
-
- Global GM_DBAll() As TM_DBRec
-
- Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
- Declare Function GetModuleUsage Lib "KERNEL" (ByVal InstanceID%) As Integer
-
-
- Global G_CDInfoFile As String
-
- Global G_Control As Control
- Global G_EditFile As String
-
- Function ExistDir% (drn$)
- Dim temp$
- On Error Resume Next
- temp$ = Dir$(drn$, 16)
- If Err <> 0 Or temp$ = "" Then
- ExistDir% = False
- Else
- ExistDir% = True
- End If
- End Function
-
- Function exists (dn$) As Integer
- Dim temp$
- On Error Resume Next
- temp$ = Dir$(dn$, 32)
- exists = Not (Err <> 0 Or temp$ = "")
- End Function
-
- Function FM_LiesDB (ID&)
- Dim fd As Integer
- If ID < 1 Then
- Exit Function
- End If
- fd = FreeFile
- Open GCM_DBNAME For Random As fd Len = Len(GM_DB)
- If ID& * Len(GM_DB) <= LOF(fd) Then
- Get #fd, ID&, GM_DB
- FM_LiesDB = ID&
- Else
- FM_LiesDB = 0
- End If
- Close fd
- End Function
-
- Function FM_Max (X, y)
- If X > y Then
- FM_Max = X
- Else
- FM_Max = y
- End If
- End Function
-
- 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 z$ wird die Zeile zur Initia-
- ' lisierung ⁿbergeben. Zum Abrufen der Werte wird ein
- ' Leerstring als z$ ⁿbergeben
- ' --------------------------------------------------------
- Function FM_ParseZeile$ (z$, ch$)
- Static txt$, Zch$
- Dim tmp$
-
- If z$ <> "" Then
- ' Zeile initialisieren
- txt$ = z$ + ch$
- Zch$ = ch$
- End If
- If Trim$(txt$) <> "" Then
- ' Zeichenkette bis zum ersten Tabulatorzeichen bestimmen
- tmp$ = Left$(txt$, InStr(txt$, Zch$) - 1)
- ' Zeile auf Teil nach erstem Tabulatorzeichen reduzieren
- txt$ = LTrim$(Mid$(txt$, InStr(txt$, Zch$) + 1))
- End If
- FM_ParseZeile$ = tmp$
- End Function
-
- Function FM_SchreibDB ()
- Dim fd As Integer
- Dim pos%
- fd = FreeFile
- Open GCM_DBNAME For Random As fd Len = Len(GM_DB)
- pos% = (LOF(fd) / Len(GM_DB)) + 1
- Put #fd, pos%, GM_DB
- FM_SchreibDB = pos%
- Close fd
- End Function
-
- Function FM_Verz$ (Verz$)
- Dim tmp$
- tmp$ = Trim$(Verz$)
- If Right$(tmp$, 1) <> "\" Then
- tmp$ = tmp$ + "\"
- End If
- FM_Verz$ = tmp$
- End Function
-
- Sub 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 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_ChangeCmdState (index%)
- Static old%
- Dim Res&
- If Haupt!Cmd_Array(index%).Enabled Then
- Res& = SendMessage(Haupt!Cmd_Array(index%).hWnd, &H403, -1, 0)
- Else
- Res& = SendMessage(Haupt!Cmd_Array(index%).hWnd, &H403, 0, 0)
- End If
- If old% = index% Then Exit Sub
- Res& = SendMessage(Haupt!Cmd_Array(old%).hWnd, &H403, 0, 0)
- old% = index%
- End Sub
-
- Sub PM_ClearDB ()
- Dim fd As Integer
- fd = FreeFile
- Kill GCM_DBNAME
- End Sub
-
- Sub PM_EditFile (dn$)
- Dim fd As Integer
- Dim L_LengthOfFile%
- Dim tmp$
- fd = FreeFile
- L_LengthOfFile% = FileLen(dn$)
- tmp$ = Space$(L_LengthOfFile%)
- Open dn$ For Binary As fd Len = L_LengthOfFile%
- Get fd, 1, tmp$
- G_EditFile$ = tmp$
- Close fd
- EditFile.Caption = dn$
- EditFile.Show
- End Sub
-
- Sub PM_GenerateDB (Pfad$)
- Dim I%, Res%
- If ExistDir(Pfad$) Then
- PM_ClearDB
- ListSubDirs Pfad$, GM_DBAll()
- For I% = 1 To UBound(GM_DBAll)
- GM_DB = GM_DBAll(I%)
- Res% = FM_SchreibDB()
- Next I%
- End If
- End Sub
-
- Sub PM_GetCDINFO (d As TM_DBRec)
- Dim tmp$, fd%, Zeile$, pos%
- tmp$ = Trim$(d.Verzeichnis$)
- If Right$(tmp$, 1) <> "\" Then tmp$ = tmp$ + "\"
- tmp$ = Trim$(tmp$) + "CDINFO.TXT"
- fd = FreeFile
- On Error Resume Next
- Open tmp$ For Input As fd
- If Err <> 0 Then Exit Sub
- If Not EOF(fd) Then
- Line Input #fd, Zeile$
- pos% = InStr(UCase$(Zeile$), GCM_VERZEICHNIS)
- If pos% Then
- d.Bezeichnung$ = Mid$(Zeile$, pos% + Len(GCM_VERZEICHNIS))
- End If
- If Not EOF(fd) Then
- Line Input #fd, Zeile$
- pos% = InStr(UCase$(Zeile$), GCM_PROJEKT)
- If pos% Then
- d.Code = 1
- Else
- d.Code = 0
- End If
- End If
- End If
- Close fd
- End Sub
-
- Sub PM_GetChilds (ID&, d())
- Dim fd As Integer
- Dim I%
- fd = FreeFile
- Open GCM_DBNAME For Random As fd Len = Len(GM_DB)
- For I% = 1 To LOF(fd) / Len(GM_DB)
- Get #fd, I%, GM_DB
- If GM_DB.Vater = ID& Then
- d(UBound(d)) = I%
- ReDim Preserve d(UBound(d) + 1)
- End If
- Next I%
- Close fd
- End Sub
-
- Sub PM_GetFileInfo (dn$)
- Dim ds As Integer
- Dim pos%
- Dim Zeile$
- Dim Ub%
- ds = FreeFile
- Open dn$ For Input As ds
- Line Input #ds, Zeile$
- pos% = InStr(Zeile$, GCM_VERZEICHNIS)
- If pos% Then ' Verzeichnis
- On Error Resume Next
- Ub% = UBound(GM_Outline)
- On Error GoTo 0
- Ub% = Ub% + 1
- ReDim Preserve GM_Outline(Ub%)
- GM_Outline(Ub%).Bezeichnung = Mid$(Zeile$, pos% + Len(GCM_VERZEICHNIS))
- End If
- If Not EOF(ds) Then
- Line Input #ds, Zeile$
- pos% = InStr(Zeile$, GCM_PROJEKT)
- If pos% Then
- GM_Outline(Ub%).hat_unter_obj = False
- Else
- GM_Outline(Ub%).hat_unter_obj = True
- End If
- Else
- GM_Outline(Ub%).hat_unter_obj = True
- End If
- Close #ds
- End Sub
-
- Sub PM_GetParents (ID&, d())
- Dim fd As Integer
- Dim I%
- fd = FreeFile
- Open GCM_DBNAME For Random As fd Len = Len(GM_DB)
- For I% = 1 To LOF(fd) / Len(GM_DB)
- Get #fd, I%, GM_DB
- If GM_DB.Vater = ID& Then
- d(UBound(d)) = I%
- ReDim Preserve d(UBound(d) + 1)
- End If
- Next I%
- Close fd
- End Sub
-
- Sub PM_LeseEintrag (index As Long, ByVal ID As Long, Ebene%)
- Dim Vater&
- Dim LM_DB As TM_DBRec
- Dim tmpIndex&
- ReDim d(1)
- Dim cnt%, I%, Res%
- Res% = FM_LiesDB(ID&)
- LM_DB = GM_DB
- If ID > 0 Then
- PM_LeseEintrag index&, LM_DB.Vater&, Ebene%
- PM_GetParents ID&, d()
- For I% = 1 To UBound(d) - 1
- Res% = FM_LiesDB(CLng(d(I%)))
- If Res% <> 0 Then
- Haupt.Outline.AddItem GM_DB.Bezeichnung, index
- Haupt.Outline.ItemData(index) = Res%
- Haupt.Outline.Indent(index) = Ebene%
- If Not GM_DB.Code Then
- Haupt.Outline.PictureType(index&) = 0
- Else
- Haupt.Outline.PictureType(index&) = 2
- End If
- If Haupt.Outline.ItemData(index) = LM_DB.Vater& Then
- tmpIndex& = index&
- Haupt.Outline.Expand(index&) = True
- End If
- index& = index& + 1
- End If
- Next I%
-
- If tmpIndex& <> 0 Then index& = tmpIndex& + 1
- Else
- Res% = FM_LiesDB(1)
- Ebene% = 1
- If Res% <> 0 Then
- Haupt.Outline.AddItem GM_DB.Bezeichnung, index
- Haupt.Outline.ItemData(index) = Res%
- Haupt.Outline.Indent(index) = Ebene%
- If Not GM_DB.Code Then
- Haupt.Outline.PictureType(index&) = 0
- Else
- Haupt.Outline.PictureType(index&) = 2
- End If
- If Haupt.Outline.ItemData(index) = LM_DB.Vater& Then
- Haupt.Outline.Expand(index&) = True
- tmpIndex& = index&
- End If
- index& = index& + 1
- End If
- End If
- Ebene% = Ebene% + 1
- End Sub
-
- Sub PM_Lies (ID&)
- Dim index&
- Dim Ebene%
- index& = 0
- Haupt.Outline.Clear
- PM_LeseEintrag index&, ID&, Ebene%
- End Sub
-
- Sub PM_LiesCDInfo (Verzeichnis$)
- Dim fd As Integer
- Dim l&
- Dim L_CDInfoFilename$
- If Right$(Verzeichnis$, 1) <> "\" Then
- L_CDInfoFilename$ = Verzeichnis$ + "\" + GCM_INFOFILENAME
- Else
- L_CDInfoFilename$ = Verzeichnis$ + GCM_INFOFILENAME
- End If
- l& = FileLen(L_CDInfoFilename$)
- G_CDInfoFile$ = Space$(l&)
- fd = FreeFile
- Open L_CDInfoFilename$ For Binary As fd Len = l&
- Get #fd, , G_CDInfoFile$
- Close fd
- End Sub
-
- ' --------------------------------------------------------
- ' Liest die ben÷tigten Control-Informationen aus dem
- ' Initialisierungsfile
- ' --------------------------------------------------------
- ' Autor : NM/ag
- ' Datum : 10.2.94
- ' Version : 1.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
- ' Version : 1.0
- ' --------------------------------------------------------
- Sub PM_LiesForm (Frm As Form)
- Dim L_Ini_Zeile$, Eigenschaft$
- 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
-
- Sub PM_LiesOutline (pos%)
- Dim fd As Integer
- fd = FreeFile
- Open GCM_DBNAME For Random As fd Len = Len(GM_DB)
- Get fd, pos%, GM_DB
- Haupt.Outline.AddItem GM_DB.Bezeichnung
- Haupt.Outline.ItemData(0) = pos%
- Haupt.Outline.Indent(1) = 2
- Close fd
- Haupt.Outline.Refresh
- End Sub
-
- Sub PM_ReadCDInfo ()
- Dim Res&
- Dim pos%
- Dim L_CDInfoCommands$
- Dim tmp$
- Dim MakDatei$, HilfeDatei$
- Res& = FM_LiesDB(Val(Haupt!Outline.ItemData(Haupt!Outline.ListIndex)))
- PM_LiesCDInfo Trim$(GM_DB.Verzeichnis$)
- pos% = InStr(UCase$(G_CDInfoFile$), GCM_INFO)
- If pos% <> 0 Then
- Haupt!Lbl_Info.Caption = Mid$(G_CDInfoFile$, pos% + Len(GCM_INFO))
- Haupt!Lbl_Info.Visible = True
- Haupt!Cmd_Array(GCM_CMD_INFO).Enabled = True
- Haupt!Cmd_Array(GCM_CMD_INFO) = True
- L_CDInfoCommands$ = UCase$(Left$(G_CDInfoFile$, pos% - 1))
- Else
- Haupt!Cmd_Array(GCM_CMD_INFO).Enabled = False
- Haupt!Lbl_Info.Visible = False
- Haupt!Lbl_Info.Caption = ""
- Haupt!Cmd_Array(6) = True
- L_CDInfoCommands$ = UCase$(G_CDInfoFile$)
- End If
- pos% = InStr(L_CDInfoCommands$, GCM_DEMO)
- If pos% <> 0 Then
- Haupt!Cmd_Array(GCM_CMD_DEMO).Enabled = True
- tmp$ = Mid$(L_CDInfoCommands$ + Chr$(13), pos% + Len(GCM_DEMO))
- Haupt!Cmd_Array(GCM_CMD_DEMO).Tag = Left$(tmp$, InStr(tmp$, Chr$(13)) - 1)
- Else
- Haupt!Cmd_Array(GCM_CMD_DEMO).Enabled = False
- End If
- pos% = InStr(L_CDInfoCommands$, GCM_PROJEKT)
- If pos% <> 0 Then
- Haupt!Cmd_Array(GCM_CMD_COPY).Enabled = True
- Else
- Haupt!Cmd_Array(GCM_CMD_COPY).Enabled = False
- End If
- tmp$ = FM_Verz$(GM_DB.Verzeichnis$) + "*.MAK"
- MakDatei$ = Dir$(tmp$)
- If MakDatei$ <> "" Then
- Haupt!Cmd_Array(GCM_CMD_CODE).Enabled = True
- Haupt!Cmd_Array(GCM_CMD_CODE).Tag = FM_Verz$(GM_DB.Verzeichnis$)
- Else
- Haupt!Cmd_Array(GCM_CMD_CODE).Enabled = False
- End If
- pos% = InStr(L_CDInfoCommands$, GCM_INSTALL)
- If pos% <> 0 Then
- Haupt!Cmd_Array(GCM_CMD_INSTALL).Enabled = True
- tmp$ = Mid$(L_CDInfoCommands$ + Chr$(13), pos% + Len(GCM_INSTALL))
- Haupt!Cmd_Array(GCM_CMD_INSTALL).Tag = Left$(tmp$, InStr(tmp$, Chr$(13)) - 1)
- Else
- Haupt!Cmd_Array(GCM_CMD_INSTALL).Enabled = False
- End If
- tmp$ = FM_Verz$(GM_DB.Verzeichnis$) + "*.HLP"
- HilfeDatei$ = Dir$(tmp$)
- If HilfeDatei$ <> "" Then
- Haupt!Cmd_Array(GCM_CMD_HILFE).Enabled = True
- Haupt!Cmd_Array(GCM_CMD_HILFE).Tag = "WinHelp " & FM_Verz$(GM_DB.Verzeichnis$) & HilfeDatei$
- Else
- Haupt!Cmd_Array(GCM_CMD_HILFE).Enabled = False
- End If
- PM_ChangeCmdState (0)
- End Sub
-
- Sub PM_ReadItems (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% < Haupt.Outline.ListCount Then
- If Haupt.Outline.List(ListIndex%) = "Hilfs" Then
- Haupt.Outline.List(ListIndex%) = GM_DB.Bezeichnung$
- Else
- Haupt.Outline.AddItem GM_DB.Bezeichnung, ListIndex%
- End If
- Else
- Haupt.Outline.AddItem GM_DB.Bezeichnung, ListIndex%
- End If
- Haupt.Outline.ItemData(ListIndex%) = Res%
- Haupt.Outline.Indent(ListIndex%) = Ebene%
- If GM_DB.Code = 0 Then
- Haupt.Outline.PictureType(ListIndex%) = 0
- ListIndex% = ListIndex% + 1
- Haupt.Outline.AddItem "Hilfs", ListIndex%
- Haupt.Outline.Indent(ListIndex%) = Ebene% + 1
- Else
- Haupt.Outline.PictureType(ListIndex%) = 2
- End If
- End If
- Next I%
- End Sub
-
- Sub PM_RefreshAnzeige ()
- Haupt!Lbl_Info.Move 4, 2
- Haupt!Lbl_Info.Height = Haupt!Pic_Anzeige.Height - 4
- Haupt!Lbl_Info.Width = FM_Max(Haupt!Pic_Anzeige.Width - 6, 0)
- Haupt!File1.Move 4, 2
- Haupt!File1.Width = Haupt!Lbl_Info.Width
- Haupt!File1.Height = Haupt!Lbl_Info.Height
- If Haupt!Lbl_Info.Visible Then
- Haupt!Pic_Anzeige.BackColor = Haupt!Lbl_Info.BackColor
- Else
- Haupt!Pic_Anzeige.BackColor = Haupt!File1.BackColor
- End If
- End Sub
-
- Sub PM_ScanDirs (Pfad$, Vater&)
- Dim tmp$, Vater_Neu&, totPfad$
- GM_DB.Bezeichnung$ = "Test"
- GM_DB.Vater& = Vater&
- GM_DB.Verzeichnis$ = Pfad$
- Debug.Print Pfad$
- Vater_Neu& = FM_SchreibDB()
- If Right$(Pfad$, 1) <> "\" Then
- totPfad$ = Pfad$ + "\"
- Else
- totPfad$ = Pfad$ + ""
- End If
- tmp$ = Dir$(totPfad$ + "*.*", 16)
- Do While Left$(tmp$, 1) = "."
- tmp$ = Dir$
- Loop
- Do While tmp$ <> ""
- If GetAttr(totPfad$ + tmp$) = 16 Then ' Verzeichnis
- PM_ScanDirs totPfad$ + tmp$, Vater_Neu&
- End If
- tmp$ = Dir$
- Loop
- 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
-
- Sub PM_SeekList (Cntrl As Control, Eintrag$)
- Dim I%
- For I% = 0 To Cntrl.ListCount - 1
- If Cntrl.List(I%) = Eintrag Then
- Cntrl.ListIndex = I%
- Exit For
- End If
- Next I%
- End Sub
-
- Sub PM_ShellAndWait (CommandString$)
- Dim ID%
- Dim X%
- ID% = Shell(CommandString$, 1)
- Do
- DoEvents
- Debug.Print Timer
- Loop Until GetModuleUsage(ID%) = 0
- End Sub
-
- 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
- Dim Tx As Integer
- Dim Ty As Integer
-
- Tx = 1
- Ty = 1
- Frm.AutoRedraw = True
-
- ' 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 TypeOf ct Is Shape Then
- ct.Visible = False
- Frm.DrawWidth = 2
- Frm.Line (ct.Left - (0 * Tx), ct.Top - (0 * Ty))-(ct.Width + (1 * Tx) + ct.Left, ct.Top + ct.Height + (0 * Ty)), DGRAY, B
- Frm.DrawWidth = 1
- Frm.Line (ct.Left - (1 * Tx), ct.Top - (1 * Ty))-(ct.Width + (0 * Tx) + ct.Left, ct.Top + ct.Height - (1 * Ty)), WHITE, 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 + Tx
- Frm.CurrentY = ct.Top + Ty
- 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 * 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
- End If
- If TypeOf ct Is ListBox Then
- 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 If
- If TypeOf ct Is ComboBox Then
- 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 If
- If TypeOf ct Is Line Then
- ct.Visible = False
- Frm.Line (ct.X1 + (1 * Tx), ct.Y1 + (1 * Ty))-(ct.X2 + (1 * Tx), ct.Y2 + (1 * Ty)), DGRAY
- Frm.Line (ct.X1 + (0 * Tx), ct.Y1 + (0 * Ty))-(ct.X2 + (0 * Tx), ct.Y2 + (0 * Ty)), WHITE
- End If
-
- Next I
- Frm.AutoRedraw = False
-
- End Sub
-
- Option Explicit
-
- 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 * 25
- Vater As Long
- Verzeichnis As String * 128
- Code As Integer
- End Type
-
- Global GM_Outline() As TM_OutlineRec
- Global GM_DB As TM_DBRec
-
- Global Const GCM_INFOFILENAME = "CDINFO.TXT"
- 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_DBNAME = "SPY.DAT"
- Global Const GCM_EINSTELLUNGEN = "Einstellungen"
- Global Const GCM_SEPERATOR = ","
- ' SchaltflΣchen im Cmd_Array
- Global Const GCM_CMD_INFO = 0
- Global Const GCM_CMD_DEMO = 1
- Global Const GCM_CMD_COPY = 2
- Global Const GCM_CMD_INSTALL = 3
- Global Const GCM_CMD_CODE = 4
- Global Const GCM_CMD_HILFE = 5
-
-
- Global GM_DBAll() As TM_DBRec
-
- Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
- Declare Function GetModuleUsage Lib "KERNEL" (ByVal InstanceID%) As Integer
-
-
- Global G_CDInfoFile As String
-
- Global G_Control As Control
- Global G_EditFile As String
-
- Function ExistDir% (drn$)
- Dim temp$
- On Error Resume Next
- temp$ = Dir$(drn$, 16)
- If Err <> 0 Or temp$ = "" Then
- ExistDir% = False
- Else
- ExistDir% = True
- End If
- End Function
-
- Function exists (dn$) As Integer
- Dim temp$
- On Error Resume Next
- temp$ = Dir$(dn$, 32)
- exists = Not (Err <> 0 Or temp$ = "")
- End Function
-
- Function FM_LiesDB (ID&)
- Dim fd As Integer
- If ID < 1 Then
- Exit Function
- End If
- fd = FreeFile
- Open GCM_DBNAME For Random As fd Len = Len(GM_DB)
- If ID& * Len(GM_DB) <= LOF(fd) Then
- Get #fd, ID&, GM_DB
- FM_LiesDB = ID&
- Else
- FM_LiesDB = 0
- End If
- Close fd
- End Function
-
- Function FM_Max (X, y)
- If X > y Then
- FM_Max = X
- Else
- FM_Max = y
- End If
- End Function
-
- 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 z$ wird die Zeile zur Initia-
- ' lisierung ⁿbergeben. Zum Abrufen der Werte wird ein
- ' Leerstring als z$ ⁿbergeben
- ' --------------------------------------------------------
- Function FM_ParseZeile$ (z$, ch$)
- Static txt$, Zch$
- Dim tmp$
-
- If z$ <> "" Then
- ' Zeile initialisieren
- txt$ = z$ + ch$
- Zch$ = ch$
- End If
- If Trim$(txt$) <> "" Then
- ' Zeichenkette bis zum ersten Tabulatorzeichen bestimmen
- tmp$ = Left$(txt$, InStr(txt$, Zch$) - 1)
- ' Zeile auf Teil nach erstem Tabulatorzeichen reduzieren
- txt$ = LTrim$(Mid$(txt$, InStr(txt$, Zch$) + 1))
- End If
- FM_ParseZeile$ = tmp$
- End Function
-
- Function FM_SchreibDB ()
- Dim fd As Integer
- Dim pos%
- fd = FreeFile
- Open GCM_DBNAME For Random As fd Len = Len(GM_DB)
- pos% = (LOF(fd) / Len(GM_DB)) + 1
- Put #fd, pos%, GM_DB
- FM_SchreibDB = pos%
- Close fd
- End Function
-
- Function FM_Verz$ (Verz$)
- Dim tmp$
- tmp$ = Trim$(Verz$)
- If Right$(tmp$, 1) <> "\" Then
- tmp$ = tmp$ + "\"
- End If
- FM_Verz$ = tmp$
- End Function
-
- Sub 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 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_ChangeCmdState (index%)
- Static old%
- Dim Res&
- If Haupt!Cmd_Array(index%).Enabled Then
- Res& = SendMessage(Haupt!Cmd_Array(index%).hWnd, &H403, -1, 0)
- Else
- Res& = SendMessage(Haupt!Cmd_Array(index%).hWnd, &H403, 0, 0)
- End If
- If old% = index% Then Exit Sub
- Res& = SendMessage(Haupt!Cmd_Array(old%).hWnd, &H403, 0, 0)
- old% = index%
- End Sub
-
- Sub PM_ClearDB ()
- Dim fd As Integer
- fd = FreeFile
- Kill GCM_DBNAME
- End Sub
-
- Sub PM_EditFile (dn$)
- Dim fd As Integer
- Dim L_LengthOfFile%
- Dim tmp$
- fd = FreeFile
- L_LengthOfFile% = FileLen(dn$)
- tmp$ = Space$(L_LengthOfFile%)
- Open dn$ For Binary As fd Len = L_LengthOfFile%
- Get fd, 1, tmp$
- G_EditFile$ = tmp$
- Close fd
- EditFile.Caption = dn$
- EditFile.Show
- End Sub
-
- Sub PM_GenerateDB (Pfad$)
- Dim I%, Res%
- If ExistDir(Pfad$) Then
- PM_ClearDB
- ListSubDirs Pfad$, GM_DBAll()
- For I% = 1 To UBound(GM_DBAll)
- GM_DB = GM_DBAll(I%)
- Res% = FM_SchreibDB()
- Next I%
- End If
- End Sub
-
- Sub PM_GetCDINFO (d As TM_DBRec)
- Dim tmp$, fd%, Zeile$, pos%
- tmp$ = Trim$(d.Verzeichnis$)
- If Right$(tmp$, 1) <> "\" Then tmp$ = tmp$ + "\"
- tmp$ = Trim$(tmp$) + "CDINFO.TXT"
- fd = FreeFile
- On Error Resume Next
- Open tmp$ For Input As fd
- If Err <> 0 Then Exit Sub
- If Not EOF(fd) Then
- Line Input #fd, Zeile$
- pos% = InStr(UCase$(Zeile$), GCM_VERZEICHNIS)
- If pos% Then
- d.Bezeichnung$ = Mid$(Zeile$, pos% + Len(GCM_VERZEICHNIS))
- End If
- If Not EOF(fd) Then
- Line Input #fd, Zeile$
- pos% = InStr(UCase$(Zeile$), GCM_PROJEKT)
- If pos% Then
- d.Code = 1
- Else
- d.Code = 0
- End If
- End If
- End If
- Close fd
- End Sub
-
- Sub PM_GetChilds (ID&, d())
- Dim fd As Integer
- Dim I%
- fd = FreeFile
- Open GCM_DBNAME For Random As fd Len = Len(GM_DB)
- For I% = 1 To LOF(fd) / Len(GM_DB)
- Get #fd, I%, GM_DB
- If GM_DB.Vater = ID& Then
- d(UBound(d)) = I%
- ReDim Preserve d(UBound(d) + 1)
- End If
- Next I%
- Close fd
- End Sub
-
- Sub PM_GetFileInfo (dn$)
- Dim ds As Integer
- Dim pos%
- Dim Zeile$
- Dim Ub%
- ds = FreeFile
- Open dn$ For Input As ds
- Line Input #ds, Zeile$
- pos% = InStr(Zeile$, GCM_VERZEICHNIS)
- If pos% Then ' Verzeichnis
- On Error Resume Next
- Ub% = UBound(GM_Outline)
- On Error GoTo 0
- Ub% = Ub% + 1
- ReDim Preserve GM_Outline(Ub%)
- GM_Outline(Ub%).Bezeichnung = Mid$(Zeile$, pos% + Len(GCM_VERZEICHNIS))
- End If
- If Not EOF(ds) Then
- Line Input #ds, Zeile$
- pos% = InStr(Zeile$, GCM_PROJEKT)
- If pos% Then
- GM_Outline(Ub%).hat_unter_obj = False
- Else
- GM_Outline(Ub%).hat_unter_obj = True
- End If
- Else
- GM_Outline(Ub%).hat_unter_obj = True
- End If
- Close #ds
- End Sub
-
- Sub PM_GetParents (ID&, d())
- Dim fd As Integer
- Dim I%
- fd = FreeFile
- Open GCM_DBNAME For Random As fd Len = Len(GM_DB)
- For I% = 1 To LOF(fd) / Len(GM_DB)
- Get #fd, I%, GM_DB
- If GM_DB.Vater = ID& Then
- d(UBound(d)) = I%
- ReDim Preserve d(UBound(d) + 1)
- End If
- Next I%
- Close fd
- End Sub
-
- Sub PM_LeseEintrag (index As Long, ByVal ID As Long, Ebene%)
- Dim Vater&
- Dim LM_DB As TM_DBRec
- Dim tmpIndex&
- ReDim d(1)
- Dim cnt%, I%, Res%
- Res% = FM_LiesDB(ID&)
- LM_DB = GM_DB
- If ID > 0 Then
- PM_LeseEintrag index&, LM_DB.Vater&, Ebene%
- PM_GetParents ID&, d()
- For I% = 1 To UBound(d) - 1
- Res% = FM_LiesDB(CLng(d(I%)))
- If Res% <> 0 Then
- Haupt.Outline.AddItem GM_DB.Bezeichnung, index
- Haupt.Outline.ItemData(index) = Res%
- Haupt.Outline.Indent(index) = Ebene%
- If Not GM_DB.Code Then
- Haupt.Outline.PictureType(index&) = 0
- Else
- Haupt.Outline.PictureType(index&) = 2
- End If
- If Haupt.Outline.ItemData(index) = LM_DB.Vater& Then
- tmpIndex& = index&
- Haupt.Outline.Expand(index&) = True
- End If
- index& = index& + 1
- End If
- Next I%
-
- If tmpIndex& <> 0 Then index& = tmpIndex& + 1
- Else
- Res% = FM_LiesDB(1)
- Ebene% = 1
- If Res% <> 0 Then
- Haupt.Outline.AddItem GM_DB.Bezeichnung, index
- Haupt.Outline.ItemData(index) = Res%
- Haupt.Outline.Indent(index) = Ebene%
- If Not GM_DB.Code Then
- Haupt.Outline.PictureType(index&) = 0
- Else
- Haupt.Outline.PictureType(index&) = 2
- End If
- If Haupt.Outline.ItemData(index) = LM_DB.Vater& Then
- Haupt.Outline.Expand(index&) = True
- tmpIndex& = index&
- End If
- index& = index& + 1
- End If
- End If
- Ebene% = Ebene% + 1
- End Sub
-
- Sub PM_Lies (ID&)
- Dim index&
- Dim Ebene%
- index& = 0
- Haupt.Outline.Clear
- PM_LeseEintrag index&, ID&, Ebene%
- End Sub
-
- Sub PM_LiesCDInfo (Verzeichnis$)
- Dim fd As Integer
- Dim l&
- Dim L_CDInfoFilename$
- If Right$(Verzeichnis$, 1) <> "\" Then
- L_CDInfoFilename$ = Verzeichnis$ + "\" + GCM_INFOFILENAME
- Else
- L_CDInfoFilename$ = Verzeichnis$ + GCM_INFOFILENAME
- End If
- l& = FileLen(L_CDInfoFilename$)
- G_CDInfoFile$ = Space$(l&)
- fd = FreeFile
- Open L_CDInfoFilename$ For Binary As fd Len = l&
- Get #fd, , G_CDInfoFile$
- Close fd
- End Sub
-
- ' --------------------------------------------------------
- ' Liest die ben÷tigten Control-Informationen aus dem
- ' Initialisierungsfile
- ' --------------------------------------------------------
- ' Autor : NM/ag
- ' Datum : 10.2.94
- ' Version : 1.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
- ' Version : 1.0
- ' --------------------------------------------------------
- Sub PM_LiesForm (Frm As Form)
- Dim L_Ini_Zeile$, Eigenschaft$
- 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
-
- Sub PM_LiesOutline (pos%)
- Dim fd As Integer
- fd = FreeFile
- Open GCM_DBNAME For Random As fd Len = Len(GM_DB)
- Get fd, pos%, GM_DB
- Haupt.Outline.AddItem GM_DB.Bezeichnung
- Haupt.Outline.ItemData(0) = pos%
- Haupt.Outline.Indent(1) = 2
- Close fd
- Haupt.Outline.Refresh
- End Sub
-
- Sub PM_ReadCDInfo ()
- Dim Res&
- Dim pos%
- Dim L_CDInfoCommands$
- Dim tmp$
- Dim MakDatei$, HilfeDatei$
- Res& = FM_LiesDB(Val(Haupt!Outline.ItemData(Haupt!Outline.ListIndex)))
- PM_LiesCDInfo Trim$(GM_DB.Verzeichnis$)
- pos% = InStr(UCase$(G_CDInfoFile$), GCM_INFO)
- If pos% <> 0 Then
- Haupt!Lbl_Info.Caption = Mid$(G_CDInfoFile$, pos% + Len(GCM_INFO))
- Haupt!Lbl_Info.Visible = True
- Haupt!Cmd_Array(GCM_CMD_INFO).Enabled = True
- Haupt!Cmd_Array(GCM_CMD_INFO) = True
- L_CDInfoCommands$ = UCase$(Left$(G_CDInfoFile$, pos% - 1))
- Else
- Haupt!Cmd_Array(GCM_CMD_INFO).Enabled = False
- Haupt!Lbl_Info.Visible = False
- Haupt!Lbl_Info.Caption = ""
- Haupt!Cmd_Array(6) = True
- L_CDInfoCommands$ = UCase$(G_CDInfoFile$)
- End If
- pos% = InStr(L_CDInfoCommands$, GCM_DEMO)
- If pos% <> 0 Then
- Haupt!Cmd_Array(GCM_CMD_DEMO).Enabled = True
- tmp$ = Mid$(L_CDInfoCommands$ + Chr$(13), pos% + Len(GCM_DEMO))
- Haupt!Cmd_Array(GCM_CMD_DEMO).Tag = Left$(tmp$, InStr(tmp$, Chr$(13)) - 1)
- Else
- Haupt!Cmd_Array(GCM_CMD_DEMO).Enabled = False
- End If
- pos% = InStr(L_CDInfoCommands$, GCM_PROJEKT)
- If pos% <> 0 Then
- Haupt!Cmd_Array(GCM_CMD_COPY).Enabled = True
- Else
- Haupt!Cmd_Array(GCM_CMD_COPY).Enabled = False
- End If
- tmp$ = FM_Verz$(GM_DB.Verzeichnis$) + "*.MAK"
- MakDatei$ = Dir$(tmp$)
- If MakDatei$ <> "" Then
- Haupt!Cmd_Array(GCM_CMD_CODE).Enabled = True
- Haupt!Cmd_Array(GCM_CMD_CODE).Tag = FM_Verz$(GM_DB.Verzeichnis$)
- Else
- Haupt!Cmd_Array(GCM_CMD_CODE).Enabled = False
- End If
- pos% = InStr(L_CDInfoCommands$, GCM_INSTALL)
- If pos% <> 0 Then
- Haupt!Cmd_Array(GCM_CMD_INSTALL).Enabled = True
- tmp$ = Mid$(L_CDInfoCommands$ + Chr$(13), pos% + Len(GCM_INSTALL))
- Haupt!Cmd_Array(GCM_CMD_INSTALL).Tag = Left$(tmp$, InStr(tmp$, Chr$(13)) - 1)
- Else
- Haupt!Cmd_Array(GCM_CMD_INSTALL).Enabled = False
- End If
- tmp$ = FM_Verz$(GM_DB.Verzeichnis$) + "*.HLP"
- HilfeDatei$ = Dir$(tmp$)
- If HilfeDatei$ <> "" Then
- Haupt!Cmd_Array(GCM_CMD_HILFE).Enabled = True
- Haupt!Cmd_Array(GCM_CMD_HILFE).Tag = "WinHelp " & FM_Verz$(GM_DB.Verzeichnis$) & HilfeDatei$
- Else
- Haupt!Cmd_Array(GCM_CMD_HILFE).Enabled = False
- End If
- PM_ChangeCmdState (0)
- End Sub
-
- Sub PM_ReadItems (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% < Haupt.Outline.ListCount Then
- If Haupt.Outline.List(ListIndex%) = "Hilfs" Then
- Haupt.Outline.List(ListIndex%) = GM_DB.Bezeichnung$
- Else
- Haupt.Outline.AddItem GM_DB.Bezeichnung, ListIndex%
- End If
- Else
- Haupt.Outline.AddItem GM_DB.Bezeichnung, ListIndex%
- End If
- Haupt.Outline.ItemData(ListIndex%) = Res%
- Haupt.Outline.Indent(ListIndex%) = Ebene%
- If GM_DB.Code = 0 Then
- Haupt.Outline.PictureType(ListIndex%) = 0
- ListIndex% = ListIndex% + 1
- Haupt.Outline.AddItem "Hilfs", ListIndex%
- Haupt.Outline.Indent(ListIndex%) = Ebene% + 1
- Else
- Haupt.Outline.PictureType(ListIndex%) = 2
- End If
- End If
- Next I%
- End Sub
-
- Sub PM_RefreshAnzeige ()
- Haupt!Lbl_Info.Move 4, 2
- Haupt!Lbl_Info.Height = Haupt!Pic_Anzeige.Height - 4
- Haupt!Lbl_Info.Width = FM_Max(Haupt!Pic_Anzeige.Width - 6, 0)
- Haupt!File1.Move 4, 2
- Haupt!File1.Width = Haupt!Lbl_Info.Width
- Haupt!File1.Height = Haupt!Lbl_Info.Height
- If Haupt!Lbl_Info.Visible Then
- Haupt!Pic_Anzeige.BackColor = Haupt!Lbl_Info.BackColor
- Else
- Haupt!Pic_Anzeige.BackColor = Haupt!File1.BackColor
- End If
- End Sub
-
- Sub PM_ScanDirs (Pfad$, Vater&)
- Dim tmp$, Vater_Neu&, totPfad$
- GM_DB.Bezeichnung$ = "Test"
- GM_DB.Vater& = Vater&
- GM_DB.Verzeichnis$ = Pfad$
- Debug.Print Pfad$
- Vater_Neu& = FM_SchreibDB()
- If Right$(Pfad$, 1) <> "\" Then
- totPfad$ = Pfad$ + "\"
- Else
- totPfad$ = Pfad$ + ""
- End If
- tmp$ = Dir$(totPfad$ + "*.*", 16)
- Do While Left$(tmp$, 1) = "."
- tmp$ = Dir$
- Loop
- Do While tmp$ <> ""
- If GetAttr(totPfad$ + tmp$) = 16 Then ' Verzeichnis
- PM_ScanDirs totPfad$ + tmp$, Vater_Neu&
- End If
- tmp$ = Dir$
- Loop
- 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
-
- Sub PM_SeekList (Cntrl As Control, Eintrag$)
- Dim I%
- For I% = 0 To Cntrl.ListCount - 1
- If Cntrl.List(I%) = Eintrag Then
- Cntrl.ListIndex = I%
- Exit For
- End If
- Next I%
- End Sub
-
- Sub PM_ShellAndWait (CommandString$)
- Dim ID%
- Dim X%
- ID% = Shell(CommandString$, 1)
- Do
- DoEvents
- Debug.Print Timer
- Loop Until GetModuleUsage(ID%) = 0
- End Sub
-
- 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
- Dim Tx As Integer
- Dim Ty As Integer
-
- Tx = 1
- Ty = 1
- Frm.AutoRedraw = True
-
- ' 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 TypeOf ct Is Shape Then
- ct.Visible = False
- Frm.DrawWidth = 2
- Frm.Line (ct.Left - (0 * Tx), ct.Top - (0 * Ty))-(ct.Width + (1 * Tx) + ct.Left, ct.Top + ct.Height + (0 * Ty)), DGRAY, B
- Frm.DrawWidth = 1
- Frm.Line (ct.Left - (1 * Tx), ct.Top - (1 * Ty))-(ct.Width + (0 * Tx) + ct.Left, ct.Top + ct.Height - (1 * Ty)), WHITE, 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 + Tx
- Frm.CurrentY = ct.Top + Ty
- 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 * 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
- End If
- If TypeOf ct Is ListBox Then
- 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 If
- If TypeOf ct Is ComboBox Then
- 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 If
- If TypeOf ct Is Line Then
- ct.Visible = False
- Frm.Line (ct.X1 + (1 * Tx), ct.Y1 + (1 * Ty))-(ct.X2 + (1 * Tx), ct.Y2 + (1 * Ty)), DGRAY
- Frm.Line (ct.X1 + (0 * Tx), ct.Y1 + (0 * Ty))-(ct.X2 + (0 * Tx), ct.Y2 + (0 * Ty)), WHITE
- End If
-
- Next I
- Frm.AutoRedraw = False
-
- End Sub
-
-