Refill Reminder

[WayneA]

A few years ago my asthma came back and made my life miserable. As a result I had to take several medication for allergies to keep me breathing. The thing was they all had strange doses-per-prescription so I had to refill my prescriptions at different times of the month. I couldn't just go on the 30th day every month and get a big gift basket of inhalers and pills. To help me remember when to refill these medications I wrote Refill Reminder.

I just was digging through my old projects and found this. This was one of my first serious projects and one of the few programs I've ever written that I polished enough that it looks half decent (to me). Unfortunately this was heavily dependent on Fletchie's ctl library which I don't think would easily work with EB due to the new directory/name of the compiler (IIRC it installed itself based on finding the IBPro directory). So I had some fun this morning adding in the functions from ctl manually.

Anyways, some usage info:
* When typing in "Daily Doses" if you type "PRN" after the number of daily doses it will flip the "as needed flag."
* You must hit Save before quitting, there is no auto-save.
* The Start Up button will add a shortcut to RefillReminder to your start-up menu, this will force you to check if you're low on a prescription on every start up (I thought I'd use this but found it annoying personally.)

I do not believe this will work on Win95/98 but I'd love to hear from anyone who can test that for me!

Code Select Expand

$Include "ishelllink.inc"
AutoDefine "Off"
SetId "IDGetMinMaxInfo",0x24
Const GWL_STYLE=-16
Const GWL_EXSTYLE=-20
Const GWL_WNDPROC=-4
Const WS_OVERLAPPED=0
Const SWP_NOMOVE=2
Const LVS_SHOWSELALWAYS=8
Const LVM_FIRST=0x1000
Const LVM_GETEDITCONTROL=LVM_FIRST+24
Const LVM_SETTEXTCOLOR=LVM_FIRST+36
Const SW_SHOWNORMAL=1
Const CSIDL_PERSONAL=5
Const INVALID_FILE_ATTRIBUTES=-1
Const FILE_ATTRIBUTE_DIRECTORY=0x10
Const SW_SHOWNORMAL=1
Const COINIT_APARTMENTTHREADED=2
Const CLSCTX_INPROC_SERVER=1
Const CP_ACP=0

Type NMLISTVIEW
Dim hwndFrom As UInt
Dim idFrom As Int
Dim code As Int
Dim iItem As Int
Dim iSubItem As Int
Dim uNewState As UInt
Dim uOldState As UInt
Dim uChanged As UInt
Dim ptActionx As Int
Dim ptActiony As Int
Dim lParam As Int
EndType

Type LVKEYDOWN
Dim hwndFrom As UInt
Dim idFrom As Int
Dim code As Int
Dim vkey As Word
Dim flags As  Int
EndType

Type LVITEM
Dim mask As Int
Dim iItem As Int
Dim iSubItem As Int
Dim state As Int
Dim stateMask As Int
Dim pszText As String
Dim cchTextMax As Int
Dim iImage As Int
Dim lParam As Int
Dim iIndent As Int
EndType

Type Point
Dim x As Int
Dim y As Int
EndType

Type MinMaxInfo
Dim ptReserved As Point
Dim ptMaxSize As Point
Dim ptMaxPosition As Point
Dim ptMinTrackSize As Point
Dim ptMaxTrackSize As Point
EndType

Declare Import,SetWindowPos(hwnd As Int,hWndInsertAfter As Int,x As Int,y As Int,cx As Int,cy As Int,wFlags As Int),Int
Declare Import,AdjustWindowRectEx(rec As Pointer,style As Int,mflag As Int,ExStyle As Int),Int
Declare Import,GetWindowLongA(hWnd As Int,nIndex As Int),Int
Declare Import,SetWindowLongA(hWnd As Int,nIndex As Int,dwNewLong As Int),Int
Declare Import,SetRect(pRect As Pointer,x1 As Int,y1 As Int,x2 As Int,y2 As Int),Int
Declare Import,GetSysColor(nIndex As Int),Int
Declare Import,CallWindowProcA(lpPrevWndFunc As UInt,hWnd As Int,Msg As Int,wParam As Int,lParam As UInt),Int
Declare Import,GetCommandLineA(),String
Declare Import,GetWindowTextA(hWnd As Int,lpString As String,nMaxCount As Int),Int
Declare Import,SHGetSpecialFolderLocation(hWnd As Int,nFolder As Int,ppidl As UInt)
Declare Import,SHGetSpecialFolderPathA(hWnd As Int,pszPath As String,csidl As Int,fCreate As Int),Int
Declare Import,GetFileAttributesA(lpFileName As String),Int
Declare Import,CoInitializeEx(pvReserved As UInt,dwCoInit As UInt),Int
Declare Import,MultiByteToWideChar(CodePage As Int,dwFlags As Int,lpMultiByteStr As String,cchMultiByte As Int,lpWideCharStr As String,cchWideChar As Int),Int
Declare Import,GetDlgItem(hDlg As Int,nIDDlgItem As Int),Int

Dim wndMain As Window
Dim orig As UInt
OpenWindow wndMain,0,0,0,0,@MinBox|@MaxBox|@Size,0,"Refill Reminder",&wndMainProc
SetClientSize(wndMain,490,225)
SetWindowColor wndMain,GetSysColor(15)
WaitUntil wndMain=0
End

