PDA Software Library/pdasoftwarelib.iso/PILOT/PC/GCM/PMONEY/FORM1.FRM

Visual Basic Form | 1996-11-26 | 20.2 KB | 595 lines

VERSION 4.00
Begin VB.Form Form1
   Caption         =   "Pilot Money Viewer 1.0"
   ClientHeight    =   5895
   ClientLeft      =   1140
   ClientTop       =   1575
   ClientWidth     =   6720
   Height          =   6330
   Left            =   1080
   LinkMode        =   1  'Source
   LinkTopic       =   "notify"
   ScaleHeight     =   5895
   ScaleWidth      =   6720
   Top             =   1200
   Width           =   6840
   Begin VB.Frame FrameGeneral
      Caption         =   "General Setting"
      Height          =   5295
      Left            =   6720
      TabIndex        =   6
      Top             =   0
      Visible         =   0   'False
      Width           =   4335
      Begin VB.ComboBox comboTrans
         Height          =   315
         Left            =   1320
         Style           =   2  'Dropdown List
         TabIndex        =   12
         Top             =   960
         Width           =   2895
      End
      Begin VB.ComboBox comboTypes
         Height          =   315
         Left            =   1320
         Style           =   2  'Dropdown List
         TabIndex        =   11
         Top             =   600
         Width           =   2895
      End
      Begin VB.ComboBox comboCats
         Height          =   315
         Left            =   1320
         Style           =   2  'Dropdown List
         TabIndex        =   8
         Top             =   240
         Width           =   2895
      End
      Begin VB.Label Label5
         Caption         =   "Transatction"
         Height          =   255
         Left            =   240
         TabIndex        =   10
         Top             =   1080
         Width           =   975
      End
      Begin VB.Label Label4
         Caption         =   "Types"
         Height          =   255
         Left            =   240
         TabIndex        =   9
         Top             =   720
         Width           =   975
      End
      Begin VB.Label Label3
         Caption         =   "Categories"
         Height          =   255
         Left            =   240
         TabIndex        =   7
         Top             =   360
         Width           =   975
      End
   End
   Begin VB.CommandButton btnDone
      Caption         =   "Done"
      Height          =   375
      Left            =   5400
      TabIndex        =   4
      Top             =   5400
      Width           =   1215
   End
   Begin VB.CommandButton btnGeneral
      Caption         =   "General"
      Height          =   375
      Left            =   2280
      TabIndex        =   3
      Top             =   5400
      Width           =   1215
   End
   Begin VB.Frame FrameDetails
      Caption         =   "Details"
      Height          =   5295
      Left            =   2280
      TabIndex        =   2
      Top             =   0
      Width           =   4335
      Begin VB.TextBox txt
         Height          =   285
         Index           =   9
         Left            =   1080
         TabIndex        =   27
         Text            =   "Text1"
         Top             =   2040
         Width           =   3135
      End
      Begin VB.CheckBox chk
         Caption         =   "Private"
         Height          =   255
         Index           =   10
         Left            =   1080
         TabIndex        =   26
         Top             =   2880
         Width           =   1455
      End
      Begin VB.TextBox txt
         Height          =   285
         Index           =   4
         Left            =   1080
         TabIndex        =   25
         Text            =   "Text1"
         Top             =   1680
         Width           =   3135
      End
      Begin VB.CheckBox chk
         Caption         =   "Receipt"
         Height          =   255
         Index           =   8
         Left            =   1080
         TabIndex        =   23
         Top             =   2640
         Width           =   1455
      End
      Begin VB.CheckBox chk
         Caption         =   "Cleared"
         Height          =   255
         Index           =   7
         Left            =   1080
         TabIndex        =   22
         Top             =   2400
         Width           =   1455
      End
      Begin VB.TextBox txt
         Height          =   1095
         Index           =   6
         Left            =   1080
         TabIndex        =   17
         Text            =   "Text1"
         Top             =   3360
         Width           =   3135
      End
      Begin VB.TextBox txt
         Height          =   285
         Index           =   5
         Left            =   1080
         TabIndex        =   16
         Text            =   "Text1"
         Top             =   1320
         Width           =   3135
      End
      Begin VB.TextBox txt
         Height          =   285
         Index           =   3
         Left            =   1080
         TabIndex        =   15
         Text            =   "Text1"
         Top             =   960
         Width           =   3135
      End
      Begin VB.TextBox txt
         Height          =   285
         Index           =   2
         Left            =   1080
         TabIndex        =   14
         Text            =   "Text1"
         Top             =   600
         Width           =   3135
      End
      Begin VB.TextBox txt
         Height          =   285
         Index           =   1
         Left            =   1080
         TabIndex        =   13
         Text            =   "Text1"
         Top             =   240
         Width           =   3135
      End
      Begin VB.Label Label2
         Caption         =   "Category"
         Height          =   255
         Index           =   6
         Left            =   240
         TabIndex        =   28
         Top             =   2040
         Width           =   735
      End
      Begin VB.Label Label2
         Caption         =   "Type"
         Height          =   255
         Index           =   5
         Left            =   240
         TabIndex        =   24
         Top             =   1680
         Width           =   735
      End
      Begin VB.Label Label2
         Caption         =   "Notes:"
         Height          =   255
         Index           =   4
         Left            =   240
         TabIndex        =   21
         Top             =   3360
         Width           =   735
      End
      Begin VB.Label Label2
         Caption         =   "Descript:"
         Height          =   255
         Index           =   3
         Left            =   240
         TabIndex        =   20
         Top             =   1320
         Width           =   735
      End
      Begin VB.Label Label2
         Caption         =   "Date"
         Height          =   255
         Index           =   2
         Left            =   240
         TabIndex        =   19
         Top             =   960
         Width           =   735
      End
      Begin VB.Label Label2
         Caption         =   "Amount"
         Height          =   255
         Index           =   1
         Left            =   240
         TabIndex        =   18
         Top             =   600
         Width           =   735
      End
      Begin VB.Label Label2
         Caption         =   "Check#"
         Height          =   255
         Index           =   0
         Left            =   240
         TabIndex        =   5
         Top             =   240
         Width           =   735
      End
   End
   Begin VB.ListBox List1
      Height          =   5520
      Left            =   120
      TabIndex        =   0
      Top             =   240
      Width           =   2055
   End
   Begin VB.Label Label1
      Caption         =   "Transacation:"
      Height          =   255
      Left            =   120
      TabIndex        =   1
      Top             =   0
      Width           =   1815
   End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
