PDA Software Library/pdasoftwarelib.iso/PILOT/support/GCM13/CBASVIEW/CBASVIEW.FRM

Visual Basic Form | 1996-11-16 | 16.2 KB | 498 lines

VERSION 4.00
Begin VB.Form Form1
   Caption         =   "cBasView 0.1"
   ClientHeight    =   4860
   ClientLeft      =   1140
   ClientTop       =   1575
   ClientWidth     =   6690
   Height          =   5295
   Left            =   1080
   LinkMode        =   1  'Source
   LinkTopic       =   "notify"
   ScaleHeight     =   4860
   ScaleWidth      =   6690
   Top             =   1200
   Width           =   6810
   Begin VB.CommandButton btnOpen
      Caption         =   "&Open"
      Height          =   375
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   1335
   End
   Begin VB.TextBox Text1
      Height          =   4335
      Left            =   2640
      MultiLine       =   -1  'True
      TabIndex        =   4
      Text            =   "cBasView.frx":0000
      Top             =   120
      Width           =   3855
   End
   Begin VB.CommandButton btnDelete
      Caption         =   "D&elete"
      Height          =   375
      Left            =   1200
      TabIndex        =   3
      Top             =   4320
      Width           =   975
   End
   Begin VB.CommandButton btnNew
      Caption         =   "&New"
      Height          =   375
      Left            =   120
      TabIndex        =   2
      Top             =   4320
      Width           =   975
   End
   Begin VB.ListBox List1
      Height          =   2985
      Left            =   120
      TabIndex        =   1
      Top             =   1200
      Width           =   2055
   End
   Begin VB.Label lblStatus
      Caption         =   "Label2"
      Height          =   255
      Left            =   2640
      TabIndex        =   6
      Top             =   4560
      Width           =   3855
   End
   Begin MSComDlg.CommonDialog CommonDialog1
      Left            =   1800
      Top             =   120
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin VB.Line Line1
      X1              =   2400
      X2              =   2400
      Y1              =   120
      Y2              =   4680
   End
   Begin VB.Label Label1
      Caption         =   "Programs:"
      Height          =   255
      Left            =   120
      TabIndex        =   0
      Top             =   840
      Width           =   1695
   End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Const TNAME = 0