Sub wndMainProc
Dim l,t,w,h,lvid,hWnd,ww,hh As Int
Dim doses As Double
Dim date,name,text As String
Dim p As UInt
Select @Message
Case @IDGetMinMaxInfo
SetTrackedWindowSize(1,490,225)
Case @IDCreate
CenterWindow wndMain
Control wndMain,@ListView,"",5,5,478,115,LVS_SHOWSELALWAYS|@LVSReport|@LVSSingleSel|@LVSEditLabels|@VScroll|@HScroll|@Group|@Border,1
Control wndMain,@SysButton,"&Add",5,135,70,20,@Group,2
Control wndMain,@SysButton,"&Load",85,135,70,20,@Group,3
Control wndMain,@SysButton,"&Clear Entrys",165,135,70,20,@Group,4
Control wndMain,@SysButton,"Start&Up",245,135,70,20,@Group,5
Control wndMain,@SysButton,"&Save",325,135,70,20,@Group,6
Control wndMain,@SysButton,"&Delete",405,135,70,20,@Group,7
Control wndMain,@Static,"Date Filled:",5,165,100,20,0,8
Control wndMain,@Edit,"",105,160,80,20,@Group,9
Control wndMain,@Static,"Total Doses:",295,165,100,20,0,10
Control wndMain,@Edit,"",395,160,80,20,@Group,11
Control wndMain,@Static,"Daily Doses:",5,200,100,20,0,12
Control wndMain,@Edit,"",105,200,80,20,@Group,13
Control wndMain,@Static,"Drug Name:",295,200,100,20,0,14
Control wndMain,@Edit,"",395,200,80,20,@Group,15
orig=SubClassWindow(wndMain,&DateEditHandler,9)
ControlCMD wndMain,1,@LVInsertColumn,0,"Drug Name"
ControlCMD wndMain,1,@LVInsertColumn,1,"Refill Date"
ControlCMD wndMain,1,@LVInsertColumn,2,"As Needed?"
ControlCMD wndMain,1,@LVSetColWidth,0,325
ControlCMD wndMain,1,@LVSetColWidth,1,75
ControlCMD wndMain,1,@LVSetColWidth,2,75
ControlCMD wndMain,9,@EdSetLimitText,10
For l=1 to 15
SetFont wndMain,"MS Sans Serif",8,400,0,l
Next l
lvid=GetControlHandle(wndMain,1)
loadList(wndMain,1)
Case @IDControl
Select @ControlID
Case 1
If @NotifyCode=@LVNEndLabelEdit Then
For t=0 to ControlCMD(wndMain,1,@LVGetCount)
If ControlCMD(wndMain,1,@LVGetSelected,t) Then
hWnd=SendMessage(wndMain,LVM_GETEDITCONTROL,0,0,1)
GetWindowTextA(hWnd,text,254)
ControlCMD wndMain,1,@LVSetText,t,0,text
BreakFor
EndIf
Next t
EndIf
Case 2
name=GetControlText(wndMain,15)
date=GetControlText(wndMain,9)
doses=Val(GetControlText(wndMain,11))/Val(GetControlText(wndMain,13))
If name<>"" And Len(date)=10 Then
l=ControlCMD(wndMain,1,@LVGetCount)
ControlCMD wndMain,1,@LVInsertItem,l,GetControlText(wndMain,15)
ControlCMD wndMain,1,@LVSetText,l,1,JulToDate(Julian(date)+doses)
If InStr(GetControlText(wndMain,13),"PRN") Then ControlCMD wndMain,1,@LVSetText,l,2,"Yes" Else ControlCMD wndMain,1,@LVSetText,l,2,"No"
EndIf
Case 3
ControlCMD wndMain,1,@LVDeleteAll
loadList(wndMain,1)
Case 4
For l=9 to 15 Step 2
SetControlText wndMain,l,""
Next l
Case 5
sGetDir(name,254,7)
If FileExists(name+"RefillRem.lnk")=0 Then
CreateShortcut(name+"RefillRem.lnk",NthField(GetCommandLineA()," ",0,True),"",GetStartPath,"",0,NthField(GetCommandLineA()," ",0,True),0)
Else
DeleteFile name+"RefillRem.lnk"
EndIf
Case 6
saveList(wndMain,1)
Case 7
For t=0 to ControlCMD(wndMain,1,@LVGetCount)
If ControlCMD(wndMain,1,@LVGetSelected,t) Then
ControlCMD wndMain,1,@LVDeleteItem,t
BreakFor
EndIf
Next t
EndSelect
Case @IDSize
GetClientSize wndMain,l,t,w,h
SetSize wndMain,5,5,w-12,h-110,1
SetSize wndMain,5,h-90,70,20,2
SetSize wndMain,85,h-90,70,20,3
SetSize wndMain,165,h-90,70,20,4
SetSize wndMain,w-245,h-90,70,20,5
SetSize wndMain,w-165,h-90,70,20,6
SetSize wndMain,w-85,h-90,70,20,7
SetSize wndMain,5,h-60,100,20,8
SetSize wndMain,105,h-65,80,20,9
SetSize wndMain,w-195,h-60,100,20,10
SetSize wndMain,w-95,h-65,80,20,11
SetSize wndMain,5,h-25,100,20,12
SetSize wndMain,105,h-25,80,20,13
SetSize wndMain,w-195,h-25,100,20,14
SetSize wndMain,w-95,h-25,80,20,15
GetSize wndMain,l,t,ww,hh,1
' ControlCMD wndMain,1,@LVSetColWidth,0,w-165
Case @IDCloseWindow
CloseWindow wndMain
EndSelect
Return
EndSub

