' FilePropsAdd.bas for FilmStar DESIGN
' Copyright 2011 FTG Software Associates
'
' ****************************************************
' Warning: Save modified program with new name!!!
' ****************************************************
'
' This program adds FILM Archive file description and graph
' titles to NTFS File Properties. USERS SHOULD BACK-UP FILES
' BEFORE PROCEEDING.
'
Option Explicit
Const DesPath$ = "C:\Winfilm\Designs"
Sub Main
On Error Resume Next
Dim k%, titl As String * 50, desc As String*50, file$
Dim d1$, d2$, d3$, d4$, d5$, d6$, RO As Boolean
If MsgBox("This program adds NTFS file properties To FILM Archive" _
& vbLf & "files in " & DesPath$, vbOkCancel + vbInformation, _
"NTFS File Utility") = vbCancel Then End
file$ = Dir(DesPath$ & "\*.faw")
StatusLabel "Busy - please wait"
Do
k = k + 1
If k > 1 Then file$ = Dir
If file$ = "" Then Exit Do
If LCase$(Left$(file$, 4)) <> "work" Then
FilePropsGet DesPath$ & "\" & file$, d1$, d2$, d3$, _
d4$, d5$, d6$, RO
' Skip files with NTFS properties; skip read-only files
If d2$ = "" And Not RO Then
Open DesPath$ & "\" & file$ For Binary As #1
StringGet 1, desc$
' Skip 'Work' files
If LCase(Left$(desc$, 9)) <> "work file" Then
Get #1, 125, titl$ ' get graph axes title
If Trim$(titl$) <> "" Or Trim$(desc$)<> "" Then _
If Not FilePropsSet(Trim$(titl$), Trim$(desc$), _
DesPath$ & "\" & file$) Then End
End If
End If
Close #1
End If
Loop
StatusLabel "Task completed"
End Sub
Sub StringGet(ByVal kFN, s$, Optional ByVal j&)
Dim k&
k& = Len(s$)
ReDim a(k) As Byte
If j = 0 Then Get #kFN, , a() Else Get #kFN, j, a()
s$ = StrConv(a(), vbUnicode)
End Sub