'things to do: if record is deleted, don't show it
' change view screen to a grid
' allow grid export to .CSV file
''''''''''''''''''''''''''''''''''''''''''
'''''' Conduit Manager structures
''''''''''''''''''''''''''''''''''''''''''
Private Type tHeader
  sName As String * 32
  dwUnknown1 As Long
  dwTime1 As Long
  dwTime2 As Long
  dwTime3 As Long
  dwLastSync As Long
  ofsAppInfo As Long
  ofsCategories As Long
  dwType As Long
  dwCreator 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
Const RE_PRIVATE = &H10000000
'''''''''''''''''''''''''''''''''''''''''''
'''' Pilot Money structures
'''''''''''''''''''''''''''''''''''''''''''
'NOTE: remember: all of the numbers are Mac format!
Private Type MoneyAppInfo
    renamedCategories As Integer
    categoryLabels(15) As String * 16 'actually char[16][16]
    categoryUniqIDs As String * 16  'actually char[16]
    lastUniqID As Byte
    Reserved1 As Byte
    Reserved2 As Integer
        'The above stuff is all standard. The type and tran labels are
        ' for the popup lists in the Transaction Edit screen
    typeLabels(19) As String * 10   'actually char[20][10];
    tranLabels(19) As String * 20  'actually char[20][20];
End Type
Private Type MoneyPreferences
    displayPref As Byte          '// Display Prefs - Used for check# display etc
    repeatBound As Integer      '/ How far in advance we repeat transactions
    currentCategory As Integer '    // What category are we looking at
    topVisibleRecord As Integer '   // Which is the first record on the page
    currentRecord As Integer    ';      // Which record were we last looking at?
    currentRecordID As Long '    // The ID of that recod in case the hotsync
        'changes things and we need to look for it
    amountwidth As Byte
    prefflags As Byte ' // Width of the amount column and some flags
    mainstatuschoise As Byte '   // On the main display do we show Current, Min, Max balance?
    dollarSign As Byte '       // What character do we want to use for the amounts?
    version As Byte '          // What version of the database are we on?
End Type
Private Type DateTime
    sec As Integer
    min As Integer
    hour As Integer
    day As Integer
    month As Integer
    year As Integer
    dow As Integer
End Type
Private Type MoneyTransaction
    flags As Integer '          // Has it cleared? Do we have a receipt? 1=cleared, 2=noExport
    checknum As Integer '       // Check number or 0
    amount As Long
    total As Long     '/ The "dollar" value of the amount and the runn
            'ing total after this transaction clears
    amountc As Integer
    totalc As Integer ';   // The cents values as above
    date As DateTime '           // Transaction date
    repeat As Byte ';         // Type of repeat or 0 if it doesnt repeat
    flags2 As Byte ';         // More flags; 1=receipt
    type As Byte '           // Which of the "type" list items this belongs to
    Reserved1 As Byte '      // for expansion
    Reserved2 As Byte '      // For expansion
    Reserved3 As Byte '      // For expansion
    description As String * 19 '    // The actual description of the transaction
    note As String * 401 '        // '0' terminated notes field.
End Type
'screen versions
Const kCheckNum = 1
Const kAmount = 2
Const kDate = 3
Const kType = 4
Const kDesc = 5
Const kNote = 6
Const kCleared = 7
Const kReceipt = 8
Const kCategory = 9
Const kPrivate = 10
'########################################
'############ REGISTRY ##################
'########################################
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 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
Const sMainKey = "Software\Palm Computing\Pilot Desktop"
'Globals
Dim sFileName As String         'the file
Dim header As tHeader           'file header
Dim appinfo As MoneyAppInfo     'file header
Dim aRecEntry() As tRecEntry    'copy of the file index
Dim aRec() As MoneyTransaction  'holds the actual data; one-to-one with aRecEntry()
Dim nRecs As Integer
Dim nCurSel As Integer          'index into the list1 list box
Sub FillScreen(i As Integer)
    nCurSel = i
    txt(kCheckNum) = Format(SwapWord(aRec(nCurSel).checknum))
    txt(kAmount) = Format(SwapLong(aRec(nCurSel).amount) + SwapWord(aRec(nCurSel).amountc) / 100#, "$#0.00")
    txt(kDate) = Format(PilotToDate(aRec(nCurSel).date), "General Date")
    txt(kDesc) = aRec(nCurSel).description
    txt(kNote) = aRec(nCurSel).note
    txt(kType) = comboTypes.List(aRec(nCurSel).type)
    txt(kCategory) = comboCats.List((aRecEntry(nCurSel).attrib And &HF000000) \ &H1000000)
    chk(kCleared) = aRec(nCurSel).flags And 1
    chk(kReceipt) = aRec(nCurSel).flags2 And 1
    If ((aRecEntry(nCurSel).attrib And RE_PRIVATE) = RE_PRIVATE) Then
        chk(kPrivate) = 1
    Else
        chk(kPrivate) = 0
    End If
End Sub
Private Function PilotToDate(s As DateTime) As Date
    Dim dw2 As Long
    PilotToDate = DateSerial(SwapWord(s.year), SwapWord(s.month), SwapWord(s.day)) + _
        TimeSerial(SwapWord(s.hour), SwapWord(s.min), SwapWord(s.sec))
    'CDate(dw2 / 3600# / 24#) ' - CDate("Jan 1, 1970")
End Function
Sub OpenAndRead(sFile As String)
    List1.Clear
    comboCats.Clear
    comboTrans.Clear
    comboTypes.Clear
    nRecs = 0
    On Error GoTo or_err
    Dim dwFileLen As Long
    dwFileLen = FileLen(sFile)
    Open sFile For Binary Access Read As 1
    Get #1, , header
    nRecs = SwapWord(header.wNumRecs)
    ReDim aRecEntry(nRecs - 1)
    Dim i As Integer
    For i = 0 To nRecs - 1
        Get #1, , aRecEntry(i)
        aRecEntry(i).attrib = SwapLong(aRecEntry(i).attrib)
    Next
    Dim dw As Long
    dw = SwapLong(header.ofsAppInfo)
    Seek #1, dw + 1
    Get #1, , appinfo
    ReDim aRec(nRecs - 1)
    For i = 0 To nRecs - 1
        dw = SwapLong(aRecEntry(i).ofs)
        Seek #1, dw + 1
        Get #1, , aRec(i)
    Next
    Close #1
    'fill the list box
    For i = 0 To nRecs - 1
        If (aRecEntry(i).attrib And DELETED) = 0 Then
            List1.AddItem Format(PilotToDate(aRec(i).date), "Short Date") & "  " & Format(SwapLong(aRec(i).amount), "Currency")
        End If
    Next
    For i = 0 To 15
        If Asc(appinfo.categoryLabels(i)) = 0 Then Exit For
        comboCats.AddItem appinfo.categoryLabels(i)
    Next
    comboCats.ListIndex = 0

    For i = 0 To 19
        If Asc(appinfo.typeLabels(i)) = 0 Then Exit For
        comboTypes.AddItem appinfo.typeLabels(i)
    Next
    comboTypes.ListIndex = 0

    For i = 0 To 15
        If Asc(appinfo.tranLabels(i)) = 0 Then Exit For
        comboTrans.AddItem appinfo.tranLabels(i)
    Next
    comboTrans.ListIndex = 0

    List1.ListIndex = 0
    Exit Sub
or_err:
    Close #1
    On Error GoTo 0
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 btnDone_Click()
    End
End Sub
Private Sub btnGeneral_Click()
    If FrameGeneral.Visible Then
        FrameGeneral.Visible = False
        FrameDetails.Visible = True
    Else
        FrameGeneral.Left = FrameDetails.Left
        FrameGeneral.Visible = True
        FrameDetails.Visible = False
    End If
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
            OpenAndRead (sFileName)
    End Select
    Cancel = 0
End Sub
                                'the listbox.itemdata is a index into the aRecs() array
Private Sub Form_Load()
    sFileName = QueryValue(sMainKey & "\Preferences", "LastUserDir")
    If sFileName <> "" Then
        sFileName = sFileName & "\PMoney\PMoney.dat"
        OpenAndRead (sFileName)
    End If
End Sub
'usage:    QueryValue "TestKey\SubKey1", "StringValue"
Public Function QueryValue(sKeyName As String, sValueName As String) As Variant
    Dim lRetVal As Long         'result of the API functions
    Dim hKey As Long         'handle of opened key
    Dim vValue As Variant      'setting of queried value
    lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, _
        KEY_ALL_ACCESS, hKey)
    lRetVal = QueryValueEx(hKey, sValueName, vValue)
    QueryValue = vValue
    RegCloseKey (hKey)
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 List1_Click()
    FillScreen List1.ListIndex
End Sub