Const TCONDUIT = 1
Const TMODULE = 2
Const TCREATOR = 3
Const TREMOTE = 4
Const TDIRECTORY = 5
Const TFILE = 6
Const TBACKUPS = 7
Const TSYNCSOURCE = 8
Const TNEXTSYNCSOURCE = 9
Const TNOTIFYAPPSERVICE = 10
Const TNOTIFYAPPTOPIC = 11
Const TAPPLICATIONX = 12
Const TDISABLE = 13
Dim nNextApp As Integer
Dim bRecordDirty As Integer
Dim nCurrListIndex As Integer
Const REG_SZ As Long = 1
Const REG_DWORD As Long = 4
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const ERROR_NONE = 0
Const ERROR_BADDB = 1
Const ERROR_BADKEY = 2
Const ERROR_CANTOPEN = 3
Const ERROR_CANTREAD = 4
Const ERROR_CANTWRITE = 5
Const ERROR_OUTOFMEMORY = 6
Const ERROR_INVALID_PARAMETER = 7
Const ERROR_ACCESS_DENIED = 8
Const ERROR_INVALID_PARAMETERS = 87
Const ERROR_NO_MORE_ITEMS = 259
Const KEY_ALL_ACCESS = &H3F
Const REG_OPTION_NON_VOLATILE = 0
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias _
   "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
   ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions _
   As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes _
   As Long, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
    "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
    ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias _
    "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
    String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
    As String, lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias _
    "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
    String, ByVal lpReserved As Long, lpType As Long, lpData As _
    Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias _
    "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As _
    String, ByVal lpReserved As Long, lpType As Long, ByVal lpData _
    As Long, lpcbData As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
    ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
    String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias _
    "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
    ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
    ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
    (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Const sMainKey = "Software\Palm Computing\Pilot Desktop"
Dim sFileName As String
Private Type tHeader
  sName As String * 32
  dwUnknown1 As Long
  dwTime1 As Long
  dwTime2 As Long
  dwTime3 As Long
  dwLastSync As Long
  ofsSort As Long
  ofsCategories As Long
  dwCreator As Long
  dwType As Long
  dwUnknown2  As Long
  dwUnknown As Long
  wNumRecs As Integer
End Type
Const kOfsSort = &H34
Const kOfsCategories = &H38
Const kOfsCreator = &H3C
Const kOfsNumRecs = &H4C
Const kOfsEntries = &H4E
Private Type tRecEntry
  ofs As Long
  attrib As Long
End Type
Const DIRTY = &H40000000
Const DELETED = &H80000000
Dim head As tHeader
'these three arrays hold ALL the data, includind deleted entries
Dim recIndex() As tRecEntry
Dim attrib_data() As Byte
Dim recs() As Variant
Dim bDirty As Integer
Dim bLoading As Integer 'works with to prevent spurious setting of bDirty
Dim nCurrRec As Integer 'points to the current entry within the whold file
    'on screen, List1 holds the non-deleted records
    'List1.ItemData() holds the nCurrRec index, which points into the whole file arrays above
Dim bEndianSwapped As Integer
    'set when the numbers have been twisted into Mac format
Public Sub AddCR(s As String)
    Dim i As Integer
    i = InStr(s, Chr(0))
    If i Then s = Left(s, i - 1)
    i = InStr(s, Chr(10))
    While (i)
        s = Left(s, i - 1) & Chr(13) & Mid(s, i)
        i = InStr(i + 2, s, Chr(10))
    Wend
End Sub
Private Function GetFileName() As String
    GetFileName = ""
    Dim lRetVal As Long
    Dim hKey As Long
    lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sMainKey & "\Preferences", 0, KEY_ALL_ACCESS, hKey)
    If lRetVal = ERROR_NONE Then
        Dim val As Variant
        lRetVal = QueryValueEx(hKey, "LastUserDir", val)
        If lRetVal = ERROR_NONE Then GetFileName = val & "\cbasview\cbasvw.dat"
    End If
End Function
Function QueryValueEx(ByVal lhKey As Long, _
    ByVal szValueName As String, _
    vValue As Variant) As Long
        Dim cch As Long
        Dim lrc As Long
        Dim lType As Long
        Dim lValue As Long
        Dim sValue As String
        On Error GoTo QueryValueExError
        ' Determine the size and type of data to be read
        lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
        If lrc <> ERROR_NONE Then Error 5
        Select Case lType
            ' For strings
            Case REG_SZ:
                sValue = String(cch, 0)
                lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
                If lrc = ERROR_NONE Then
                    vValue = Left$(sValue, cch - 1) 'RegQuery returns the 0 term
                Else
                    vValue = Empty
                End If
            ' For DWORDS
            Case REG_DWORD:
                lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
                If lrc = ERROR_NONE Then vValue = lValue
            Case Else
                'all other data types not supported
                lrc = -1
        End Select
QueryValueExExit:
        QueryValueEx = lrc
        Exit Function

QueryValueExError:
        Resume QueryValueExExit
End Function


