home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
code
/
cdspy
/
parse.frm
< prev
next >
Wrap
Text File
|
1995-02-27
|
7KB
|
235 lines
VERSION 2.00
Begin Form Form1
Caption = "Parse Directory"
ClientHeight = 2985
ClientLeft = 1095
ClientTop = 1485
ClientWidth = 5295
Height = 3390
Left = 1035
LinkTopic = "Form1"
ScaleHeight = 2985
ScaleWidth = 5295
Top = 1140
Width = 5415
Begin CommandButton Command1
Caption = "single"
Height = 375
Left = 4230
TabIndex = 5
Top = 2430
Width = 735
End
Begin DriveListBox Drive1
Height = 315
Left = 270
TabIndex = 2
Top = 180
Width = 2085
End
Begin FileListBox File1
Height = 1590
Left = 2520
Pattern = "*.TXT;*.FRM;*.BAS"
TabIndex = 1
Top = 630
Width = 1995
End
Begin DirListBox Dir1
Height = 1605
Left = 270
TabIndex = 0
Top = 630
Width = 2085
End
Begin CommandButton Btn_Ende
Caption = "Ende"
Height = 375
Left = 990
TabIndex = 4
Top = 2430
Visible = 0 'False
Width = 3075
End
Begin CommandButton Parse
Caption = "Parse"
Height = 375
Left = 990
TabIndex = 3
Top = 2430
Width = 3075
End
End
Option Explicit
Dim closing%
Sub Btn_Ende_Click ()
closing% = True
Beep
Beep
Beep
Beep
Btn_Ende.Visible = False
End Sub
Sub Command1_Click ()
Dim i%, fh%, zeile$, db As database, ds As dynaset
Dim j%
ChDrive drive1.Drive
ChDir dir1.Path
Me.Refresh
If Not FM_exists("WORTE.YZX") And (file1.ListCount > 0) Then
PM_ShellAndWait ("XCOPY C:\TEMP\WORTE.MDB")
Set db = OpenDatabase("WORTE.MDB")
Set ds = db.CreateDynaset("T_Worte")
db.BeginTrans
For i% = 0 To file1.ListCount - 1
file1.ListIndex = i%
DoEvents
If file1 <> "CDINFO.TXT" And file1.ListCount > 0 Then
fh% = FreeFile
Open file1 For Input As fh%
Do While Not EOF(fh%)
Line Input #fh%, zeile$
Dim ii%, zch%, l%
Dim wort$
zeile$ = LCase(zeile$)
For ii% = 1 To Len(zeile$)
DoEvents
zch% = Asc(Mid$(zeile$, ii%, 1))
If zch% >= 97 And zch% <= 122 Or zch% = 228 Or zch% = 246 Or zch% = 252 Then
wort$ = wort$ + Chr$(zch%)
l% = l% + 1
Else
If Trim(wort$) <> "" And l% > 2 Then
' Wort anzuhΣngen versuchen
If l% < 36 Then
ds.AddNew
ds!wort = wort$
ds!filename = file1
On Error Resume Next
ds.Update
Err = 0
On Error GoTo 0
End If
wort$ = ""
l% = 0
Else
wort$ = ""
l% = 0
End If
End If
Next ii%
Loop
Close fh%
End If
Next i%
db.CommitTrans
If ds.RecordCount > 0 Then
fh% = FreeFile
Open "WORTE.YZX" For Output As fh%
ds.MoveFirst
Do While Not ds.EOF
Print #fh%, ds!wort; ","; ds!filename
ds.MoveNext
Loop
Close
End If
ds.Close
db.Close
Kill "WORTE.MDB"
Kill "WORTE.LDB"
End If
MsgBox "Geparsed"
End Sub
Sub Dir1_Change ()
file1.Path = dir1.Path
End Sub
Sub Drive1_Change ()
dir1.Path = drive1.Drive
End Sub
Sub Parse_Click ()
Dim i%, fh%, zeile$, db As database, ds As dynaset
Dim j%
PM_ListSubDirs "N:\SORTED", GM_DBAll()
drive1.Drive = GM_DBAll(1).Verzeichnis$
Btn_Ende.Visible = True
For j% = 1 To UBound(GM_DBAll)
If closing% Then Exit For
dir1.Path = GM_DBAll(j%).Verzeichnis$
Me.Refresh
ChDrive drive1.Drive
ChDir dir1.Path
Me.Refresh
If Not FM_exists("WORTE.YZX") And (file1.ListCount > 0) Then
PM_ShellAndWait ("XCOPY C:\TEMP\WORTE.MDB")
Set db = OpenDatabase("WORTE.MDB")
Set ds = db.CreateDynaset("T_Worte")
db.BeginTrans
For i% = 0 To file1.ListCount - 1
file1.ListIndex = i%
DoEvents
If file1 <> "CDINFO.TXT" And file1.ListCount > 0 Then
fh% = FreeFile
Open file1 For Input As fh%
Do While Not EOF(fh%)
Line Input #fh%, zeile$
Dim ii%, zch%, l%
Dim wort$
zeile$ = LCase(zeile$)
For ii% = 1 To Len(zeile$)
DoEvents
zch% = Asc(Mid$(zeile$, ii%, 1))
If zch% >= 97 And zch% <= 122 Or zch% = 228 Or zch% = 246 Or zch% = 252 Then
wort$ = wort$ + Chr$(zch%)
l% = l% + 1
Else
If Trim(wort$) <> "" And l% > 2 Then
If l% < 36 Then
' Wort anzuhΣngen versuchen
ds.AddNew
ds!wort = wort$
ds!filename = file1
On Error Resume Next
ds.Update
Err = 0
On Error GoTo 0
End If
wort$ = ""
l% = 0
Else
wort$ = ""
l% = 0
End If
End If
Next ii%
Loop
Close fh%
End If
Next i%
db.CommitTrans
If ds.RecordCount > 0 Then
fh% = FreeFile
Open "WORTE.YZX" For Output As fh%
ds.MoveFirst
Do While Not ds.EOF
Print #fh%, ds!wort; ","; ds!filename
ds.MoveNext
Loop
Close
End If
ds.Close
db.Close
Kill "WORTE.MDB"
Kill "WORTE.LDB"
End If
Next j%
MsgBox "Parsing fertig"
End Sub