Sub loadList(win As Window,cid As Int)
Dim docdir,lyne,date,name As String
Dim f As File
Dim l,prn As Int
prn=False
GetMyDocsDir(docdir,254)
If OpenFile(f,docdir+"Refills.txt","R")=0 Then
Do
Read f,lyne
If lyne<>"" Then
name=NthField(lyne,"\t",0)
date=NthField(lyne,"\t",1)
If Right$(date,5)="|PRN|" Then
date[Len(date)-5]=0
prn=True
EndIf
l=ControlCMD(win,cid,@LVGetCount)
'If Julian(date)>=(Julian(Date$)-7) Then SendMessage GetControlHandle(win,cid),LVM_SETTEXTCOLOR,0,RGB(255,0,0)
ControlCMD win,cid,@LVInsertItem,l,name
ControlCMD win,cid,@LVSetText,l,1,date
If prn Then ControlCMD win,cid,@LVSetText,l,2,"Yes" Else ControlCMD win,cid,@LVSetText,l,2,"No"
prn=False
EndIf
Until Eof(f)
CloseFile f
EndIf
Return
EndSub

Sub saveList(win As Window,cid As Int)
Dim docdir,lyne,date,name,prn As String
Dim f As File
Dim l As Int
name=""
date=""
prn=""
GetMyDocsDir(docdir,254)
If OpenFile(f,docdir+"Refills.txt","W")=0 Then
For l=0 to ControlCMD(win,cid,@LVGetCount)-1
lyne=""
ControlCMD win,cid,@LVGetText,l,0,name
ControlCMD win,cid,@LVGetText,l,1,date
ControlCMD win,cid,@LVGetText,l,2,prn
lyne=name+"\t"+date
If prn="Yes" Then lyne+="|PRN|"
If Len(lyne)>1 Then Write f,lyne
Next l
CloseFile f
EndIf
Return
EndSub

Sub NthField(Source As String,Delimiter As String,fieldNum As Int,Opt quotes=False As Int,Opt retEmpty=True As Int),Heap
Dim rString As Pointer
Dim pos,field,quote As Int
field=0
rString=AllocHeap(Len(Source)+1)
quote=False
SetType rString,String
If InStr(Source,Delimiter)=0 Then
If retEmpty Then #rString="" Else #rString=Source
Return #rString
EndIf
For pos=0 To Len(Source)-1
If quotes=True And Source[pos]=34 Then
quote=(quote=False)
Else
If Mid$(Source,pos+1,Len(Delimiter))=Delimiter And quote=False Then
If field=fieldNum Then Return #rString
field++
#rString=""
pos+=Len(Delimiter)-1
Else
#rString+=Source[pos]
EndIf
EndIf
Next pos
If field<>fieldNum Then #rString=""
Return #rString
EndSub

Sub DateEditHandler(hWnd As Int,uMsg As Int,wParam As Int,lParam As UInt),Int
Dim a[11] As IString
Select uMsg
Case @IDChar
a[0]=0,0,0,0,0,0,0,0,0,0
a=GetControlText(wndMain,9)
If wParam<>8 Then
If wParam<Asc("0") Or wParam>Asc("9") Then Return 0
If Len(a)>=1 Or Len(a)>=4 Then
CallWindowProcA(orig,hWnd,uMsg,wParam,lParam)
a=GetControlText(wndMain,9)
If Len(a)>1 And a[2]<>"/" Then a[2]="/"
If Len(a)>4 And a[5]<>"/" Then a[5]="/"
SetControlText wndMain,9,a
ControlCMD wndMain,9,@EdSetSelection,Len(a)+2,Len(a)+2
Return 0
EndIf
EndIf
EndSelect
Return CallWindowProcA(orig,hWnd,uMsg,wParam,lParam)
EndSub

Sub SetClientSize(win As Window,w As Int,h As Int,Opt fmenu=0 As Int),Int
WINRECT rec
Int style,exstyle,err
style=0:exstyle=0:err=0
style=GetWindowLongA(win.hwnd,GWL_STYLE)
If style
style=style & not(WS_OVERLAPPED)
exstyle=GetWindowLongA(win.hwnd,GWL_EXSTYLE)
If style=0 | exstyle=0 Then Return 0
EndIf
err=SetRect(rec,0,0,w,h)
If err
err=AdjustWindowRectEx(rec,style,fmenu,exstyle)
If err
err=SetWindowPos(win.hwnd,0,0,0,rec.right+Int(ABS(rec.left)),rec.bottom+Int(ABS(rec.top)),SWP_NOMOVE)
EndIf
EndIf
Return err
EndSub