Private Sub LoadRecords()
    bDirty = False
    List1.Clear
    On Error GoTo lr_err
    Open sFileName For Binary Access Read As #1
    Get #1, , head
    head.wNumRecs = SwapWord(head.wNumRecs)
    head.ofsSort = SwapLong(head.ofsSort)
    Dim i As Integer
    ReDim recIndex(head.wNumRecs) As tRecEntry
    For i = 0 To head.wNumRecs - 1
        Get #1, , recIndex(i)
        recIndex(i).ofs = SwapLong(recIndex(i).ofs)
        recIndex(i).attrib = SwapLong(recIndex(i).attrib)
    Next
    If head.ofsSort > recIndex(0).ofs Then head.ofsSort = recIndex(0).ofs
    ReDim attrib_data(recIndex(0).ofs - head.ofsSort) As Byte
    Seek #1, head.ofsSort + 1
    Get #1, , attrib_data
    ReDim recs(head.wNumRecs)
    Dim dwFileLen
    dwFileLen = FileLen(sFileName)
    Dim r As String
    For i = 0 To head.wNumRecs - 1
        Seek #1, recIndex(i).ofs + 1
        Dim dwLen
        If i < head.wNumRecs - 1 Then
            dwLen = recIndex(i + 1).ofs - recIndex(i).ofs
        Else
            dwLen = dwFileLen - recIndex(i).ofs
        End If
        r = Space(dwLen)
        Seek #1, recIndex(i).ofs + 1
        Get #1, , r
        AddCR r
        recs(i) = r
        'if it's not deleted, show it
        If (recIndex(i).attrib And DELETED) = 0 Then
            List1.AddItem r
            List1.ItemData(List1.ListCount - 1) = i
        End If
    Next
    Close #1
    'this is required to make sure the text swapping works
    Text1.Enabled = False
    nCurrRec = 0
    If List1.ListCount > 0 Then
        List1.ListIndex = 0
        btnNew.Enabled = True
        btnDelete.Enabled = True
        List1.Enabled = True
    End If
    bDirty = False
lr_err:
    Close #1
    On Error GoTo 0
End Sub
Public Sub RemoveCR(s As String)
    Dim i As Integer
    i = InStr(s, Chr(13))
    While (i)
        s = Left(s, i - 1) & Mid(s, i + 1)
        i = InStr(i, s, Chr(13))
    Wend
End Sub
Public Sub SaveRecords()
    On Error GoTo lr_err
    Open sFileName For Binary Access Write As #1
    'restore mac patterns
    Dim nRecs As Integer
    nRecs = head.wNumRecs
    head.wNumRecs = SwapWord(head.wNumRecs)
    head.ofsSort = SwapLong(head.ofsSort)
    Put #1, , head
    'restore
    head.wNumRecs = SwapWord(head.wNumRecs)
    head.ofsSort = SwapLong(head.ofsSort)
    Dim i As Integer
    For i = 0 To nRecs - 1
       recIndex(i).ofs = SwapLong(recIndex(i).ofs)
       recIndex(i).attrib = SwapLong(recIndex(i).attrib)
       Put #1, , recIndex(i)
       'and restore
       recIndex(i).ofs = SwapLong(recIndex(i).ofs)
       recIndex(i).attrib = SwapLong(recIndex(i).attrib)
    Next
    Dim dwPos As Long
    Dim dwPosEnd As Long
    Dim s As String
    'just after the rec index
    dwPos = Seek(1) - 1
    'save the sort data
    Put #1, , attrib_data
    'remember eof
    dwPosEnd = Seek(1) - 1
    'go back and write offset
    Seek #1, kOfsSort + 1  'where the ofsSort data goes
    dwPos = SwapLong(dwPos)
    Put #1, , dwPos
    For i = 0 To nRecs - 1
        'go back to eof
        Seek #1, dwPosEnd + 1
        dwPos = dwPosEnd
        s = recs(i)
        RemoveCR s
        Put #1, , s
        s = Chr(0)
        Put #1, , s 'zero terminate the strings
        dwPosEnd = Seek(1) - 1
        'back into the index
        Seek #1, kOfsEntries + i * 8 + 1
        dwPos = SwapLong(dwPos)
        Put #1, , dwPos
    Next
    Reset
lr_err:
    Close #1
    On Error GoTo 0
End Sub
Private Sub Status()
    Dim s As String
    s = "Status: rec #" & Format(nCurrRec) & "(" & Hex(recIndex(nCurrRec).attrib And &HFFFFFF)
    s = s & ")  len: " & Format(Len(recs(nCurrRec)))
    If recIndex(nCurrRec).attrib And DIRTY Then s = s & "   modified"
    lblStatus.Caption = s
End Sub
Private Sub btnDelete_Click()
    'check for empty list
    If head.wNumRecs = 0 Then Exit Sub
    'assert
    If nCurrRec <> List1.ItemData(List1.ListIndex) Then
        MsgBox "There is a problem with the internal operation of this program. The item has NOT been deleted. Please contact the author at [e-mail]"
        Exit Sub
    End If
    'clean up data structs, set the dirty bit
    Dim i As Integer
    i = List1.ItemData(List1.ListIndex)
    recIndex(i).attrib = recIndex(i).attrib Or DELETED
    'clean up list box
    i = List1.ListIndex
    List1.RemoveItem i
    If List1.ListCount > 0 Then
        If i = List1.ListCount Then
            List1.ListIndex = i - 1
        Else
            List1.ListIndex = i
        End If
        nCurrRec = List1.ItemData(List1.ListIndex)
    Else
        Text1.Enabled = False
    End If
    bDirty = True
End Sub
Private Sub btnNew_Click()
    head.wNumRecs = head.wNumRecs + 1
    ReDim Preserve recIndex(head.wNumRecs)
    ReDim Preserve recs(head.wNumRecs)
    Dim n As Integer
    n = head.wNumRecs - 1
    nCurrRec = n
    recIndex(n).attrib = DIRTY
    recs(n) = "#enter text here"
    List1.AddItem recs(n)
    'note: must set itemdata first!
    List1.ItemData(List1.NewIndex) = n
    List1.ListIndex = List1.NewIndex
    bDirty = True
    Text1.SetFocus
End Sub
Private Sub btnOpen_Click()
    On Error GoTo open_err
    CommonDialog1.CancelError = True
    ' **************open - aka input file**********************************
    ' Set filters.
    CommonDialog1.Filter = "cBasPadFiles (*.dat)|*.dat|cBasPad Files (*.pdb) |*.pdb| All Files (*.*) |*.*"
    ' Specify default filter, .pdp files
    CommonDialog1.FilterIndex = 1
    CommonDialog1.DialogTitle = "Browse for Input File"
    ' Set flags for open dialog
    CommonDialog1.Flags = cdlOFNPathMustExist + cdlOFNFileMustExist + cdlOFNReadOnly
    ' Display the File Open dialog box.
    CommonDialog1.ShowOpen
    sFileName = CommonDialog1.filename
    LoadRecords
    Exit Sub
open_err:
    On Error GoTo 0
End Sub
Private Sub Form_LinkExecute(CmdStr As String, Cancel As Integer)
    Static sTitle As String
    Select Case CmdStr
        Case "sync start"
            If bDirty Then SaveRecords
            sTitle = Form1.Caption
            Form1.Caption = sTitle & " (syncing)"
            Me.Enabled = False
        Case "sync finished"
            Me.Enabled = True
            Form1.Caption = sTitle
            LoadRecords
    End Select
End Sub
Public Function SwapWord(w As Integer)
    Dim s As String
    s = Right("000" & Hex(w), 4)
    SwapWord = val("&H" & Mid(s, 3, 2) & Mid(s, 1, 2))
End Function
Public Function SwapLong(d As Long)
    Dim s As String
    s = Right("0000000" & Hex(d), 8)
    SwapLong = val("&H" & Mid(s, 7, 2) & Mid(s, 5, 2) & Mid(s, 3, 2) & Mid(s, 1, 2))
End Function
Private Sub Form_Load()
    btnNew.Enabled = False
    btnDelete.Enabled = False
    Text1.Enabled = False
    List1.Enabled = False
    sFileName = GetFileName
    If sFileName <> "" Then
        LoadRecords
    End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
    If bDirty Then SaveRecords
End Sub
Private Sub List1_Click()
    Text1.Enabled = True
    bLoading = True
    nCurrRec = List1.ItemData(List1.ListIndex)
    Text1.Text = recs(nCurrRec)
    bLoading = False
End Sub
Private Sub Text1_Change()
    If Not bLoading Then
        bDirty = True
        recIndex(nCurrRec).attrib = recIndex(nCurrRec).attrib Or DIRTY
        recs(nCurrRec) = Text1.Text
        List1.List(List1.ListIndex) = Text1.Text
    End If
    Status
End Sub