Sub SetTrackedWindowSize(clientsize As Int,minw As Int,minh As Int,opt maxw=-1 As Int,opt maxh=-1 As Int)
Dim p As Pointer
Dim wx,wy,cx,cy As Int
Dim difx,dify As Int
p=##<Pointer>@Qual
SetType p,MinMaxInfo
If clientsize Then
GetSize(#<Window>@HitWindow,wx,wx,wx,wy)
GetClientSize(#<Window>@HitWindow,cx,cx,cx,cy)
difx=wx-cx
dify=wy-cy
Else
difx=0:dify=0
EndIf
#p.ptMinTrackSize.x=minw+difx
#p.ptMinTrackSize.y=minh+dify
If (maxw<>-1)&(maxh<>-1) Then
#p.ptMaxTrackSize.x=maxw+difx
#p.ptMaxTrackSize.y=maxh+dify
EndIf
EndSub

Sub SetMinTrackedWindowSize(w As Int,h As Int)
Dim p As Pointer
p=##<Pointer>@Qual
#<MinMaxInfo>p.ptMinTrackSize.x=w
#<MinMaxInfo>p.ptMinTrackSize.y=h
EndSub

Sub SubClassWindow(win As AnyType,subhandler As UInt,Opt cid=0 As Int),UInt
Dim hnd As Int
Dim orig As UInt
If TypeOf(win)=@TypeUser Then
If cid=0 Then
hnd=##<Window>win.hWnd
Else
hnd=GetDlgItem(##<window>win.hWnd,cid)
EndIf
Else
If IsRef(win) Then
hnd=##<int>win
Else
hnd=#<int>win
Endif
EndIf
If hnd Then
orig=GetWindowLongA(hnd,GWL_WNDPROC)
If orig Then
SetWindowLongA(hnd,GWL_WNDPROC,subhandler)
Return orig
EndIf
EndIf
Return 0
EndSub

Sub CreateShortCut(fn As String,towhat As String,desc As String,startdir As String,args As String,hotkey As Int,iconfile As String,iconid As Int),Int
'Dim CLSID_ShellLink,IID_IShellLinkA As Guid
'Dim _IID_IPersistFile As Guid
Dim ShellLink As ComRef
Dim pPersistFile As ComRef
Dim wid[520] As IString
CoInitializeEx(0,COINIT_APARTMENTTHREADED)
If (CoCreateInstance(_CLSID_ShellLink,NULL,CLSCTX_INPROC_SERVER,_IID_IShellLinkA,ShellLink)=0)
set_interface ShellLink,IShellLinkA
set_interface pPersistFile,IPersistFile
ShellLink->QueryInterface(_IID_IPersistFile,pPersistFile)
ShellLink->SetPath(towhat)
ShellLink->SetDescription(desc)
ShellLink->SetArguments(args)
ShellLink->SetHotkey(hotkey)
ShellLink->SetShowCmd(SW_SHOWNORMAL)
If iconfile<>""
ShellLink->SetIconLocation(iconfile,iconid)
EndIf
ShellLink->SetWorkingDirectory(startdir)
MultiByteToWideChar(CP_ACP,0,fn,-1,wid,520)
pPersistFile->Save(wid,1)
pPersistFile->Release()
ShellLink->Release()
CoUninitialize()
Return 1
Else
CoUninitialize()
Return 0
Endif
EndSub

Sub sGetDir(buffer As String,bufflen As Int,folder As Int),Int
Dim buff[260] As IString
If SHGetSpecialFolderPathA(0,buff,folder,0)
buff+="\\"
If Len(buff)<bufflen Then
buffer=buff
Return 1
EndIf
EndIf
buffer=""
Return 0
EndSub

Sub GetMyDocsDir(buffer As String,bufflen As Int),Int
Return sGetDir(buffer,bufflen,CSIDL_PERSONAL)
EndSub

Sub FileExists(fn As String),Int
Dim n As Int
n=GetFileAttributesA(fn)
If n<>INVALID_FILE_ATTRIBUTES Then
If (n&FILE_ATTRIBUTE_DIRECTORY)=0 Then
Return 1
Else
Return 2
EndIf
EndIf
Return 0
EndSub

Sub JulToDate(JN As Int),String
Dim julnumber,help,tempyear,tempmonth,day,month,year As Int
Dim ResultDate$,month$,day$,year$ As String
JulNumber = JN + 68569
help = 4 * JulNumber / 146097
JulNumber = JulNumber - (146097 * help + 3) / 4
TempYear = 4000 * (JulNumber + 1) / 1461001
JulNumber = JulNumber - (1461 * TempYear / 4) + 31
TempMonth = 80 * JulNumber / 2447
day = (JulNumber - (2447 * TempMonth / 80))
month = (TempMonth + 2 - (12 * (TempMonth / 11)))
year = (100 * (help - 49) + TempYear + (TempMonth / 11))
month$ = Using("0##",month) + "/"
day$ = Using("0##",day) + "/"
year$ = Using("0####",Int(Abs(year)))
If year < 0 Then year$ = "-" + year$
Return month$+day$+year$
EndSub

Sub Julian(InDate$ As String),Int
If Len(InDate$) < 10 Then Return 0
Val(Mid$(InDate$,7))
Val(Left$(InDate$,2))
Val(Mid$(InDate$,4,2))
Return JulianAsm(Val(Mid$(InDate$,7)),Val(Left$(InDate$,2)),Val(Mid$(InDate$,4,2)))
EndSub

Sub JulianAsm(year As Int,month As Int,day As Int),Int
Dim temp As Int
Dim jul As Int
_asm
lea eax,[ebp+12]
mov eax,[eax]
sub dword eax,14
mov dword [ebp-4],eax
mov dword ebx,12
cdq
idiv dword ebx
mov dword [ebp-4],eax
mov dword eax,[ebp+8]
add dword eax,4800
add dword eax,[ebp-4]
imul dword eax,1461
cdq
mov dword ebx,4
idiv dword ebx
mov dword [ebp-8],eax
mov dword eax,[ebp+16]
sub dword eax,32075
add dword eax,[ebp-8]
mov dword [ebp-8],eax
mov dword ebx,[ebp-4]
imul dword ebx,12
mov dword eax,[ebp+12]
sub dword eax,2
sub dword eax,ebx
imul dword eax,367
mov dword ebx,12
cdq
idiv dword ebx
add dword [ebp-8],eax
mov dword eax,[ebp+8]
add dword eax,4900
add dword eax,[ebp-4]
imul dword eax,3
mov dword ebx,100
cdq
idiv dword ebx
mov dword ebx,4
cdq
idiv dword ebx
sub dword [ebp-8],eax
_endasm
Return jul
End Sub

I may have an update version of this coming up which I'll post. Theres a few features missing from this version (I wrote the first version in a RAD environment than rewrote in IBPro, never finishing 100%).

I hope someone finds this useful.

[LarryMc]

I use Fletchie's ctl lib all the time with EB.
It's used in almost everything I have posted on the forums.

Larry

[WayneA]

Code Select Expand

/* Recent changes: Enabled tabbing through controls, subclassed listview to make items that need to refilled in less than 7 days red
also reverted to using ctl.inc now that I got it working (not sure what the issue was before)
*/

$Include "ctl.inc"
AutoDefine "Off"

Const GWL_STYLE=-16
Const GWL_EXSTYLE=-20
Const GWL_WNDPROC=-4
Const WS_OVERLAPPED=0
Const SWP_NOMOVE=2
Const LVS_SHOWSELALWAYS=8
Const LVM_FIRST=0x1000
Const LVM_GETEDITCONTROL=LVM_FIRST+24
Const LVM_SETTEXTCOLOR=LVM_FIRST+36
Const LVM_GETITEMRECT=LVM_FIRST+14
Const SW_SHOWNORMAL=1
Const CSIDL_PERSONAL=5
Const WM_PAINT=0xF
Const DT_CALCRECT=0x400
Const DT_LEFT=0
Const DT_NOCLIP=0x100
Const DT_SINGLELINE=0x20

Type NMLISTVIEW
Dim hwndFrom As UInt
Dim idFrom As Int
Dim code As Int
Dim iItem As Int
Dim iSubItem As Int
Dim uNewState As UInt
Dim uOldState As UInt
Dim uChanged As UInt
Dim ptActionx As Int
Dim ptActiony As Int
Dim lParam As Int
EndType

Type LVKEYDOWN
Dim hwndFrom As UInt
Dim idFrom As Int
Dim code As Int
Dim vkey As Word
Dim flags As  Int
EndType

Type LVITEM
Dim mask As Int
Dim iItem As Int
Dim iSubItem As Int
Dim state As Int
Dim stateMask As Int
Dim pszText As String
Dim cchTextMax As Int
Dim iImage As Int
Dim lParam As Int
Dim iIndent As Int
EndType

Declare Import,SetWindowPos(hwnd As Int,hWndInsertAfter As Int,x As Int,y As Int,cx As Int,cy As Int,wFlags As Int),Int
Declare Import,AdjustWindowRectEx(rec As Pointer,style As Int,mflag As Int,ExStyle As Int),Int
Declare Import,GetWindowLongA(hWnd As Int,nIndex As Int),Int
Declare Import,SetWindowLongA(hWnd As Int,nIndex As Int,dwNewLong As Int),Int
Declare Import,SetRect(pRect As Pointer,x1 As Int,y1 As Int,x2 As Int,y2 As Int),Int
Declare Import,GetSysColor(nIndex As Int),Int
Declare Import,CallWindowProcA(lpPrevWndFunc As UInt,hWnd As Int,Msg As Int,wParam As Int,lParam As UInt),Int
Declare Import,GetCommandLineA(),String
Declare Import,GetWindowTextA(hWnd As Int,lpString As String,nMaxCount As Int),Int
Declare Import,DrawTextA(hDC As UInt,lpString As String,nCount As Int,lpRect As WINRECT,uFormat As UInt),Int
Declare Import,GetDC(hWnd As UInt),UInt
Declare Import,ReleaseDC(hWnd As UInt,hDC As UInt),UInt
Declare Import,SetTextColor(hDC As UInt,crColor As UInt),UInt

Dim wndMain As Window
Dim orig,lvorig As UInt
OpenWindow wndMain,0,0,0,0,@MinBox|@MaxBox|@Size,0,"Refill Reminder",&wndMainProc
SetClientSize(wndMain,490,225)
EnableTabs wndMain,1
SetWindowColor wndMain,GetSysColor(15)
WaitUntil wndMain=0
End

Sub wndMainProc
Dim l,t,w,h,lvid,hWnd As Int
Dim doses As Double
Dim date,name,text As String
'Dim p As UInt
Select @Message
Case @IDGetMinMaxInfo
SetTrackedWindowSize(True,490,225)
Case @IDCreate
CenterWindow wndMain
Control wndMain,@ListView,"",5,5,478,115,LVS_SHOWSELALWAYS|@LVSReport|@LVSSingleSel|@LVSEditLabels|@VScroll|@HScroll|@Group|@TabStop|@Border,1
Control wndMain,@SysButton,"&Add",5,135,70,20,@Group|@TabStop,2
Control wndMain,@SysButton,"&Load",85,135,70,20,@Group|@TabStop,3
Control wndMain,@SysButton,"&Clear Entrys",165,135,70,20,@Group|@TabStop,4
Control wndMain,@SysButton,"Start&Up",245,135,70,20,@Group|@TabStop,5
Control wndMain,@SysButton,"&Save",325,135,70,20,@Group|@TabStop,6
Control wndMain,@SysButton,"&Delete",405,135,70,20,@Group|@TabStop,7
Control wndMain,@Static,"Date Filled:",5,165,100,20,0,8
Control wndMain,@Edit,"",105,160,80,20,@Group|@TabStop,9
Control wndMain,@Static,"Total Doses:",295,165,100,20,0,10
Control wndMain,@Edit,"",395,160,80,20,@Group|@TabStop,11
Control wndMain,@Static,"Daily Doses:",5,200,100,20,0,12
Control wndMain,@Edit,"",105,200,80,20,@Group|@TabStop,13
Control wndMain,@Static,"Drug Name:",295,200,100,20,0,14
Control wndMain,@Edit,"",395,200,80,20,@Group|@TabStop,15
orig=SubClassWindow(wndMain,&DateEditHandler,9)
lvorig=SubClassWindow(wndMain,&ListViewHandler,1)
ControlCMD wndMain,1,@LVInsertColumn,0,"Drug Name"
ControlCMD wndMain,1,@LVInsertColumn,1,"Refill Date"
ControlCMD wndMain,1,@LVInsertColumn,2,"As Needed?"
ControlCMD wndMain,1,@LVSetColWidth,0,325
ControlCMD wndMain,1,@LVSetColWidth,1,75
ControlCMD wndMain,1,@LVSetColWidth,2,75
ControlCMD wndMain,9,@EdSetLimitText,10
For l=1 to 15
SetFont wndMain,"MS Sans Serif",8,400,0,l
Next l
lvid=GetControlHandle(wndMain,1)
loadList(wndMain,1)
Case @IDControl
Select @ControlID
Case 1
If @NotifyCode=@LVNEndLabelEdit Then
For t=0 to ControlCMD(wndMain,1,@LVGetCount)
If ControlCMD(wndMain,1,@LVGetSelected,t) Then
hWnd=SendMessage(wndMain,LVM_GETEDITCONTROL,0,0,1)
GetWindowTextA(hWnd,text,254)
ControlCMD wndMain,1,@LVSetText,t,0,text
BreakFor
EndIf
Next t
EndIf
Case 2
name=GetControlText(wndMain,15)
date=GetControlText(wndMain,9)
doses=Val(GetControlText(wndMain,11))/Val(GetControlText(wndMain,13))
If name<>"" And Len(date)=10 Then
l=ControlCMD(wndMain,1,@LVGetCount)
ControlCMD wndMain,1,@LVInsertItem,l,GetControlText(wndMain,15)
ControlCMD wndMain,1,@LVSetText,l,1,JulToDate(Julian(date)+doses)
If InStr(GetControlText(wndMain,13),"PRN") Then ControlCMD wndMain,1,@LVSetText,l,2,"Yes" Else ControlCMD wndMain,1,@LVSetText,l,2,"No"
EndIf
Case 3
ControlCMD wndMain,1,@LVDeleteAll
loadList(wndMain,1)
Case 4
For l=9 to 15 Step 2
SetControlText wndMain,l,""
Next l
Case 5
sGetDir(name,254,7)
If FileExists(name+"RefillRem.lnk")=0 Then
CreateShortcut(name+"RefillRem.lnk",NthField(GetCommandLineA()," ",0,True),"",GetStartPath,"",0,NthField(GetCommandLineA()," ",0,True),0)
Else
DeleteFile name+"RefillRem.lnk"
EndIf
Case 6
saveList(wndMain,1)
Case 7
For t=0 to ControlCMD(wndMain,1,@LVGetCount)
If ControlCMD(wndMain,1,@LVGetSelected,t) Then
ControlCMD wndMain,1,@LVDeleteItem,t
BreakFor
EndIf
Next t
EndSelect
Case @IDSize
GetClientSize wndMain,l,t,w,h
SetSize wndMain,5,5,w-12,h-110,1
SetSize wndMain,5,h-90,70,20,2
SetSize wndMain,85,h-90,70,20,3
SetSize wndMain,165,h-90,70,20,4
SetSize wndMain,w-245,h-90,70,20,5
SetSize wndMain,w-165,h-90,70,20,6
SetSize wndMain,w-85,h-90,70,20,7
SetSize wndMain,5,h-60,100,20,8
SetSize wndMain,105,h-65,80,20,9
SetSize wndMain,w-195,h-60,100,20,10
SetSize wndMain,w-95,h-65,80,20,11
SetSize wndMain,5,h-25,100,20,12
SetSize wndMain,105,h-25,80,20,13
SetSize wndMain,w-195,h-25,100,20,14
SetSize wndMain,w-95,h-25,80,20,15
'GetSize wndMain,l,t,ww,hh,1
'This preserves the default column widths.. Comment out if you don't want it to revert back to default everytime the window is resized
ControlCMD wndMain,1,@LVSetColWidth,0,w-165
Case @IDCloseWindow
CloseWindow wndMain
EndSelect
Return
EndSub

Sub loadList(win As Window,cid As Int)
Dim docdir,lyne,date,name As String
Dim f As File
Dim l,prn As Int
prn=False
GetMyDocsDir(docdir,254)
If OpenFile(f,docdir+"Refills.txt","R")=0 Then
Do
Read f,lyne
If lyne<>"" Then
name=NthField(lyne,"\t",0)
date=NthField(lyne,"\t",1)
If Right$(date,5)="|PRN|" Then
date[Len(date)-5]=0
prn=True
EndIf
l=ControlCMD(win,cid,@LVGetCount)
'SendMessage GetControlHandle(win,cid),LVM_SETTEXTCOLOR,0,RGB(255,0,0)
'If Julian(date)>=(Julian(Date$)-7) Then
ControlCMD win,cid,@LVInsertItem,l,name
ControlCMD win,cid,@LVSetText,l,1,date
If prn Then ControlCMD win,cid,@LVSetText,l,2,"Yes" Else ControlCMD win,cid,@LVSetText,l,2,"No"
prn=False
EndIf
Until Eof(f)
CloseFile f
EndIf
Return
EndSub

Sub saveList(win As Window,cid As Int)
Dim docdir,lyne,date,name,prn As String
Dim f As File
Dim l As Int
name=""
date=""
prn=""
GetMyDocsDir(docdir,254)
If OpenFile(f,docdir+"Refills.txt","W")=0 Then
For l=0 to ControlCMD(win,cid,@LVGetCount)-1
lyne=""
ControlCMD win,cid,@LVGetText,l,0,name
ControlCMD win,cid,@LVGetText,l,1,date
ControlCMD win,cid,@LVGetText,l,2,prn
lyne=name+"\t"+date
If prn="Yes" Then lyne+="|PRN|"
If Len(lyne)>1 Then Write f,lyne
Next l
CloseFile f
EndIf
Return
EndSub

Sub NthField(Source As String,Delimiter As String,fieldNum As Int,Opt quotes=False As Int,Opt retEmpty=True As Int),Heap
Dim rString As Pointer
Dim pos,field,quote As Int
field=0
rString=AllocHeap(Len(Source)+1)
quote=False
SetType rString,String
If InStr(Source,Delimiter)=0 Then
If retEmpty Then #rString="" Else #rString=Source
Return #rString
EndIf
For pos=0 To Len(Source)-1
If quotes=True And Source[pos]=34 Then
quote=(quote=False)
Else
If Mid$(Source,pos+1,Len(Delimiter))=Delimiter And quote=False Then
If field=fieldNum Then Return #rString
field++
#rString=""
pos+=Len(Delimiter)-1
Else
#rString+=Source[pos]
EndIf
EndIf
Next pos
If field<>fieldNum Then #rString=""
Return #rString
EndSub

Sub ListViewHandler(hWnd As Int,uMsg As Int,wParam As Int,lParam As UInt),Int
Dim i,today,refillday As Int
Dim itemRect As WINRECT
Dim buf="" As String
today=Julian(Date$())
Select uMsg
Case WM_PAINT
'First let the control paint itself....
CallWindowProcA(lvorig,hWnd,uMsg,wParam,lParam)
uint hDC=GetDC(hWnd)
'Next we need to determine if any items need to be red flagged...
'It would be better to find out the range of items that are visible first, rather than checking every item
'But this is simpler to do and we don't expect to have very large lists in this program anyways..
For i=ControlCMD(wndMain,1,@LVGetCount)-1 to 0 Step -1
'If the item is selected we don't want to paint because it ends up looking bad..
If !ControlCMD(wndMain,1,@LVGetSelected,i) Then
ControlCMD(wndMain,1,@LVGetText,i,1,buf)
'rtrim has not proven to be needed, but just in case
refillday=Julian(RTrim$(buf))
'DebugPrint buf+":"+date$+":"+str$(refillday-today)
'Check if the refill day is nearing... (within a week)
If refillday-today<7 Then
'If it is then we get the items placement and size...
itemRect.left=0
SendMessage(hWnd,LVM_GETITEMRECT,i,&itemRect)
If itemRect.Top>10 Then
'So we dont paint over the header control we check if its currently visible
ControlCMD(wndMain,1,@LVGetText,i,0,buf)
SetTextColor(hDC,0x000000FF)
'Make it red(you can specify colors in hex like so: 0x00BBGGRR, its just reverse of RGB with an empty byte in front.)
DrawTextA(hDC," "+buf,-1,itemRect,0)
'Draw using the default font.. Its easier this way and it ends up being bigger & bolder then the others
EndIf
EndIf
EndIf
Next i
'Return the decive context to windows and return 0 so that the message wont be re-processed by windows
ReleaseDC(hWnd,hDC)
Return 0
EndSelect
Return CallWindowProcA(lvorig,hWnd,uMsg,wParam,lParam)
EndSub


Sub DateEditHandler(hWnd As Int,uMsg As Int,wParam As Int,lParam As UInt),Int
Dim a[11] As IString
Select uMsg
Case @IDChar
a[0]=0,0,0,0,0,0,0,0,0,0
a=GetControlText(wndMain,9)
If wParam<>8 Then
If wParam<Asc("0") Or wParam>Asc("9") Then Return 0
If Len(a)>=1 Or Len(a)>=4 Then
CallWindowProcA(orig,hWnd,uMsg,wParam,lParam)
a=GetControlText(wndMain,9)
If Len(a)>1 And a[2]<>"/" Then a[2]="/"
If Len(a)>4 And a[5]<>"/" Then a[5]="/"
SetControlText wndMain,9,a
ControlCMD wndMain,9,@EdSetSelection,Len(a)+2,Len(a)+2
Return 0
EndIf
EndIf
EndSelect
Return CallWindowProcA(orig,hWnd,uMsg,wParam,lParam)
EndSub

Sub SetClientSize(win As Window,w As Int,h As Int,Opt fmenu=0 As Int),Int
WINRECT rec
Int style,exstyle,err
style=0:exstyle=0:err=0
style=GetWindowLongA(win.hwnd,GWL_STYLE)
If style
style=style & not(WS_OVERLAPPED)
exstyle=GetWindowLongA(win.hwnd,GWL_EXSTYLE)
If style=0 | exstyle=0 Then Return 0
EndIf
err=SetRect(rec,0,0,w,h)
If err
err=AdjustWindowRectEx(rec,style,fmenu,exstyle)
If err
err=SetWindowPos(win.hwnd,0,0,0,rec.right+Int(ABS(rec.left)),rec.bottom+Int(ABS(rec.top)),SWP_NOMOVE)
EndIf
EndIf
Return err
EndSub

Sub JulToDate(JN As Int),String
Dim julnumber,help,tempyear,tempmonth,day,month,year As Int
Dim month$,day$,year$ As String
JulNumber = JN + 68569
help = 4 * JulNumber / 146097
JulNumber = JulNumber - (146097 * help + 3) / 4
TempYear = 4000 * (JulNumber + 1) / 1461001
JulNumber = JulNumber - (1461 * TempYear / 4) + 31
TempMonth = 80 * JulNumber / 2447
day = (JulNumber - (2447 * TempMonth / 80))
month = (TempMonth + 2 - (12 * (TempMonth / 11)))
year = (100 * (help - 49) + TempYear + (TempMonth / 11))
month$ = Using("0##",month) + "/"
day$ = Using("0##",day) + "/"
year$ = Using("0####",Int(Abs(year)))
If year < 0 Then year$ = "-" + year$
Return month$+day$+year$
EndSub

Sub Julian(InDate$ As String),Int
Return JulianAsm(Val(Right$(InDate$,4)),Val(Left$(InDate$,2)),Val(Mid$(InDate$,4,2)))
EndSub

Sub JulianAsm(year As Int,month As Int,day As Int),Int
Dim temp As Int
Dim jul As Int
'DebugPrint Using("##&##&####",day,"/",month,"/",year)
_asm
lea eax,[ebp+12]
mov eax,[eax]
sub dword eax,14
mov dword [ebp-4],eax
mov dword ebx,12
cdq
idiv dword ebx
mov dword [ebp-4],eax
mov dword eax,[ebp+8]
add dword eax,4800
add dword eax,[ebp-4]
imul dword eax,1461
cdq
mov dword ebx,4
idiv dword ebx
mov dword [ebp-8],eax
mov dword eax,[ebp+16]
sub dword eax,32075
add dword eax,[ebp-8]
mov dword [ebp-8],eax
mov dword ebx,[ebp-4]
imul dword ebx,12
mov dword eax,[ebp+12]
sub dword eax,2
sub dword eax,ebx
imul dword eax,367
mov dword ebx,12
cdq
idiv dword ebx
add dword [ebp-8],eax
mov dword eax,[ebp+8]
add dword eax,4900
add dword eax,[ebp-4]
imul dword eax,3
mov dword ebx,100
cdq
idiv dword ebx
mov dword ebx,4
cdq
idiv dword ebx
sub dword [ebp-8],eax
_endasm
Return jul
EndSub