SOFTWARE FOR IMAGE SEGMENTATION AND ANALYSIS
IN PATHOLOGY (ISAP).
Microsoft(R) VISUAL BASIC SOURCE CODE.
Copyright © 1994 G. William Moore, Geoffrey W. Moore,
Jules J. Berman, Lawrence A. Brown.
http://www.medparse.com/isapsour.htm
U. S. Government Work, presented at the 1994 meeting
of the American Society of Clinical Pathology, Washington, DC.
Moore GW, Berman JJ, Moore GW, Brown LA.
Software for Image Segmentation and Analysis in Pathology (ISAP)
Am J Clin Pathol 102:538-539, 1994.
1. ISAP Microsoft(R) VISUAL BASIC SOURCE CODE.
'PROGRAMMER SWITCH
Dim GWMSW%
'RHEOSTAT SWITCH
Dim RHEOSTATSW%
'IMAGE SWITCH
Dim IMAGEBLOCKSW%, IMAGEMEASURESW%
'FORM PARAMETERS
Dim CRLF$
'GRAND DATABASE NAME
Dim GRANDDBS$, LGRANDDBS&, DATALINE$, DATAGRAND$, DBSSW%
Dim DBOXTEXT$, HEBX$, TGANAME$, RAWNAME$
'THRESHOLD VALUES AND SWITCHES
Dim THRESHOLDVALUE!, THRESHOLDLONGI&
Dim SELFTHRESHOLDSW%, SELFERRORSW%
Dim WORKAREA&, TRACESUM&, TRACEPCT&
'PARTICLE ARRAYS
Dim PUSHX&(500), PUSHY&(500), PTRX&(10), PTRY&(10)
Dim EDGEX&(500), EDGEY&(500), HIST&(0 To 300), VFNL&(800)
'CENTER OF GRAVITY
Dim CTX&, CTY&, MINX&, MINY&, MAXX&, MAXY&
Dim HISTOPCT&, XBYTES%, YBYTES%
Dim AJN!, AJS!, AJQ!, HJN!, HJS!, HJQ!, MAXJR!, MAXII&
'ARRAY VERTEX
Dim AVTX&(10)
'PERIMETER
Dim PERMX&(500), PERMY&(500), AREA&
Dim CHKRBD&(19, 19), QUAD&(-2 To 2, -2 To 2)
'Dim MAXCRN&,
Dim MAXREACH&, ZIPPER&, NREACH&
'MOUSE SWITCH
Dim PERIMSHOWSW%, MOUSEBEGINSW%, MOUSEENDSW%
Dim NEDGE&, IPUSH&, NPUSH&, NPERM&, MPERM&, PRMTR&
'IMAGE BOX DIMENSIONS
Dim IMAGEBOX&(199, 199), XLENG&, YLENG&, IMAGELIN$(199)
'BOUNDARY ARRAY
Dim NBND&, OBND&, BNDX&(500), BNDY&(500)
'PAINTNOW GLOBAL IS USED
'TO TURN ON AND OFF THE PAINTING TOOL USED ON MOUSE MOVE AFTER THE MOUSE
Dim PAINTNOW As Integer
'FIRST TIME SWITCHES, 1=FIRST TIME, 0=REPEAT
Dim FIRSTTIMETHRESHSW%, FIRSTTIMEBLOCKSW%
'INPUT STRING FOR HELP WORD SEARCH
Dim LINPUT$
'DATABASE BOX
Dim DBSNAM$, DBSBOX$, DBSHDR$, DBSLINE$
'PERIMETER ERROR MESSAGE
Dim PERIMETERERROR$
'INSTRING LOCATIONS FOR WORDS IN HELP WORD SEARCH
Dim WORDLOC&(100)
'WORD COUNTER FOR HELP WORD SEARCH
Dim WORDCOUNT&
'WORD NUMBER FOR CURRENT WORD IN HELP WORD SEARCH
Dim WORDNOW&, RAND$(0 To 56), RAWLEN As Long, RAWA, RAWB
'EDGE ERROR SWITCH
Dim EDGEERRORSW%
'SELECTED PALETTE COLOR
Dim COLORSEL$
'PALETTESW%=0 IF THE COLOR PALETTE HAS NOT YET BEEN DISPLAYED
Dim PALETTESW%
'SIZE OF EDGE DETECTION WINDOW (NUMBER OF PIXELS)
Dim WINDOWVALUE&
'SWITCH FOR AVERAGE (1=ARITH,2=GEOM,3=MAX,4=MIN)
Dim AVERAGEMENUSW%, TGABMPSW%, RAWBMPSW%, IMAGEGRAB%
'FRACTAL PERIMETER ARRAYS
Dim FRACX&(-4 To 300): Dim FRACY!(-4 To 300)
'HISTOGRAM COUNTER
Dim HISTG&(0 To 300)
'X&Y COORDINATES FOR MOUSE-DOWN EVENT
Dim DOWNX&: Dim DOWNY&
'X&Y COORDINATES FOR MOUSE-UP EVENT
Dim UPX&: Dim UPY&
'PARTICLE X&Y CENTERS OF GRAVITY
Dim XCR&, YCR&, XC&, YC&
'PARTICLE NUCLEAR AREA
Dim NUCAREA&
'MAXIMUM DIAMETER OF PARTICLE
Dim MAXDIAM!
Dim FILEGRABPOINTER%
'FILE NAME FOR GIVEN, .BMP, AND .TGA IMAGE FILES
Dim FLNM$, FLNMBMP$, FLNMTGA$, FLNMSEL$, FLNMDBS$, FLNMTMP$, FLNMSAV$
'LENGTH OF FILE FOR .BMP AND .TGA FILES
Dim LOFBMP&, LOFTGA&
'FRACTAL DIMENSION
Dim FRDIM!
'AVERAGE, SUM, STDEV GRAYVALUES & OPTICAL DENSITY
Dim GRAYAVG&, DENSAVG!, DENSUM&, ODENSAVG!, ODENSUM!, ODENSTD!
'ECCENTRICITY
Dim ECCENT!, ROOTDIAM!, AREADIAM!, EMINDIAM!
'X&Y COORDINATES, PARTICLE CENTER-OF-GRAVITY
Dim XCENTER!: Dim YCENTER!
'NUCLEAR CONTOUR
Dim NUCCONT!, CONTOUR!
'PERIMETER 1-PIXEL, 2-PIXEL, AND 4-PIXEL EDGES
Dim PRMONE!: Dim PRMTWO!: Dim PRMFOR!
Sub ANALYSISHELP_Click ()
GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPANLY.TXT": HELPBOX.Visible = -1
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
HELPBOX.Text = "NO ANALYSIS HELP TEXT IS AVAILABLE."
Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
HELPBOX.Text = SHOWPAGE$
End Sub
Sub ARITHMEANMENU_Click ()
AVERAGESW% = 1
End Sub
Sub BIGSCREENPIC_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)
'IF THE USER PRESSES THE MOUSE ON THE BIGSCREEN PICTURE,
'THEN THE SELECTION BOX WILL BEGIN TO FORM.
If (IMAGEGRAB% = 0) Then
MSGX$ = "MAKE A SELECTION" + CRLF$ + "FROM THE IMAGE SUBMENU"
MsgBox MSGX$, 48, "USER GUIDE"
Exit Sub
End If
If ((IMAGEGRAB% = 1) Or (IMAGEGRAB% = 2)) Then
BIGSCREENPIC.Visible = -1
BIGSCREENPIC.AutoRedraw = -1
MOUSEBEGINSW% = 1: PAINTNOW = -1
NBND& = 0: OBND& = 0: HELPBOX.Visible = 0
HISTOGRAMPIC.Visible = 0: VALUEBOX.Visible = 0
DOWNX& = X: DOWNY& = Y: XX& = DOWNX&: YY& = DOWNY&
UPX& = 0: UPY& = 0: NCOOR& = 0: XCR& = 0: YCR& = 0
NUCAREA& = 0: DENSUM& = 0
End If
End Sub
Sub BIGSCREENPIC_MouseMove (Button As Integer, Shift As Integer, X As Single, Y As Single)
'FOR BLOCK-SELECT, CONTINUE MOVING THE MOUSE-PELLETS
If (MOUSEBEGINSW% > 0) Then
If (IMAGEGRAB% = 1) Then
BIGSCREENPIC.AutoRedraw = -1: OLDX& = X: OLDY& = Y
BIGSCREENPIC.Line (OLDX&, OLDY&)-(OLDX& + 1, OLDY& + 1), RGB(255, 0, 0), BF
NBND& = NBND& + 1
If (NBND& > 499) Then
MOUSEBEGINSW% = 0
MSGX$ = "EDGE TOO LONG"
MsgBox MSGX$, 48, "USER GUIDE:"
Exit Sub
End If
BNDX&(NBND&) = OLDX&: BNDY&(NBND&) = OLDY&
Exit Sub
End If
'FOR MEASURE-DISTANCE, IF PAINTING IS ON,
'THEN CREATE A SIMULATED LINE BETWEEN POINT OF ORIGIN AND
'THE POINT BEING MOVED
If ((IMAGEGRAB% = 2) And (PAINTNOW)) Then
BIGSCREENPIC.Line (DOWNX&, DOWNY&)-(X, Y), RGB(255, 0, 0)
If (DOWNX& < X) Then MIX = DOWNX& Else MIX = X
If (DOWNY& < Y) Then MIY = DOWNY& Else MIY = Y
TX = Abs((DOWNX& - X) / 2) + MIX
TY = Abs((DOWNY& - Y) / 2) + MIY
BIGSCREENPIC.Line (TX - 2, TY - 2)-(TX + 2, TY + 2), RGB(0, 255, 0)
End If
End If
End Sub
Sub BIGSCREENPIC_MouseUp (Button As Integer, Shift As Integer, X As Single, Y As Single)
'IF SELECT-BLOCK:
MOUSEBEGINSW% = 0
If (IMAGEGRAB% = 1) Then
'OBTAIN USER WORKSPACE
MOUSEPOINTER = 11: BIGSCREENPIC.AutoRedraw = 0: SELFERRORSW% = 0
PAINTNOW = 0: DATALINE$ = "": DBSLINE$ = ""
Call WORKSPACE
If (SELFERRORSW% = 1) Then
MOUSEPOINTER = 1: DBSLINE$ = ""
MSGX$ = "WORKSPACE ERROR"
MsgBox MSGX$, 48, "USER GUIDE:"
Exit Sub
End If
'IF WORKSPACE OK, THEN OBTAIN THRESHOLD
If (SELFERRORSW% = 0) Then
'SELF THRESHOLD
If (HISTOPCT& > 0) Then
Call WORKSPACEPCT
SELFTHRESHOLDSW% = 0
'Exit Sub
End If
If (SELFTHRESHOLDSW% = 1) Then
SELFERRORSW% = 1
Call SELFTHRESHOLD
If (SELFERRORSW% = 1) Then
MOUSEPOINTER = 1: DBSLINE$ = ""
MSGX$ = "THRESHOLD ERROR"
MsgBox MSGX$, 48, "USER GUIDE:"
Exit Sub
End If
End If
'FIXED THRESHOLD
If (SELFTHRESHOLDSW% = 0) Then
SELFERRORSW% = 1
If (THRESHOLDLONGI& > 0) Then SELFERRORSW% = 0
If (THRESHOLDLONGI& < 1) Then
MOUSEPOINTER = 1: DBSLINE$ = ""
MSGX$ = "THRESHOLD NOT SPECIFIED."
MsgBox MSG$, 48, "USER GUIDE:"
Exit Sub
End If
End If
'IF THRESHOLD AVAILABLE, THEN TRACE EDGE
If (SELFERRORSW% = 0) Then
SELFERRORSW% = 1
Call TRACEEDGE
If (SELFERRORSW% = 1) Then
MOUSEPOINTER = 1: DBSLINE$ = ""
MSGX$ = "EDGE TRACE ERROR"
MsgBox MSGX$, 48, "USER GUIDE:"
Exit Sub
End If
If (SELFERRORSW% = 0) Then
MOUSEPOINTER = 1
MSGX$ = "THRESHOLD=" + Str$(THRESHOLDLONGI&) + " X=" + Str$(CTX&) + " Y=" + Str$(CTY&)
MSGX$ = MSGX$ + CRLF$ + "AREA=" + Str$(AREA&) + " PERIM=" + Str$(PRMTR&)
MSGX$ = MSGX$ + " ZIPPER=" + Str$(ZIPPER&)
MSGX$ = MSGX$ + CRLF$ + "MAX REACH=" + Str$(MAXREACH&)
ANSW% = MsgBox(MSGX$, 1)
If (ANSW% = 1) Then
HISTOGRAMCTL.Enabled = -1
VALUESCTL.Enabled = -1
Call DBSAPPEND
End If
If (GWMSW% = 1) Then Call SHOWMEDIA
Exit Sub
End If
End If
End If
End If
' IF IMAGEGRAB%=0 THEN THE NOTHING HAS BEEN CHECKED OFF
HELPBOX.Visible = 0: 'DONEBOX.Visible = 0
If (IMAGEGRAB% < 1) Then
'DONEBOX.Visible = False
MSGX$ = "Select desired item" + CRLF$ + "from IMAGE submenu."
MsgBox MSGX$, 48, "USER GUIDE:"
HELPBOX.Visible = 0 ': DONEBOX.Visible = 0
Exit Sub
End If
' IF IMAGEGRAB%=2 THEN THE DISTANCE FUNCTION HAS BEEN
' CHECKED OFF
PAINTNOW = False 'TURN OFF PAINTING
BIGSCREENPIC.Cls
UPX& = X: UPY& = Y
If (IMAGEGRAB% = 2) Then
BIGSCREENPIC.AutoRedraw = 0
BIGSCREENPIC.Line (DOWNX&, DOWNY&)-(UPX&, UPY&), RGB(255, 0, 0)
BIGSCREENPIC.AutoRedraw = -1
XDS! = Abs(DOWNX& - UPX&): YDS! = Abs(DOWNY& - UPY&)
EDS! = Sqr((XDS! * XDS!) + (YDS! * YDS!))
MSGX$ = "X-LENGTH:" + Left$(Str$(XDS!), 6)
MSGX$ = MSGX$ + CRLF$ + "Y-LENGTH:" + Left$(Str$(YDS!), 6)
MSGX$ = MSGX$ + CRLF$ + "TOTAL LENGTH:" + Left$(Str$(EDS!), 6) + CRLF$ + "PIXELS"
MsgBox MSGX$
Exit Sub
End If
End Sub
Sub BLOCKSELECTCTL_Click ()
'THIS ROUTINE SETS UP THE PICTURE FOR BLOCKING A CELL
IMAGEGRAB% = 1
If (FIRSTTIMEBLOCKSW% = 1) Then
GRABPAGE$ = String$(3000, " "): FILETEXT$ = "ISAPBLKS.TXT"
Close #1: Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1): Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then GRABPAGE$ = "# FILE `ISAPBLKS.TXT' IS MISSING. #"
INGRAB& = InStr(4, GRABPAGE$, "#"): ' SHOWS HELP TEXT
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
FIRSTTIMEBLOCKSW% = 0: ANSQ% = MsgBox(SHOWPAGE$, 0)
End If
End Sub
Sub CANCELCOMDIR_Click ()
FLNMSEL$ = "": FLNMTMP$ = ""
DIRECTORYFILE.Visible = 0: COLORLIST.Visible = 0
OKCOMDIR.Visible = 0: CANCELCOMDIR.Visible = 0
End Sub
Sub CLOSECTL_Click ()
HELPBOX.Visible = 0: HISTOGRAMPIC.Visible = 0
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
VALUEBOX.Visible = 0
End Sub
Sub CLOSEFILECTL_Click ()
BIGSCREENPIC.Visible = -1: BIGSCREENPIC.Cls
LOFBMP& = 1: HELPBOX.Visible = -1: VALUEBOX.Visible = -1
IMAGEMENU.Enabled = 0: EDGECTL.Enabled = 0: ANALYSISCTL.Enabled = 0
End Sub
Sub CLOSEHELPCOM_Click ()
HELPBOX.Text = "": HELPBOX.Visible = 0
CLOSEHELPCOM.Visible = 0
End Sub
Sub CLOSEITEMCTL_Click ()
VALUESCTL.Enabled = -1: CLOSEITEMCTL.Enabled = 0
HISTOGRAMPIC.Enabled = -1: HISTOGRAMPIC.Visible = 0
VALUEBOX.Visible = 0: HISTOGRAMCTL.Enabled = -1
End Sub
Sub CLOSESEARCH_Click ()
'CLOSE HELP WORD SEARCH
'SCANBOX.Visible = 0
NEXTSEARCH.Visible = 0
CLOSESEARCH.Visible = 0
End Sub
Sub COLORLIST_Click ()
'COLORLIST CLICK
GRABPAGE$ = String$(3000, " "): CRLF$ = Chr$(13) + Chr$(10)
'THE USER-SELECTED COLOR (FROM HANDLER PALETTEMENU)
'IS GIVEN IN COLORLIST.TXT
FILEHEADER$ = "ISAPHEAD.TXT": COLORSEL$ = COLORLIST.Text
LINESNARE$ = CRLF$ + COLORSEL$ + "^"
'LOCATE THE SELECTED COLOR FROM FILE `ISAPHEAD.TXT'
HELPBOX.Visible = 0: VALUEBOX.Visible = 0
Open FILEHEADER$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
'IF `ISAPHEAD.TXT' IS UNAVAILABLE, THEN ERROR BOX.
If (LOFTEXT& < 10) Then
MSGG$ = "File `ISAPHEAD.TXT' is not available." + CRLF$ + "Please copy from original floppy disk."
MsgBox MSGG$, 48, "USER GUIDE:": Exit Sub
End If
INGRAB& = InStr(GRABPAGE$, LINESNARE$)
ENDGRAB& = InStr(INGRAB& + 1, GRABPAGE$, CRLF$)
LINEGRAB$ = Mid$(GRABPAGE$, INGRAB& + 2, ENDGRAB& - INGRAB& - 2)
PALIN% = InStr(LINEGRAB$, "^"): LLINEGRAB% = Len(LINEGRAB$)
FLNMTMP$ = Mid$(LINEGRAB$, PALIN% + 1, LLINEGRAB% - PALIN%)
FLNMSEL = ""
'AT THIS POINT, THE USER MAY EITHER `OK' (=OKCOMDIR)
'OR `CANCEL' (=CANCELCOMDIR).
End Sub
Sub COLORLIST_DblClick ()
FLNMSEL$ = FLNMTMP$
DIRECTORYFILE.Visible = 0: OKCOMDIR.Visible = 0
CANCELCOMDIR.Visible = 0: COLORLIST.Visible = 0
'COLORLIST CLICK
GRABPAGE$ = String$(3000, " "): CRLF$ = Chr$(13) + Chr$(10)
'THE USER-SELECTED COLOR (FROM HANDLER PALETTEMENU)
'IS GIVEN IN COLORLIST.TXT
FILEHEADER$ = "ISAPHEAD.TXT": COLORSEL$ = COLORLIST.Text
LINESNARE$ = CRLF$ + COLORSEL$ + "^"
'LOCATE THE SELECTED COLOR FROM FILE `ISAPHEAD.TXT'
HELPBOX.Visible = 0
': DONEBOX.Visible = 0
Close #1: Open FILEHEADER$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
'IF `ISAPHEAD.TXT' IS UNAVAILABLE, THEN ERROR BOX.
If (LOFTEXT& < 10) Then
MSGG$ = "File `ISAPHEAD.TXT' is not available." + CRLF$ + "Please copy from original floppy disk."
MsgBox MSGG$, 48, "USER GUIDE:": Exit Sub
End If
INGRAB& = InStr(GRABPAGE$, LINESNARE$)
ENDGRAB& = InStr(INGRAB& + 1, GRABPAGE$, CRLF$)
LINEGRAB$ = Mid$(GRABPAGE$, INGRAB& + 2, ENDGRAB& - INGRAB& - 2)
PALIN% = InStr(LINEGRAB$, "^"): LLINEGRAB% = Len(LINEGRAB$)
FLNMTMP$ = Mid$(LINEGRAB$, PALIN% + 1, LLINEGRAB% - PALIN%)
FLNMSEL = ""
'USER SELECTS THE OK COMMAND FOR DIRECTORYFILE
'TRANSFER TEMPORARY FILE NAME TO SELECTED FILE NAME
FLNMSEL$ = FLNMTMP$: CRLF$ = Chr$(13) + Chr$(10)
'HIDE THE DIRECTORYFILE, OK & CANCEL COMMANDS.
DIRECTORYFILE.Visible = 0
OKCOMDIR.Visible = 0: CANCELCOMDIR.Visible = 0
COLORLIST.Visible = 0
'IF NO FILE HAS BEEN SELECTED, THEN ERROR MESSAGE
If (FLNMSEL$ = "") Then
MsgBox "NO FILE NAME" + CRLF$ + "HAS BEEN SELECTED", 48, "USER GUIDE"
Exit Sub
End If
'IF A FILE HAS BEEN SELECTED, THEN CALL FILEGRABBER
If (FLNMSEL$ <> "") Then
Call FILEGRABBER
Exit Sub
End If
'IF NO FILE HAS BEEN SELECTED, THEN ERROR MESSAGE
'If (FLNMSEL$ = "") Then
' MsgBox "NO FILE NAME" + CRLF$ + "HAS BEEN SELECTED", 48, "USER GUIDE"
' Exit Sub
'End If
''AT THIS POINT, THE USER MAY EITHER `OK' (=OKCOMDIR)
'OR `CANCEL' (=CANCELCOMDIR).
'If (FLNMSEL$ <> "") Then
' Call FILEGRABBER
'End If
End Sub
Sub CONVERTTGABMP ()
'THIS ROUTINE CONVERTS A TGA FILE TO A BMP FILE
Static F As String * 30000: Static INZ As String * 1081
INZ = "": F = ""
'ASSIGN THE NORMAL (GRAY) COLOR MAP TO THE NEW .BMP FILE
Close #1: Open "grey.hdr" For Binary Access Read As #1
'SUBSTITUTE GREY AS THE HEADER FILE
Close #2: Open TGANAME$ + "tga" For Binary Access Read As #2
Close #3: Open TGANAME$ + "bmp" For Binary As #3
INZ = Input$(1081, #1): Close #1
Put #3, , INZ: Seek #2, 13
B1$ = Input$(1, #2): B2$ = Input$(1, #2)
B3$ = Input$(1, #2): B4$ = Input$(1, #2)
'CONVERT THE X,Y COORDINATES OF THE FILES
Seek #3, 19: Put #3, , B1$: Put #3, , B2$
Seek #3, 23: Put #3, , B3$: Put #3, , B4$
Seek #3, 1078
While (Not (EOF(2)))
F = Input$(30000, 2)
Put #3, , F
Wend
Close #2: Close #3
MSGX$ = "FILE HAS BEEN CONVERTED TO:" + CRLF$ + UCase$(TGANAME$) + "BMP"
MsgBox (MSGX$)
End Sub
Sub DATABASEHELP_Click ()
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPDTBS.TXT": HELPBOX.Visible = -1
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
HELPBOX.Text = "NO DATABASE HELP TEXT IS AVAILABLE."
Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
HELPBOX.Text = SHOWPAGE$
CLOSEHELPCOM.Visible = -1
End Sub
Sub DBSAPPEND ()
'APPEND DATABASE
HISTOGRAMCTL.Enabled = -1: VALUESCTL.Enabled = -1
DBSCOMP$ = DATALINE$ + DBSLINE$
INBK% = InStr(DBSCOMP$, " ")
Do While (INBK% > 0)
INOL% = INBK%: INLN% = Len(DBSCOMP$)
DBSX$ = Mid$(DBSCOMP$, 1, INOL% - 1) + Mid$(DBSCOMP$, INOL% + 1, INLN% - INOL%)
DBSCOMP$ = DBSX$: INBK% = InStr(DBSCOMP$, " ")
Loop
DBSDISPLAY$ = DBSCOMP$ + ",": INCM% = 0: INSW% = 1
DBOXTEXT$ = "": INCR& = 0
Do While (INSW% > 0)
INOL% = INCM%: INCR& = INCR& + 1
INCM% = InStr(INCM% + 1, DBSDISPLAY$, ",")
If (INCM% < 1) Then INSW% = 0
If (INCR& > 24) Then INSW% = 0
If (INSW% > 0) Then
DPC$ = Left$(Mid$(DBSDISPLAY$, INOL% + 1, INCM% - INOL% - 1) + " ", 14)
RAND$(INCR&) = RAND$(INCR&) + DPC$
DBOXTEXT$ = DBOXTEXT$ + RAND$(INCR&) + CRLF$
End If
Loop
DATAGRAND$ = DATAGRAND$ + DBSCOMP$ + CRLF$
ANALYSISCTL.Enabled = -1: DATABASECTL.Enabled = -1
VIEWACTIVEDBS.Enabled = -1
End Sub
Sub DBSCALC ()
'DATABASE PARAMETERS CALCULATION
'FIND THE EDGE FOR A PARTICLE WITH KNOWN INSIDE
'CALCULATE PARTICLE AREA, GRAY SUM, DENSITY SUM,
'CENTER-OF-GRAVITY, MAX DIAMETER, MIN DIAMETER, ETC.
DENSUM& = 0: ODENSUM! = 0: ODENSQUD! = 0:
RLTEN! = 1# / Log(10#)
XCR& = 0: YCR& = 0: NUCAREA& = 0: MAXDIAM! = 0
SVIJ& = -9999: SVI& = -9999
For II& = 0 To 256
HISTG&(II&) = 0
Next II&
'THE SHARED ARRAY INCOORD%() IS THE `INSIDENESS POINTER'.
'INCOORD%()=0 FOR OUTSIDE THE PARTICLE,
'INCOORD%()=1 FOR INSIDE THE PARTICLE,
'INCOORD%()=2 FOR THE EDGE OF THE PARTICLE.
For II& = 1 To YLENG&
IML$ = IMAGELIN$(II&)
For JJ& = 1 To XLENG&
ASJ& = Asc(Mid$(IML$, JJ&, 1)): IMG& = IMAGEBOX&(II&, JJ&)
If (IMG& > 3) Then
'CALCULATE CENTER OF GRAVITY SUMS
XCR& = XCR& + JJK&: YCR& = YCR& + IIK&
'CALCULATE OPTICAL DENSITY SUM
VLC% = ASJ&: VARG! = 0#
If (VLC% < 255) Then VARG! = 255 / (255 - VLC%)
If (VARG! > 0) Then
ODENSVAL! = RLTEN! * Log(VARG!): ODENSUM! = ODENSUM! + ODENSVAL!
ODENSQUD! = ODENSQUD! + (ODENSVAL! * ODENSVAL!)
End If
'CALCULATE PARTICLE AREA AND GRAY SUM
DENSUM& = DENSUM& + VLC%: NUCAREA& = NUCAREA& + 1
'CALCULATE HISTOGRAM BARS
HST% = VLC%: HISTG&(HST%) = HISTG&(HST%) + 1
End If
Next JJ&
Next II&
GRAYAVG& = DENSUM& / NUCAREA&
'IF THE NUCLEAR AREA IS TOO SMALL, THEN ERROR BOX
'CONSIDER A HIGHER THRESHOLD VALUE.
If (NUCAREA& < 15) Then
LIGHT$ = "The particle is too light." + CRLF$ + "Consider a higher" + CRLF$ + "THRESHOLD selection."
MsgBox LIGHT$, 48, "USER GUIDE"
EDGEERRORSW% = 1: Exit Sub
End If
'FIND THE CENTER-OF-GRAVITY OF THE PARTICLE
If (NUCAREA& > 3) Then
XC& = (XCR& / NUCAREA&) \ 1: YC& = (YCR& / NUCAREA&) \ 1
End If
'FIND MAX DIAMETER OF THE PARTICLE
MAXEUC! = 0#: NPERMM& = NPERM& - 1: NPERMMM& = NPERMM& - 1
For II& = 2 To NPERMMM&
YZI& = PERMY&(II&): XZI& = PERMX&(II&): IIP& = II& + 1
For JJ& = IIP& To NPERMM&
YZJ& = PERMY&(JJ&): XZJ& = PERMX&(JJ&)
DSY! = YZI& - YZJ&: SQY! = DSY! * DSY!
DSX! = XZI& - XZJ&: SQX! = DSX! * DSX!
EUC! = SQX! + SQY!: If (EUC! > MAXEUC!) Then MAXEUC! = EUC!
Next JJ&
Next II&
MAXDIAM! = Sqr(MAXEUC!): XC& = CTX&: YC& = CTY&
NFRAC& = 0: FRACX&(0) = 0: FRACY!(0) = 0
BIGSCREENPIC.AutoRedraw = -1
For IFR& = 1 To NPERMM&
If (IFR& = NPERMM&) Then IFP& = 1
If (IFR& < NPERMM&) Then IFP& = IFR& + 1
YRR& = PERMY&(IFR&): XRR& = PERMX&(IFR&)
YRP& = PERMY&(IFP&): XRP& = PERMX&(IFP&)
XR& = XRR& - XC& + MINX& - 1: YR& = YRR& - YC& + MINY& - 1
XP& = XRP& - XC& + MINX& - 1: YP& = YRP& - YC& + MINY& - 1
XRB& = XR& + XC&: XPB& = XP& + XC&
YRB& = YR& + YC&: YPB& = YP& + YC&
XD& = XP& - XR&
BIGSCREENPIC.Line (XRB&, YRB&)-(XPB&, YPB&), RGB(255, 255, 255)
If (XP& < XR&) Then
For HFR& = XP& To XR&
JFR& = XR& + XP& - HFR&
KFR! = (((JFR& - XP&) * (YR& - YP&)) / (XR& - XP&)) + YP&
OFR& = FRACX&(NFRAC&)
If ((OFR& <> JFR&) And (NFRAC& < 300)) Then
NFRAC& = NFRAC& + 1
FRACX&(NFRAC&) = JFR&: FRACY!(NFRAC&) = KFR!
End If
Next HFR&
End If
If (XP& > XR&) Then
For JFR& = XR& To XP&
KFR! = (((JFR& - XR&) * (YP& - YR&)) / (XP& - XR&)) + YR&
OFR& = FRACX&(NFRAC&)
If ((OFR& <> JFR&) And (NFRAC& < 300)) Then
NFRAC& = NFRAC& + 1
FRACX&(NFRAC&) = JFR&: FRACY!(NFRAC&) = KFR!
End If
Next JFR&
End If
If (XP& = XR&) Then
OFR& = FRACX&(NFRAC&)
If ((OFR& <> XR&) And (NFRAC& < 300)) Then
NFRAC& = NFRAC& + 1
FRACX&(NFRAC&) = XR&: FRACY!(NFRAC&) = YR&
End If
End If
Next IFR&
BIGSCREENPIC.AutoRedraw = 0
PRMONE! = 0: PRMTWO! = 0: PRMFOR! = 0: NUCCONT! = 0
'CALCULATE PERIMETER
FRACX&(0) = FRACX&(NFRAC&): FRACY!(0) = FRACY!(NFRAC&)
For IFRAC& = 1 To NFRAC&
IFRAM& = IFRAC& - 1: IFRAL& = IFRAC& - 2: IFRAF& = IFRAC& - 4
XDM! = FRACX&(IFRAC&) - FRACX&(IFRAM&): XAM! = Abs(XDM!)
XDL! = FRACX&(IFRAC&) - FRACX&(IFRAL&): XAL! = Abs(XDL!)
XDF! = FRACX&(IFRAC&) - FRACX&(IFRAF&): XAF! = Abs(XDF!)
YDM! = FRACY!(IFRAC&) - FRACY!(IFRAM&)
YDL! = FRACY!(IFRAC&) - FRACY!(IFRAL&)
YDF! = FRACY!(IFRAC&) - FRACY!(IFRAF&)
PRMONE! = PRMONE! + Sqr((XDM! * XDM!) + (YDM! * YDM!))
If ((XAL! > 1.5) And (((IFRAC& \ 2) * 2) = IFRAC&)) Then
PRMTWO! = PRMTWO! + Sqr((XDL! * XDL!) + (YDL! * YDL!))
If ((XAF! > 3.5) And (((IFRAC& \ 4) * 4) = IFRAC&)) Then
PRMFOR! = PRMFOR! + Sqr((XDF! * XDF!) + (YDF! * YDF!))
End If
End If
Next IFRAC&
If (NUCAREA& > 1) Then
NUCCONT! = PRMONE! / (Sqr(NUCAREA&))
CONTOUR! = ((1000 * NUCCONT!) \ 1) / 1000
End If
FRDIM! = 0: BINLOG! = 1# / Log(2#)
If (PRMTWO! > 0) Then
FRQUO! = PRMONE! / PRMTWO!
If (FRQUO! > 1) Then FRX! = BINLOG! * Log(FRQUO!)
FRDIM! = 1 + (((FRX! * 1000#) \ 1) / 1000#)
End If
SN! = 0: SL! = 0: SQ! = 0: TN! = 0: TL! = 0: TQ! = 0
For II& = 1 To 256
HIG& = HISTG&(II&)
If (HIG& > 0) Then
SN! = SN! + HIG&: SL! = SL! + (HIG& * II&)
SQ! = SQ! + (HIG& * II& * II&)
End If
Next II&
BIGSCREENPIC.AutoRedraw = 0
If (SN! > 1) Then VTOT! = (SQ! - ((SL! * SL!) / SN!))
VSAV! = 500 + VTOT!: VISAV& = 0
For II& = 1 To 256
HIG& = HISTG&(II&)
If (HIG& > 0) Then
TN! = TN! + HIG&: TL! = TL! + (HIG& * II&)
TQ! = TQ! + (HIG& * II& * II&)
VN! = SN! - TN!: VL! = SL! - TL!: VQ! = SQ! - TQ!
If ((TN! > 0) And (VN! > 0)) Then
VBOT! = (TQ! - ((TL! * TL!) / TN!))
VTOP! = (VQ! - ((VL! * VL!) / VN!))
VRAT! = (VBOT! + VTOP!) / VTOT!
If (VRAT! < VSAV!) Then
VSAV! = VRAT!: VISAV& = II&
End If
End If
End If
Next II&
VRAT! = ((1000 * VSAV!) \ 1) / 1000
If (NUCAREA& > 3) Then
DENSAVG! = (((1000 * DENSUM&) / NUCAREA&) \ 1) / 1000
ODENSAVG! = (((1000 * ODENSUM!) / NUCAREA&) \ 1) / 1000
ODVAR! = (ODENSQUD! - ((ODENSUM! * ODENSUM!) / NUCAREA&)) / (NUCAREA& - 1)
ODSTD! = Sqr(ODVAR!)
ODENSTD! = ((1000 * ODSTD!) \ 1) / 1000
End If
AREADIAM! = ((1000 * Sqr(1.273 * NUCAREA&)) \ 1) / 1000
DIV = ISAV& * 4.5
If (NUCAREA& > 3) Then
ROOTDIAM! = 0: EMINDIAM! = 0: ECCENT! = 0
XCENTER! = ((1000 * CTX&) \ 1) / 1000
YCENTER! = ((1000 * CTY&) \ 1) / 1000
If (MAXDIAM! > 0) Then ROOTDIAM! = ((1000 * MAXDIAM!) \ 1) / 1000
If (MAXDIAM! > 0) Then EMINDIAM! = (((1273.24 * NUCAREA&) / MAXDIAM!) \ 1) / 1000
If (EMINDIAM! > 0) Then ECCENT! = (((MAXDIAM! * 1000) / EMINDIAM!) \ 1) / 1000
End If
'DATABASE LINE
DBSLINE$ = Str$(NUCAREA&) + "," + Str$(DENSUM&) + "," + Str$(ODENSUM!) + ","
DBSLINE$ = DBSLINE$ + Str$(ODENSAVG!) + "," + Str$(ODENSTD!) + ","
DBSLINE$ = DBSLINE$ + Str$(THRESHOLDLONGI&) + "," + Str$(AREADIAM!) + ","
DBSLINE$ = DBSLINE$ + Str$(ROOTDIAM!) + "," + Str$(EMINDIAM!) + ","
DBSLINE$ = DBSLINE$ + Str$(ECCENT!) + "," + Str$(XCENTER!) + ","
DBSLINE$ = DBSLINE$ + Str$(YCENTER!) + "," + Str$(FRDIM!) + ","
DBSLINE$ = DBSLINE$ + Str$(CONTOUR!) + "," + Str$(PRMONE!) + ","
DBSLINE$ = DBSLINE$ + Str$(WORKAREA&) + "," + Str$(GRAYAVG&) + ","
DBSLINE$ = DBSLINE$ + Str$(MAXREACH&) + "," + Str$(ZIPPER&)
'ENABLE MENU ITEMS
IMAGEMENU.Enabled = -1
EDGECTL.Enabled = -1: ANALYSISCTL.Enabled = -1
End Sub
Sub DIRECTORYFILE_Click ()
FLNMTMP$ = DIRECTORYFILE.FileName
End Sub
Sub DIRECTORYFILE_DblClick ()
FLNMSEL$ = DIRECTORYFILE.FileName
DIRECTORYFILE.Visible = 0
OKCOMDIR.Visible = 0
CANCELCOMDIR.Visible = 0
Call FILEGRABBER
End Sub
Sub DONECLOSECOM_Click ()
DONECLOSECOM.Visible = 0: DBOX.Visible = 0
End Sub
Sub EDGEHELP_Click ()
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPEDGE.TXT": HELPBOX.Visible = -1
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
HELPBOX.Text = "NO EDGE HELP TEXT IS AVAILABLE."
Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
HELPBOX.Text = SHOWPAGE$
CLOSEHELPCOM.Visible = -1
End Sub
Sub ERRORNOCTL_Click ()
GWMSW% = 0: MSGX$ = "ERROR DISPLAY IS OFF"
MsgBox MSGX$
End Sub
Sub ERRORYESCTL_Click ()
GWMSW% = 1: MSGX$ = "ERROR DISPLAY IS ON"
MsgBox MSGX$
End Sub
Sub FILEGRABBER ()
'THIS HANDLER GRABS THE FILE WHICH HAS BEEN
'SPECIFIED IN THE DIRECTORYFILE.
'THERE ARE DIFFERENT PATHWAYS INTO THIS HANDLER,
'WHICH ARE SPECIFIED BY VALUES OF FILEGRABPOINTER%
'IF FILEGRABPOINTER%=1 THEN OPEN IMAGE
'IF FILEGRABPOINTER%=2 THEN CONVERT .TGA TO .BMP
'IF FILEGRABPOINTER%=3 THEN CONVERT .RAW TO .BMP
'IF FILEGRABPOINTER%=4 THEN CHANGE COLOR PALETTE
'OPEN IMAGE IN 8-BIT BLACK-WHITE .BMP FORMAT
If (FILEGRABPOINTER% = 1) Then
HISTOGRAMPIC.Visible = 0: BIGSCREENPIC.Visible = -1
BMPIN% = InStr(FLNMSAV$, "."): Close #2
Open FLNMSAV$ For Binary Access Read As #2
LOFBMP& = LOF(2): Close #2
If (LOFBMP& < 10) Then
MsgBox "INVALID FILE NAME", 48, "USER GUIDE"
Exit Sub
End If
'REFRESHCTL.ENABLED = -1
'OBTAIN ABSCISSA AND ORDINATE FOR IMAGE
Close #3: Open FLNMSAV$ For Binary Access Read As #3
Seek #3, 19: XBYTES% = Asc(Input$(1, #3)) + (256 * (Asc(Input$(1, #3))))
Seek #3, 23: YBYTES% = Asc(Input$(1, #3)) + (256 * (Asc(Input$(1, #3))))
LOFBMP& = LOF(3): Close #3
VALUEBOX.Visible = 0
PALETTEMENU.Enabled = -1: DATABASECTL.Enabled = -1
'VIEWDBS.Enabled = -1:
VIEWACTIVEDBS.Enabled = 0
IMAGEMENU.Enabled = -1: EDGECTL.Enabled = -1
ANALYSISCTL.Enabled = 0: REFRESHCTL.Enabled = -1
BIGSCREENPIC.AutoRedraw = 0
BIGSCREENPIC.Picture = LoadPicture(FLNMBMP$)
End If
'THIS ROUTINE RECEIVES THE .TGA FILE NAME
'WHICH HAS BEEN SELECTED FOR CONVERSION TO .BMP
'THE SELECTED FILE IS GLOBAL FLNMSEL$
If (FILEGRABPOINTER% = 2) Then
HISTOGRAMPIC.Visible = 0: BIGSCREENPIC.Visible = -1
NMARKR& = 0: FLNMTGA$ = FLNMSEL$: LOFTGA& = 0
'MSGX$ = "FLNMTGA" + CRLF$ + FLNMTGA$ + CRLF$ + TGANAME$
'MsgBox MSGX$
'Exit Sub
BMPIN% = InStr(FLNMSEL$, ".")
'.: LFLNMSEL% = Len(FLNMSEL$)
TGANAME$ = Mid$(FLNMSEL$, 1, BMPIN%)
Close #2: Open FLNMTGA$ For Binary Access Read As #2
LOFTGA& = LOF(2): Close #2
If (LOFTGA& < 100) Then
MsgBox "INVALID FILE NAME", 48, "USER GUIDE"
Close #2: Exit Sub
End If
'TGANAME$ = Mid$(FLNMSEL$, 1, BMPIN%)
'TGANAME$ = FLNMTGA$
NEWFILESW% = 0: OPENFILESW% = 0
TGABMPSW% = 1: RAWBMPSW% = 0
Call CONVERTTGABMP
End If
'THIS ROUTINE RECEIVES THE .RAW FILE NAME
'WHICH HAS BEEN SELECTED FOR CONVERSION TO .BMP
'THE SELECTED FILE IS GLOBAL FLNMSEL$
If (FILEGRABPOINTER% = 3) Then
MSGX$ = "THIS OPTION" + CRLF$ + "NOT AVAILABLE"
MsgBox MSGX$
End If
'FLIP HEADERS TO CHANGE PALETTE
If (FILEGRABPOINTER% = 4) Then
Close #5: Open FLNMBMP$ For Binary Access Write As #5
LOFBMP& = LOF(5)
If (LOFBMP& < 100) Then
MSGX$ = "INVALID IMAGE FILE NAME "
MsgBox MSGX$ + FLNMBMP$, 48, "USER GUIDE"
Close #4: Close #5: Exit Sub
End If
Close #4: Open FLNMSAV$ For Binary Access Read As #4
LOFSAV& = LOF(4)
If (LOFSAV& < 100) Then
MsgBox "INVALID HEADER FILE NAME " + FLNMSAV$, 48, "USER GUIDE"
Close #4: Close #5: Exit Sub
End If
Seek #4, 57: Seek #5, 57
For YYY = 1 To 4
For ZZZ = 1 To 2
TTT$ = Input$(128, #4)
Put #5, , TTT$
Next ZZZ
Next YYY
Close #4: Close #5
BIGSCREENPIC.Picture = LoadPicture(FLNMBMP$)
'NTH = 1
End If
'VIEW ACTIVE DATABASE
'If (FILEGRABPOINTER% = 14) Then
' Call DBSVDATA: Exit Sub
'End If
End Sub
Sub FILEHELP_Click ()
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPFILE.TXT": HELPBOX.Visible = -1
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
HELPBOX.Text = "NO FILE HELP TEXT IS AVAILABLE."
Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
HELPBOX.Text = SHOWPAGE$
CLOSEHELPCOM.Visible = -1
End Sub
Sub Form_Load ()
Reset
'SET FORM PARAMETERS
CRLF$ = Chr$(13) + Chr$(10)
'SET SWITCHES
HISTOPCT& = 0: IMAGEGRAB% = 0: GWMSW% = 0: RHEOSTATSW% = 0
PERIMSHOWSW% = 1: SELFERRORSW% = 0
GRANDDBS$ = "ISAP.DBS": DBSNAM$ = "ISAP.DBS": DBSSW% = 0
DATALINE$ = "": DBSLINE$ = "": DATAGRAND$ = ""
MOUSEBEGINSW% = 0: MOUSEENDSW% = 0
SELFTHRESHOLDSW% = 1: THRESHOLDVALUE! = 0#: THRESHOLDLONGI& = 0
MAXRCH& = 0: MAXCRN& = 607: ZIPPER& = 999999
NBND& = 0: OBND& = 0: PAINTNOW = 1
ISAP.Icon = LoadPicture("isap.ico")
'FIRST TIME SWITCH, 1=FIRST TIME, 0=REPEAT
DBSNAMESW% = 0
FIRSTTIMETHRESHSW% = 1: FIRSTTIMEBLOCKSW% = 1
'PALETTESW%=FALSE IF THE COLORLIST HAS NOT YET BEEN FILLED.
PALETTESW% = 0: DATABASE$ = "": DATABASESW% = 0
THRESHOLDVALUE! = 0#: THRESHOLDLONGI& = 0
WINDOWVALUE& = 3: FILEGRABPOINTER% = 0
AVERAGESW% = 1: DBSCOUNT& = 0
NEWFILESW% = 0: OPENFILESW% = 0
TGABMPSW% = 0: RAWBMPSW% = 0
TEXTEDITSW% = 0: IMAGEDITSW% = 0
IMAGEGRAB% = 0: GEOFFSROU% = 0
METHODSW% = 0
'DONEBOX.Visible = 0:
HISTOGRAMPIC.Visible = 0
NMARKR& = 0: NCOOR& = 0
BIGSCREENPIC.Visible = 0: BIGSCREENPIC.AutoRedraw = -1
IMAGEMENU.Enabled = 0: VIEWACTIVEDBS.Enabled = 0
EDGECTL.Enabled = 0: ANALYSISCTL.Enabled = 0
DATABASECTL.Enabled = -1: VIEWDBS.Enabled = -1
GRABPAGE$ = String$(3000, " "): FILETEXT$ = "ISAPPRIM.TXT"
Close #1: Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then GRABPAGE$ = "# FILE `ISAPPRIM.TXT' IS MISSING. #"
INGRAB& = InStr(4, GRABPAGE$, "#"): ' SHOWS HELP TEXT
PERIMETERERROR$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
GRABPAGE$ = String$(3000, " "): FILETEXT$ = "DATABASE.HDR"
Close #1: Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then GRABPAGE$ = "# FILE `DATABASE.HDR' IS MISSING. #"
INGRAB& = InStr(GRABPAGE$, CRLF$) - 1
DBSBOX$ = Mid$(GRABPAGE$, 1, INGRAB&) + CRLF$
DBSHDR$ = DBSBOX$
GRABPAGE$ = String$(3000, " "): FILETEXT$ = "ISAPCOPR.TXT"
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
HELPBOX.Text = -1
HELPBOX.Text = "FILE `ISAPCOPR.TXT' IS NOT AVAILABLE." + CRLF$ + "ISAP(c) WILL TERMINATE WITHOUT THIS FILE."
End
Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
ISAPCOPRTXT$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
'DATABASE PARAMETER NAMES
RAND$(1) = "FILENAME ": RAND$(2) = "XCENTER "
RAND$(3) = "YCENTER ": RAND$(4) = "RIM PCT "
RAND$(5) = "AREA ": RAND$(6) = "AREA "
RAND$(7) = "GRAYSUM ": RAND$(8) = "DENSESUM "
RAND$(9) = "DENSEAVG ": RAND$(10) = "DENSESTDV "
RAND$(11) = "THRESHOLD ": RAND$(12) = "AVGDIAM "
RAND$(13) = "MAXDIAM ": RAND$(14) = "MINDIAM "
RAND$(15) = "ECCENT ": RAND$(16) = "XCENTER "
RAND$(17) = "YCENTER ": RAND$(18) = "FRACTAL "
RAND$(19) = "CONTOUR ": RAND$(20) = "PERIMETER "
RAND$(21) = "WORKSPACE ": RAND$(22) = "GRAY AVG "
RAND$(23) = "MAX REACH ": RAND$(24) = "ZIPPER "
'VERTICES FOR EDGE SEARCH
QUAD&(1, 0) = 0: QUAD&(1, 1) = 1: QUAD&(0, 1) = 2: QUAD&(-1, 1) = 3
QUAD&(-1, 0) = 4: QUAD&(-1, -1) = 5: QUAD&(0, -1) = 6: QUAD&(1, -1) = 7
For II& = 1 To 15
IM& = II& - 8: IQ& = IM& * IM&
IA& = Abs(IM&): IT& = 0: If (IA& <> 0) Then IT& = IM& / IA&
For JJ& = 1 To 15
JM& = JJ& - 8: JQ& = JM& * JM&
JA& = Abs(JM&): JT& = 0: If (JA& <> 0) Then JT& = JM& / JA&
CHKRBD&(JJ&, II&) = (8 * (IQ& + JQ&)) + QUAD&(JT&, IT&)
Next JJ&
Next II&
ReDim VSRT&(0 To 800, 0 To 10)
For II& = 1 To 800
VSRT&(II&, 0) = 0
Next II&
For II& = 1 To 15
For JJ& = 1 To 15
CHB& = CHKRBD&(II&, JJ&): KK& = 1 + VSRT&(CHB&, 0)
VSRT&(CHB&, 0) = KK&: VSRT&(CHB&, KK&) = (100 * II&) + JJ&
Next JJ&
Next II&
NREACH& = 0
For II& = 1 To 800
KK& = VSRT&(II&, 0)
If (KK& > 0) Then
For JJ& = 1 To KK&
NREACH& = NREACH& + 1
VFNL&(NREACH&) = VSRT&(II&, JJ&)
Next JJ&
End If
Next II&
ReDim VSRT&(1, 1)
'IF ERROR HANDLER ON:
' DO NOT SHOW SOFTWARE LICENSE AGREEMENT
' TURN ON DATABASE SWITCH
If (GWMSW% = 1) Then
LICENSECOM.Visible = 0
LICENSEBOX.Visible = 0
DBSSW% = 1: Close #23
Open GRANDDBS$ For Binary Access Write As #23
End If
'IF ERROR HANDLER OFF, THEN SHOW SOFTWARE LICENSE AGREEMENT
If (GWMSW% = 0) Then
LICENSEBOX.FontSize = 6
LICENSEBOX.Text = ISAPCOPRTXT$
LICENSECOM.Visible = -1
LICENSEBOX.Visible = -1
ISAP.Show
LICENSECOM.SetFocus
End If
End Sub
Sub GENERALHELP_Click ()
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPGNRL.TXT": HELPBOX.Visible = -1
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
MSGX$ = "NO GENERAL HELP TEXT IS AVAILABLE (FILE ISAPGNRL)."
MsgBox MSGX$: Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
HELPBOX.Text = SHOWPAGE$
CLOSEHELPCOM.Visible = -1
End Sub
Sub GEOMMEANMENU_Click ()
AVERAGESW% = 2
End Sub
Sub HISTOGRAMCTL_Click ()
VALUESCTL.Enabled = -1: CLOSEITEMCTL.Enabled = -1
HISTOGRAMCTL.Enabled = 0: VALUEBOX.Visible = 0:
HELPBOX.Visible = 0
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
HISTOGRAMPIC.Visible = -1: HISTOGRAMPIC.Cls
CRLF$ = Chr$(13) + Chr$(10)
For II& = 1 To 255
HIG& = HISTG&(II&): HI& = HIG& * 25
LI& = II& * 20: LP& = LI& + 20
HISTOGRAMPIC.Line (LI&, 3440)-(LP&, 3440 - HI&), RGB(255, 0, 0), BF
Next II&
If (NUCAREA& > 3) Then
ILIN& = (VISAV& * 20): IAVG& = (DENSAVG! * 20)
HISTOGRAMPIC.Line (IAVG&, 3440)-(IAVG& + 20, 0), RGB(0, 0, 255), BF
End If
HISTOGRAMPIC.PSet (50, 3500), (HISTOGRAMPIC.Point(50, 3500))
HISTOGRAMPIC.Print "0 50 100 150 200 250"
HISTOGRAMPIC.Print "0 0.09 0.22 0.39 0.67 1.71"
End Sub
Sub HISTOGRAMHELP_Click ()
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPHIST.TXT": HELPBOX.Visible = -1
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
HELPBOX.Text = "NO HISTOGRAM HELP TEXT IS AVAILABLE."
Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
HELPBOX.Text = SHOWPAGE$
CLOSEHELPCOM.Visible = -1
End Sub
Sub HISTOGRAMPIC_Click ()
HISTOGRAMPIC.Cls
HISTOGRAMPIC.Visible = 0
End Sub
Sub IMAGEHELP_Click ()
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPIMAG.TXT": HELPBOX.Visible = -1
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
HELPBOX.Text = "NO IMAGE HELP TEXT IS AVAILABLE."
Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
HELPBOX.Text = SHOWPAGE$
CLOSEHELPCOM.Visible = -1
End Sub
Sub LEVEL100_Click ()
RHEOSTATPIC.Visible = 0
THRESHOLDVALUE! = 100#
THRESHOLDLONGI& = 100
SELFTHRESHOLDSW% = 0
LEVEL130.Checked = 0
LEVEL120.Checked = 0
LEVEL110.Checked = 0
LEVEL100.Checked = -1
LEVEL90.Checked = 0
LEVEL80.Checked = 0
LEVEL70.Checked = 0
LEVEL60.Checked = 0
LEVEL50.Checked = 0
End Sub
Sub LEVEL110_Click ()
RHEOSTATPIC.Visible = 0
'PICTURE1.Visible = -1
THRESHOLDVALUE! = 110#
THRESHOLDLONGI& = 110
SELFTHRESHOLDSW% = 0
LEVEL120.Checked = 0
LEVEL110.Checked = -1
LEVEL90.Checked = 0
LEVEL80.Checked = 0
LEVEL70.Checked = 0
LEVEL60.Checked = 0
LEVEL50.Checked = 0
LEVEL130.Checked = 0
LEVEL100.Checked = 0
End Sub
Sub LEVEL120_Click ()
RHEOSTATPIC.Visible = 0
'PICTURE1.Visible = -1
LEVEL120.Checked = -1
LEVEL110.Checked = 0
LEVEL90.Checked = 0
LEVEL80.Checked = 0
LEVEL70.Checked = 0
LEVEL60.Checked = 0
LEVEL50.Checked = 0
LEVEL130.Checked = 0
THRESHOLDVALUE! = 120#
THRESHOLDLONGI& = 120
SELFTHRESHOLDSW% = 0
LEVEL100.Checked = 0
'If G1(26) = 1 Then Call THREX
End Sub
Sub LEVEL130_Click ()
RHEOSTATPIC.Visible = 0
' ALL LEVELxxx_Click CHANGE THE THRESHOLD VALUE
' AND CHECK THE APPROPRIATE BOX
THRESHOLDVALUE! = 130#
THRESHOLDLONGI& = 130
SELFTHRESHOLDSW% = 0
LEVEL120.Checked = 0
LEVEL110.Checked = 0
LEVEL90.Checked = 0
LEVEL80.Checked = 0
LEVEL70.Checked = 0
LEVEL60.Checked = 0
LEVEL50.Checked = 0
LEVEL130.Checked = -1
LEVEL100.Checked = 0
'If G1(26) = 1 Then Call THREX
End Sub
Sub LEVEL140_Click ()
RHEOSTATPIC.Visible = 0
' ALL LEVEL140_Click CHANGE THE THRESHOLD VALUE
' AND CHECK THE APPROPRIATE BOX
'PICTURE1.Visible = -1
THRESHOLDVALUE! = 140#
THRESHOLDLONGI& = 140
SELFTHRESHOLDSW% = 0
LEVEL150.Checked = 0
LEVEL140.Checked = -1
LEVEL130.Checked = 0
LEVEL120.Checked = 0
LEVEL110.Checked = 0
LEVEL100.Checked = 0
LEVEL90.Checked = 0
LEVEL80.Checked = 0
LEVEL70.Checked = 0
LEVEL60.Checked = 0
LEVEL50.Checked = 0
'If G1(26) = 1 Then Call THREX
End Sub
Sub LEVEL150_Click ()
RHEOSTATPIC.Visible = 0
' ALL LEVEL150_Click CHANGE THE THRESHOLD VALUE
' AND CHECK THE APPROPRIATE BOX
'PICTURE1.Visible = -1
THRESHOLDVALUE! = 150
THRESHOLDLONGI& = 150
SELFTHRESHOLDSW% = 0
THRESHOLDBARCTL.Checked = 0
LEVEL150.Checked = 0
LEVEL140.Checked = 0
LEVEL130.Checked = 0
LEVEL120.Checked = 0
LEVEL110.Checked = 0
LEVEL100.Checked = 0
LEVEL90.Checked = 0
LEVEL80.Checked = 0
LEVEL70.Checked = 0
LEVEL60.Checked = 0
LEVEL50.Checked = 0
'If G1(26) = 1 Then Call THREX
End Sub
Sub LEVEL50_Click ()
RHEOSTATPIC.Visible = 0
'PICTURE1.Visible = -1
LEVEL100.Checked = 0
LEVEL120.Checked = 0
LEVEL110.Checked = 0
LEVEL90.Checked = 0
LEVEL80.Checked = 0
LEVEL70.Checked = 0
LEVEL60.Checked = 0
LEVEL130.Checked = 0
LEVEL50.Checked = -1
THRESHOLDVALUE! = 50#
THRESHOLDLONGI& = 50
SELFTHRESHOLDSW% = 0
'If G1(26) Then Call THREX
End Sub
Sub LEVEL60_Click ()
RHEOSTATPIC.Visible = 0
'PICTURE1.Visible = -1
THRESHOLDVALUE! = 60#
THRESHOLDLONGI& = 60
SELFTHRESHOLDSW% = 0
LEVEL100.Checked = 0
LEVEL120.Checked = 0
LEVEL110.Checked = 0
LEVEL90.Checked = 0
LEVEL80.Checked = 0
LEVEL70.Checked = 0
LEVEL50.Checked = 0
LEVEL130.Checked = 0
LEVEL60.Checked = -1
'If G1(26) = 1 Then Call THREX
End Sub
Sub LEVEL70_Click ()
RHEOSTATPIC.Visible = 0
'PICTURE1.Visible = -1
THRESHOLDVALUE! = 70#
THRESHOLDLONGI& = 70
SELFTHRESHOLDSW% = 0
LEVEL100.Checked = 0
LEVEL120.Checked = 0
LEVEL110.Checked = 0
LEVEL90.Checked = 0
LEVEL80.Checked = 0
LEVEL130.Checked = 0
LEVEL60.Checked = 0
LEVEL50.Checked = 0
LEVEL70.Checked = -1
'If G1(26) Then Call THREX
End Sub
Sub LEVEL80_Click ()
RHEOSTATPIC.Visible = 0
'PICTURE1.Visible = -1
THRESHOLDVALUE! = 80#
THRESHOLDVALUE! = 80
SELFTHRESHOLDSW% = 0
RHEOSTATPIC.Visible = 0
LEVEL100.Checked = 0
LEVEL120.Checked = 0
LEVEL110.Checked = 0
LEVEL90.Checked = 0
LEVEL130.Checked = 0
LEVEL70.Checked = 0
LEVEL60.Checked = 0
LEVEL50.Checked = 0
LEVEL80.Checked = -1
'If G1(26) = 1 Then Call THREX
End Sub
Sub LEVEL90_Click ()
RHEOSTATPIC.Visible = 0
THRESHOLDVALUE! = 90#
THRESHOLDLONGI& = 90
SELFTHRESHOLDSW% = 0
LEVEL100.Checked = 0
LEVEL120.Checked = 0
LEVEL110.Checked = 0
LEVEL130.Checked = 0
LEVEL80.Checked = 0
LEVEL70.Checked = 0
LEVEL60.Checked = 0
LEVEL50.Checked = 0
LEVEL90.Checked = -1
'If G1(26) = 1 Then Call THREX
End Sub
Sub LICENSEBOX_Change ()
'LICENSEBOX.VISIBLE = -1: LICENSECOM.VISIBLE = -1
End Sub
Sub LICENSECOM_Click ()
LICENSEBOX.Visible = 0: LICENSECOM.Visible = 0
GRANDDBS$ = "ISAP.DBS": DBSNAM$ = "ISAP.DBS": DBSSW% = 0
DATALINE$ = "": DBSLINE$ = "": DATAGRAND$ = ""
Close #23: Open GRANDDBS$ For Binary Access Write As #23
LGRANDDBS& = LOF(23)
If (LGRANDDBS& < 1) Then MSGX$ = "Do you wish to start database" + CRLF$ + DBSNAM$ + "?"
If (LGRANDDBS& > 0) Then MSGX$ = "Do you wish to append database" + CRLF$ + DBSNAM$ + "?"
ANSW% = MsgBox(MSGX$, 1)
If (ANSW% = 2) Then Close #23
If (ANSW% = 1) Then
DBSSW% = 1: If (LGRANDDBS& < 1) Then LGRANDDBS& = 1
End If
End Sub
Sub MEASUREDISTANCECTL_Click ()
'SETS UP PICTURE FOR LINE MEASUREMENT
IMAGEGRAB% = 2
End Sub
Sub MINIMUMMENU_Click ()
AVERAGESW% = 4
End Sub
Sub NEXTSEARCH_Click ()
' This is the routine which determines the
' next word in the HELP word search
WORDNOW& = WORDNOW& + 1: CRLF$ = Chr$(13) + Chr$(10)
If ((WORDNOW& > WORDCOUNT&) Or (WORDNOW& > 10)) Then
MSGG$ = "No more encounters" + CRLF$ + "of `" + LINPUT$ + "' in HELP TEXT"
MsgBox (MSGG$): HELPBOX.Visible = 0: NEXTSEARCH.Visible = 0
CLOSESEARCH.Visible = 0: Exit Sub
End If
HELPBOX.Visible = 0
FOUND& = WORDLOC&(WORDNOW&): LHEBX& = Len(HEBX$)
MIN1 = FOUND& - 1000: MAX1 = FOUND& + 1000
If (MIN1 < 1) Then MAX1 = MAX1 - MIN1: MIN1 = 1
If (MAX1 > LHEBX&) Then MIN1 = MIN1 - Abs(MAX1 - LHEBX&): MAX1 = LHEBX&
HELPBOX.Text = Mid$(HEBX$, MIN1, Abs(MIN1 - MAX1) + 1)
SCN& = InStr(1, HELPBOX.Text, LINPUT$): T$ = ">>>>>"
LHELPBOX& = Len(HELPBOX.Text)
HELPBOX.Text = Mid$(HELPBOX.Text, 1, SCN& - 1) + T$ + Mid$(HELPBOX.Text, SCN&, LHELPBOX& - SCN&)
HELPBOX.Visible = -1: NEXTSEARCH.Visible = -1: CLOSESEARCH.Visible = -1
End Sub
Sub OKCOMDIR_Click ()
'USER SELECTS THE OK COMMAND FOR DIRECTORYFILE
'TRANSFER TEMPORARY FILE NAME TO SELECTED FILE NAME
FLNMSEL$ = FLNMTMP$
If (FILEGRABPOINTER% = 1) Then FLNMBMP$ = FLNMSEL$
If (FILEGRABPOINTER% = 2) Then FLNMTGA$ = FLNMSEL$
If (FILEGRABPOINTER% = 4) Then FLNMHDR$ = FLNMSEL$
'HIDE THE DIRECTORYFILE, OK & CANCEL COMMANDS.
DIRECTORYFILE.Visible = 0: COLORLIST.Visible = 0
OKCOMDIR.Visible = 0: CANCELCOMDIR.Visible = 0
'IF A FILE HAS BEEN SELECTED, THEN CALL FILEGRABBER
If (FLNMSEL$ <> "") Then
FLNMSAV$ = FLNMSEL$: Call FILEGRABBER: Exit Sub
End If
'IF NO FILE HAS BEEN SELECTED, THEN ERROR MESSAGE
If (FLNMSEL$ = "") Then
MSGX$ = "NO FILE NAME" + CRLF$ + "HAS BEEN SELECTED"
MsgBox MSGX$, 48, "USER GUIDE": Exit Sub
End If
End Sub
Sub OPENIMAGE_Click ()
'OPEN IMAGE FILE
'HIDE ALL IRRELEVANT OBJECTS
HELPBOX.Visible = 0
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
'DISABLE ALL IRRELEVANT MENU SELECTIONS
IMAGEMENU.Enabled = 0
EDGECTL.Enabled = 0: ANALYSISCTL.Enabled = 0
DATABASECTL.Enabled = -1
'VIEWDBS.Enabled = -1:
VIEWACTIVEDBS.Enabled = 0
'POINTER FOR FILEGRABBER HANDLER EQUALS 1
FILEGRABPOINTER% = 1
'SHOW THE LIST OF .BMP FILES IN THE CURRENT DIRECTORY
DIRECTORYFILE.Visible = -1: DIRECTORYFILE.Pattern = "*.BMP"
OKCOMDIR.Visible = -1: CANCELCOMDIR.Visible = -1
NEWFILESW% = 0: OPENFILESW% = 1: TGABMPSW% = 0: RAWBMPSW% = 0
End Sub
Sub PALETTEHELP_Click ()
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPPALE.TXT": HELPBOX.Visible = -1
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
HELPBOX.Text = "NO PALETTE HELP TEXT IS AVAILABLE."
Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
HELPBOX.Text = SHOWPAGE$
CLOSEHELPCOM.Visible = -1
End Sub
Sub PALETTEMENU_Click ()
'CHANGING THE COLOR PALETTE:
'THE FIRST 1080 BYTES OF THE SELECTED HEADER FILE
'ARE PLACED AT THE HEAD OF THE .BMP FILE
'TO CREATE A NEW .BMP FILE WITH A NEW HEADER
'IF NO IMAGE FILE IS LOADED, ERROR BOX.
If (FLNMBMP$ = "") Then
MSGX$ = "You must first OPEN IMAGE (File Menu)"
MsgBox MSGX$, 48, "USER GUIDE:": Exit Sub
End If
'THE FILE POINTER IS 4 FOR COLOR PALETTE CHANGE
GRABPAGE$ = String$(3000, " "): FILEGRABPOINTER% = 4
'FLNMBMP$ = FLNMSEL$
'HIDE UNNECESSARY TEXT AND COMMAND BOXES
DBOX.Visible = 0: DONECLOSECOM.Visible = 0: HELPBOX.Visible = 0
'SHOW THE COLOR LIST, OK&CANCEL COMMANDS
COLORLIST.Visible = -1: OKCOMDIR.Visible = -1: CANCELCOMDIR.Visible = -1
'IF THE COLORLIST HAS NOT BEEN FILLED,
'THEN IT MUST BE FILLED WITH THE LIST OF COLORS
'FROM FILE `ISAPHEAD.TXT'. THEN WE SET 'PALETTESW%=0,
'SO THAT THE COLORLIST WILL ONLY BE FILLED ONCE.
If (PALETTESW% = 0) Then
PALETTESW% = 1: FILEHEADER$ = "ISAPHEAD.TXT"
HELPBOX.Visible = 0
': DONEBOX.Visible = 0
'IF NO COLOR HEADER TEXT (ISAPHEAD.TXT) IS AVAILABLE,
'THEN ERROR BOX
Open FILEHEADER$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
MSGX$ = "File `ISAPHEAD.TXT' is not available." + CRLF$ + "Please copy from original floppy disk."
MsgBox MSGX$, 48, "USER GUIDE:": Exit Sub
End If
'SHOW THE HEADER TEXT (SELECTION OF COLORS)
LBGRAB& = InStr(4, GRABPAGE$, "#"): LSSTR& = 4: INGRAB& = 1
Do While ((INGRAB& < LBGRAB&) And (INGRAB& > 0))
INGRAB& = InStr(LSSTR&, GRABPAGE$, CRLF$)
If ((INGRAB& < LBGRAB&) And (INGRAB& > 0)) Then
LINEGRAB$ = Mid$(GRABPAGE$, LSSTR&, INGRAB& - 1)
LABELIN% = InStr(LINEGRAB$, "^")
LABELGRAB$ = Mid$(LINEGRAB$, 1, LABELIN% - 1)
LSSTR& = INGRAB& + 2
COLORLIST.AddItem LABELGRAB$
End If
Loop
End If
'AT THIS POINT, THE USER MUST CLICK ON A COLOR SELECTION.
'THE HANDLER IS COLORLIST_CLICK.
'ALTERNATIVELY, THE USER MAY DOUBLE-CLICK ON COLOR SELECTION.
'THEN THE USER MAY EITHER `OK' (=OKCOMDIR)
'OR `CANCEL' (=CANCELCOMDIR).
End Sub
Sub QUITCTL_Click ()
'CLOSE THE DATABASE FILE AND EXIT PROGRAM
If (DBSSW% = 1) Then
MSGX$ = "YOU HAVE APPENDED FILE" + CRLF$ + "ISAP.DBS"
MsgBox MSGX$: DGR$ = DATAGRAND$ + CRLF$
Put #23, LGRANDDBS&, DGR$: Close #23
End If
End
End Sub
Sub RAWBMPCTL_Click ()
'OPEN THE FILE BOX;
'SET THE RAW CONVERT SWITCH
NEWFILESW% = 0: OPENFILESW% = 0
TGABMPSW% = 0: RAWBMPSW% = 1
'DONEBOX.Visible = 0:
DIRECTORYFILE.Visible = -1
FILEGRABPOINTER% = 3: DIRECTORYFILE.Pattern = "*.RAW"
OKCOMDIR.Visible = -1: CANCELCOMDIR.Visible = -1
End Sub
Sub RAWDN_Change ()
RAWB = Int(Val((RAWDN.Text)))
If RAWB = 0 Then RAWB = 1
RAWA = Int(RAWLEN / RAWB)
RAWACR.Text = Str$(RAWA)
End Sub
Sub REFRESHCTL_Click ()
FILEGRABPOINTER% = 1
Call FILEGRABBER
End Sub
Sub RHEOSTATPIC_MouseDown (Button As Integer, Shift As Integer, X As Single, Y As Single)
'RESET RHEOSTAT
THRESHOLDVALUE! = Y
THRESHOLDLONGI& = THRESHOLDVALUE!
Call THRESHOLDBAR
End Sub
Sub SELFTHRESHOLD ()
'SET ERROR SWITCH
SELFERRORSW% = 1
'OBTAIN SELF-THRESHOLD
'PREPARE IMAGE HISTOGRAM
HJN! = 0: HJS! = 0: HJQ! = 0: MAXJR! = 1E+17: MAXII& = 0
FPC! = .1 * AJN!: GPC! = .5 * AJN!
For II& = 0 To 255
HJN! = HJN! + HIST&(II&): BJN! = AJN! - HJN!
HJS! = HJS! + (HIST&(II&) * II&)
HJQ! = HJQ! + (HIST&(II&) * II& * II&)
If ((HJN! > FPC!) And (BJN! > GPC!)) Then
BJS! = AJS! - HJS!: BJQ! = AJQ! - HJQ!
HJR! = HJQ! - ((HJS! * HJS!) / HJN!)
BJR! = BJQ! - ((BJS! * BJS!) / BJN!)
CJR! = HJR! + BJR!
If (CJR! < MAXJR!) Then
MAXJR! = CJR!: MAXII& = II&
End If
End If
Next II&
THRESHOLDVALUE! = MAXII&
THRESHOLDLONGI& = MAXII&
SELFERRORSW% = 0
End Sub
Sub SELFTHRESHOLDCTL_Click ()
'BLOCK SELECT SELF-THRESHOLD
RHEOSTATPIC.Visible = 0
SELFTHRESHOLDCTL.Checked = -1
THRESHOLDVALUE! = 0
THRESHOLDLONGI& = 0
THRESHOLDBARCTL.Checked = 0
LEVEL150.Checked = 0
LEVEL140.Checked = 0
LEVEL130.Checked = 0
LEVEL120.Checked = 0
LEVEL110.Checked = 0
LEVEL100.Checked = 0
LEVEL90.Checked = 0
LEVEL80.Checked = 0
LEVEL70.Checked = 0
LEVEL60.Checked = 0
LEVEL50.Checked = 0
SELFTHRESHOLDSW% = 1
End Sub
Sub SHOWMEDIA ()
'SHOW THE IMAGEBOX
'FOR DEBUGGING PURPOSES
SHOWTEMP$ = ""
'If (SELFERRORSW% = 0) Then
For HH& = 1 To YLENG&
SHOWTEMP$ = SHOWTEMP$ + CRLF$
For II& = 1 To XLENG&
AIM$ = " ": ASCIM& = IMAGEBOX&(HH&, II&)
If (ASCIM& = 2) Then AIM$ = "2"
If (ASCIM& = 3) Then AIM$ = "3"
If (ASCIM& = 4) Then AIM$ = "O"
If (ASCIM& = 5) Then AIM$ = "="
If (ASCIM& = 6) Then AIM$ = "*"
If (ASCIM& = 7) Then AIM$ = "A"
If (ASCIM& = 8) Then AIM$ = "Z"
SHOWTEMP$ = SHOWTEMP$ + AIM$
Next II&
Next HH&
HELPBOX.Visible = -1
HELPBOX.Text = SHOWTEMP$
'End If
End Sub
Sub SIZE11X11_Click ()
WINDOWVALUE& = 11
size11x11.Checked = -1
size9x9.Checked = 0
size4x4.Checked = 0
size6x6.Checked = 0
size5x5.Checked = 0
End Sub
Sub SIZE4X4_Click ()
WINDOWVALUE& = 3
size11x11.Checked = 0
size9x9.Checked = 0
size6x6.Checked = 0
size5x5.Checked = 0
size4x4.Checked = -1
End Sub
Sub SIZE5X5_Click ()
WINDOWVALUE& = 5
size11x11.Checked = 0
size9x9.Checked = 0
size4x4.Checked = 0
size6x6.Checked = 0
size5x5.Checked = -1
End Sub
Sub SIZE6X6_Click ()
WINDOWVALUE& = 7
size11x11.Checked = 0
size9x9.Checked = 0
size4x4.Checked = 0
size5x5.Checked = 0
size6x6.Checked = -1
End Sub
Sub SIZE9X9_Click ()
WINDOWVALUE& = 9
size11x11.Checked = -1
size9x9.Checked = -1
size4x4.Checked = 0
size6x6.Checked = 0
size5x5.Checked = 0
End Sub
Sub TGABMPCTL_Click ()
'OPEN THE FILE BOX;
'SET THE TGA CONVERT SWITCH
NEWFILESW% = 0: OPENFILESW% = 0
TGABMPSW% = 1: RAWBMPSW% = 0
DIRECTORYFILE.Visible = -1
FILEGRABPOINTER% = 2: DIRECTORYFILE.Pattern = "*.TGA"
OKCOMDIR.Visible = -1: CANCELCOMDIR.Visible = -1
End Sub
Sub THRESHOLDBAR ()
'SET OR RESET THRESHOLD BAR
If (RHEOSTATSW% = 0) Then
RHEOSTATPIC.Cls
THRESHOLDVALUE! = 80#: THRESHOLDLONGI& = 80
Close #6: Open FLNMSEL$ For Binary Access Read As #6
Seek #6, 57
For U = 0 To 255
R$ = Input$(4, #6)
R1 = Asc(Left$(R$, 1))
B = Asc(Mid$(R$, 3, 1))
G = Asc(Right$(R$, 1))
RHEOSTATPIC.Line (0, U)-(15, (U + 1)), RGB(R1, G, B), BF
Next U
Close #6
LASX = 500
End If
RHEOSTATSW% = 1
RHEOSTATPIC.Line (16, LASX)-(30, LASX), RGB(255, 255, 255)
RHEOSTATPIC.Line (16, THRESHOLDVALUE!)-(30, THRESHOLDVALUE!), RGB(255, 0, 0)
LASX = THRESHOLDVALUE!
THRESHOLDLONGI& = LASX
End Sub
Sub THRESHOLDBARCTL_Click ()
'BLOCK SELECT THRESHOLD BAR
RHEOSTATPIC.Visible = -1
THRESHOLDBARCTL.Checked = -1
SELFTHRESHOLDCTL.Checked = 0
LEVEL150.Checked = 0: LEVEL140.Checked = 0
LEVEL130.Checked = 0: LEVEL120.Checked = 0
LEVEL110.Checked = 0: LEVEL100.Checked = 0
LEVEL90.Checked = 0: LEVEL80.Checked = 0
LEVEL70.Checked = 0: LEVEL60.Checked = 0
LEVEL50.Checked = 0
SELFTHRESHOLDSW% = 0
Call THRESHOLDBAR
End Sub
Sub THRESHOLDCTL_Click ()
'THRESHOLD
If (FIRSTTIMETHRESHSW% = 1) Then
FIRSTTIMETHRESHSW% = 0: GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPTHRS.TXT"
Close #1: Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1): Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then GRABPAGE$ = "# FILE `ISAPTHRS.TXT' IS MISSING. #"
INGRAB& = InStr(4, GRABPAGE$, "#"): ' SHOWS HELP TEXT
MSGG$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
MsgBox MSGG$, 48, "USER GUIDE"
Exit Sub
End If
End Sub
Sub TRACEEDGE ()
'TRACE EDGE FROM THRESHOLDED PARTICLE
'HANDLER FOR PERFORMING SOLID-FILL METHOD FOR EDGE DETECTION
'STARTING FROM THE SELECT-BLOCK CENTER, THE METHOD EXAMINES
'FOUR NEIGHBOR POINTS (UP, DOWN, LEFT, RIGHT).
'EACH POINT IS EITHER AN INSIDE POINT OR AN EDGE POINT,
'DEPENDING ON THE THRESHOLD FOR A PIXEL-WINDOW.
'BY G. WILLIAM MOORE, MD, PhD, 9/4/94.
'SET ERROR SWITCH
SELFERRORSW% = 1
'INITIALIZE POINTER ARRAY
PTRX&(1) = -1: PTRY&(1) = -1
PTRX&(2) = -1: PTRY&(2) = 1
PTRX&(3) = 1: PTRY&(3) = 1
PTRX&(4) = 1: PTRY&(4) = -1
PTRX&(5) = 1: PTRY&(5) = 0
PTRX&(6) = -1: PTRY&(6) = 0
PTRX&(7) = 0: PTRY&(7) = 1
PTRX&(8) = 0: PTRY&(8) = -1
'DETERMINE TRACE PERCENTAGE
TRACESUM& = 0
For II& = THRESHOLDLONGI& To 255
TRACESUM& = TRACESUM& + HIST&(II&)
Next II&
TRACEPCT& = (TRACESUM& * 100) / WORKAREA&
'INITIALIZE PUSHDOWNLIST, EDGELIST
NEDGE& = 0: NPUSH& = 1: IPUSH& = 0
For II& = 1 To 500
PUSHX&(II&) = 0: PUSHY&(II&) = 0
EDGEX&(II&) = 0: EDGEY&(II&) = 0
Next II&
'INSIDE POINTS; CENTER OF GRAVITY
GXN! = 0: GXS! = 0: GYN! = 0: GYS! = 0: NEDGE& = 0
For HH& = 1 To YLENG&
IML$ = IMAGELIN$(HH&)
For II& = 1 To XLENG&
ASI& = Asc(Mid$(IML$, II&, 1))
If ((ASI& < THRESHOLDLONGI&) And (IMAGEBOX&(HH&, II&) = 1)) Then
IMAGEBOX&(HH&, II&) = 2
GYN! = GYN! + 1: GYS! = GYS! + HH&
GXN! = GXN! + 1: GXS! = GXS! + II&
End If
Next II&
Next HH&
If ((GXN! < 6) Or (GYN! < 6)) Then Exit Sub
If ((GXN! < 16) Or (GYN! < 16)) Then
MSGX$ = "PARTICLE TOO SMALL.": MsgBox MSGX$, 48, "USER GUIDE:"
If (GWMSW% = 1) Then Call SHOWMEDIA
Exit Sub
End If
AVX! = GXS! / GXN!: AVY! = GYS! / GYN!
CTX& = AVX! + MINX& + 1: CTY& = AVY! + MINY& + 1
'SURROUND AND CAPTURE LIGHT PIXELS
For GG& = 1 To 2
For HH& = 1 To YLENG&
For II& = 1 To XLENG&
IMX& = IMAGEBOX&(HH&, II&): JSUM& = 0
If (IMX& < 2) Then
AVTX&(1) = IMAGEBOX&(HH&, II& + 1): AVTX&(3) = IMAGEBOX&(HH&, II& - 1)
AVTX&(4) = IMAGEBOX&(HH& + 1, II&): AVTX&(2) = IMAGEBOX&(HH& - 1, II&)
For JJ& = 1 To 4
If (AVTX&(JJ&) > 1) Then JSUM& = JSUM& + 1
Next JJ&
If (JSUM& > 2) Then IMAGEBOX&(HH&, II&) = 2
End If
Next II&
Next HH&
Next GG&
'SURROUND AND CAPTURE DARK PIXELS
For GG& = 1 To 2
For HH& = 1 To YLENG&
For II& = 1 To XLENG&
IMX& = IMAGEBOX&(HH&, II&): JSUM& = 0
If (IMX& > 1) Then
AVTX&(1) = IMAGEBOX&(HH&, II& + 1): AVTX&(3) = IMAGEBOX&(HH&, II& - 1)
AVTX&(4) = IMAGEBOX&(HH& + 1, II&): AVTX&(2) = IMAGEBOX&(HH& - 1, II&)
For JJ& = 1 To 4
If (AVTX&(JJ&) < 2) Then JSUM& = JSUM& + 1
Next JJ&
If (JSUM& > 2) Then IMAGEBOX&(HH&, II&) = 1
End If
Next II&
Next HH&
Next GG&
'PUSHDOWN LIST FOR SOLID-FILL ALGORITHM
IPUSH& = 0: NPUSH& = 1: PUSHX&(1) = AVX!: PUSHY&(1) = AVY!
IMAGEBOX&(PUSHY&(1), PUSHX&(1)) = 4
Do While (NPUSH& > IPUSH&)
IPUSH& = IPUSH& + 1: JPUSH& = IPUSH& Mod 500&
PSX& = PUSHX&(JPUSH&): PSY& = PUSHY&(JPUSH&)
For II& = 1 To 8
PXI& = PTRX&(II&) + PSX&: PYI& = PTRY&(II&) + PSY&
If (PXI& < 1) Then PXI& = 1
If (PXI& > XLENG&) Then PXI& = XLENG&
If (PYI& < 1) Then PYI& = 1
If (PYI& > YLENG&) Then PYI& = YLENG&
If ((PYI& >= 1) And (PYI& <= YLENG&) And (PXI& >= 0) And (PXI& <= XLENG&)) Then
PMI& = IMAGEBOX&(PYI&, PXI&)
If (PMI& = 2) Then
NPUSH& = NPUSH& + 1: MPUSH& = NPUSH& Mod 500&
PUSHX&(MPUSH&) = PXI&: PUSHY&(MPUSH&) = PYI&
IMAGEBOX&(PYI&, PXI&) = 4
End If
End If
Next II&
Loop
'REMOVE POINTS OUTSIDE THE SOLID FILL AREA
For HH& = 1 To YLENG&
For II& = 1 To XLENG&
IMX& = IMAGEBOX&(HH&, II&)
If ((IMX& > 1) And (IMX& < 4)) Then IMAGEBOX&(HH&, II&) = 1
Next II&
Next HH&
'FIND FINAL EDGE POINTS
For HH& = 1 To YLENG&
For II& = 1 To XLENG&
IMX& = IMAGEBOX&(HH&, II&)
If (IMX& = 4) Then
AVTX&(1) = IMAGEBOX&(HH&, II& + 1): AVTX&(3) = IMAGEBOX&(HH&, II& - 1)
AVTX&(4) = IMAGEBOX&(HH& + 1, II&): AVTX&(2) = IMAGEBOX&(HH& - 1, II&)
For JJ& = 1 To 4
If (AVTX&(JJ&) < 2) Then
IMAGEBOX&(HH&, II&) = 5: NEDGE& = NEDGE& + 1
If (NEDGE& > 499) Then
MSGX$ = "EDGE TOO LONG."
MsgBox MSGX$
Exit Sub
End If
EDGEX&(NEDGE&) = II&: EDGEY&(NEDGE&) = HH&
End If
Next JJ&
End If
Next II&
Next HH&
If (NEDGE& < 10) Then
MSGX$ = "PARTICLE EDGE IS TOO SHORT:" + CRLF$ + Str$(NEDGE&) + " PIXELS (MIN=10)"
MsgBox MSGX$
If (GWMSW% = 1) Then Call SHOWMEDIA
Exit Sub
End If
For II& = 1 To NEDGE&
IEX& = EDGEX&(II&): IEY& = EDGEY&(II&)
OO& = 1
Do While (OO& < OBND&)
OO& = OO& + 1
XO& = BNDX&(OO&) - MINX& - 1: YO& = BNDY&(OO&) - MINY& - 1
XAB& = Abs(XO& - IEX&): YAB& = Abs(YO& - IEY&)
If ((XAB& < 10) And (YAB& < 10)) Then
IMAGEBOX&(IEY&, IEX&) = 5: OO& = (OBND& * 2) + 2
End If
Loop
Next II&
'MARK PERIMETER
NPERM& = 1: SVCRN& = 0: MAXREACH& = 0
IEX& = EDGEX&(NPERM&): IEY& = EDGEY&(NPERM&)
AEX& = IEX&: AEY& = IEY&
IMAGEBOX&(IEY&, IEX&) = 6
PERMX&(1) = IEX&: PERMY&(1) = IEY&
PRMSW& = 0: PRMTR& = 0: NDIVID& = 0
': MAXCRN& = 607
Do While ((NPERM& < NEDGE&) And (PRMSW& < 1))
PRMSW& = 1: MPERM& = NPERM&: NPERM& = NPERM& + 1
IMGX& = 0: IMGY& = 0
IEX& = PERMX&(MPERM&): IEY& = PERMY&(MPERM&)
ICRN& = 0: CRSW& = 0: SVX& = 0: SVY& = 0
Do While ((ICRN& < NREACH&) And (CRSW& < 1))
ICRN& = ICRN& + 1
VXY& = VFNL&(ICRN&): VYY& = VXY& \ 100: VXX& = VXY& - (VYY& * 100)
VX& = VXX& + IEX& - 8: VY& = VYY& + IEY& - 8
If (VX& < 1) Then VX& = 1
If (VX& > XLENG&) Then VX& = XLENG&
If (VY& < 1) Then VY& = 1
If (VY& > YLENG&) Then VY& = YLENG&
If (IMAGEBOX&(VY&, VX&) = 5) Then
CRSW& = 1: SVX& = VX&: SVY& = VY&: SVCRN& = ICRN&
PERMX&(NPERM&) = VX&: PERMY&(NPERM&) = VY&
IMAGEBOX&(VY&, VX&) = 6: PRMSW& = 0
NDIVID& = NDIVID& + 1: PRMTR& = PRMTR& + 1
If (MAXREACH& < ICRN&) Then MAXREACH& = ICRN&
End If
Loop
Loop
ZEX& = PERMX&(MPERM&): ZEY& = PERMY&(MPERM&): AREA& = GXN!
IMAGEBOX&(AEY&, AEX&) = 7: IMAGEBOX&(ZEY&, ZEX&) = 8
ZIPPER& = Abs(ZEX& - AEX&) + Abs(ZEY& - AEY&)
If ((ZIPPER& > 18) Or (PRMTR& < 20)) Then
PRMTR& = 0
MSGX$ = "PERIMETER ERROR:" + CRLF$ + "ZIPPER=" + Str$(ZIPPER&)
MsgBox MSGX$
If (GWMSW% = 1) Then Call SHOWMEDIA
Exit Sub
End If
DATALINE$ = FLNMBMP$ + "," + Str$(CTX&) + "," + Str$(CTY&) + "," + Str$(TRACEPCT&) + "," + Str$(AREA&) + ","
Call DBSCALC
SELFERRORSW% = 0
End Sub
Sub TROUBLEHELP_Click ()
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPTRUB.TXT": HELPBOX.Visible = -1
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
HELPBOX.Text = "NO TROUBLESHOOTING HELP TEXT IS AVAILABLE."
Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
HELPBOX.Text = SHOWPAGE$
CLOSEHELPCOM.Visible = -1
End Sub
Sub VALUESCTL_Click ()
'DISPLAY DATABASE VALUES IN VALUEBOX.TEXT
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
VALUESCTL.Enabled = 0: CLOSEITEMCTL.Enabled = -1
HISTOGRAMCTL.Enabled = -1: HELPBOX.Visible = 0
VALUEBOX.Visible = 0: HISTOGRAMPIC.Visible = 0
DBX$ = "CALCULATED VALUES (SEE HELP FOR EXPLANATION):"
DBX$ = DBX$ + CRLF$ + "AREA: " + Str$(NUCAREA&) + " GRAY_SUM: " + Str$(DENSUM&) + " DENSE_SUM: " + Str$(ODENSUM!)
DBX$ = DBX$ + CRLF$ + "DENSE_AVG: " + Str$(ODENSAVG!) + " DENSE_STD: " + Str$(ODENSTD!) + " THRESHOLD: " + Str$(THRESHOLDLONGI&)
DBX$ = DBX$ + CRLF$ + "AVG_DIAM: " + Str$(AREADIAM!) + " MAX_DIAM: " + Str$(ROOTDIAM!) + " MIN_DIAM: " + Str$(EMINDIAM!)
DBX$ = DBX$ + CRLF$ + "ECCENT: " + Str$(ECCENT!) + " X-CENTER: " + Str$(XCENTER!) + " Y-CENTER: " + Str$(YCENTER!)
DBX$ = DBX$ + CRLF$ + "FRACTAL: " + Str$(FRDIM!) + " CONTOUR: " + Str$(NUCCONT!) + " PERIMETER: " + Str$(PRMONE!)
DBX$ = DBX$ + CRLF$ + "WORKSPACE: " + Str$(WORKAREA&) + " GRAY AVG: " + Str$(GRAYAVG&) + " MAX REACH: " + Str$(MAXREACH&)
VALUEBOX.Visible = -1: VALUEBOX.Text = DBX$
End Sub
Sub VALUESHELP_Click ()
DBOX.Visible = 0: DONECLOSECOM.Visible = 0
GRABPAGE$ = String$(3000, " ")
FILETEXT$ = "ISAPVALU.TXT": HELPBOX.Visible = -1
Open FILETEXT$ For Binary Access Read As #1
LOFTEXT& = LOF(1)
Get #1, , GRABPAGE$: Close #1
If (LOFTEXT& < 10) Then
HELPBOX.Text = "NO VALUES HELP TEXT IS AVAILABLE."
Exit Sub
End If
INGRAB& = InStr(4, GRABPAGE$, "#")
SHOWPAGE$ = Mid$(GRABPAGE$, 4, INGRAB& - 4)
HELPBOX.Text = SHOWPAGE$
CLOSEHELPCOM.Visible = -1
End Sub
Sub VIEWACTIVEDBS_Click ()
'VIEW ACTIVE DATABASE
DBOX.Visible = -1: DBOX.Text = DBOXTEXT$
DONECLOSECOM.Visible = -1: VALUEBOX.Visible = 0
End Sub
Sub VIEWDBS_Click ()
' 'VIEW DATABASE
' 'CRLF$ = Chr$(13) + Chr$(10)
' DONECLOSECOM.Visible = 0: DBOX.Visible = 0: DBOX.Text = ""
' DIRECTORYFILE.Visible = -1
' FILEGRABPOINTER% = 15
' DIRECTORYFILE.Pattern = "*.DBS"
' OKCOMDIR.Visible = -1
' CANCELCOMDIR.Visible = -1
End Sub
Sub WORDSEARCHHELP_Click ()
' This is the routine which determines the
' FIRST word in the HELP word search
UINPUT$ = InputBox$("Enter word for word search")
If UINPUT$ = "" Then Exit Sub
LINPUT$ = LCase$(UINPUT$): LLINPUT& = Len(LINPUT$)
Close #9
Open "ISAPSRCH.TXT" For Binary Access Read As #9
LOF9& = LOF(9)
If (LOF9& < 100) Then
MsgBox ("HELP SEARCH File Not Found.")
HELPBOX.Visible = 0: Close #9: Exit Sub
End If
HEBX$ = LCase$(Input$((65534 / 2), #9))
Close #9
WORDSW% = 1: WORDLAST& = 4: WORDCOUNT& = 0
Do While (WORDSW% = 1)
FOUND& = InStr(WORDLAST&, HEBX$, LINPUT$)
If ((WORDCOUNT& < 1) And (FOUND& = 0)) Then
MsgBox ("`" + LINPUT$ + "' not found in HELP SEARCH File.")
WORDSW% = 0: HELPBOX.Visible = 0: Exit Sub
End If
If (WORDCOUNT& > 19) Then WORDSW% = 0
If (FOUND& < 2) Then WORDSW% = 0
If (WORDSW% = 1) Then
WORDCOUNT& = WORDCOUNT& + 1: WORDLOC&(WORDCOUNT&) = FOUND&
WORDLAST& = FOUND& + 1
End If
Loop
If (WORDCOUNT& > 1) Then
FOUND& = WORDLOC&(1): WORDNOW& = 1
MIN1 = FOUND& - 1000: MAX1 = FOUND& + 1000
If (MIN1 < 1) Then MAX1 = MAX1 - MIN1: MIN1 = 1
If (MAX1 > Len(HEBX$)) Then MIN1 = MIN1 - Abs(MAX1 - Len(HEBX$)): MAX1 = Len(HEBX$)
HELPBOX.Text = Mid$(HEBX$, MIN1, Abs(MIN1 - MAX1) + 1)
SCN& = InStr(1, HELPBOX.Text, LINPUT$): T$ = ">>>>>"
LHELPBOX& = Len(HELPBOX.Text)
HELPBOX.Text = Mid$(HELPBOX.Text, 1, SCN& - 1) + T$ + LINPUT$ + Mid$(HELPBOX.Text, SCN& + LLINPUT&, LHELPBOX& - SCN& - LLINPUT&)
HELPBOX.Visible = -1: CLOSEHELPCOM.Visible = -1
NEXTSEARCH.Visible = -1: CLOSESEARCH.Visible = -1
End If
End Sub
Sub WORK05_Click ()
HISTOPCT& = 5
End Sub
Sub WORK10_Click ()
HISTOPCT& = 10
End Sub
Sub WORK15_Click ()
HISTOPCT& = 15
End Sub
Sub WORK20_Click ()
HISTOPCT& = 20
End Sub
Sub WORK50_Click ()
HISTOPCT& = 50
End Sub
Sub WORKSPACE ()
'OUTLINE THE WORKSPACE IN WHICH THE IMAGE APPEARS
'SET ERROR SWITCH
SELFERRORSW% = 1
'INITIALIZE X-LENGTH OF A SINGLE IMAGE LINE.
PXLINE$ = String$(XBYTES% + 4, " "): FileName$ = FLNMBMP$
'INITIALIZE X-LENGTH AND Y-LENGTH PARAMETERS
AJN! = 0!: AJS! = 0!: AJQ! = 0!
XXS! = 0: YYS! = 0: XXN! = 0: YYN! = 0
MAXX& = 0: MAXY& = 0: MINX& = 999999: MINY& = 999999
'FIND MAXIMUM X-LENGTH AND Y-LENGTH OF WORKSPACE
For II& = 1 To NBND&
XVL& = BNDX&(II&): YVL& = BNDY&(II&)
If (XVL& < MINX&) Then MINX& = XVL&
If (XVL& > MAXX&) Then MAXX& = XVL&
If (YVL& < MINY&) Then MINY& = YVL&
If (YVL& > MAXY&) Then MAXY& = YVL&
Next II&
XLENG& = MAXX& - MINX& + 2: YLENG& = MAXY& - MINY& + 2
'IF USER BOUNDARY X-LENGTH OR Y-LENGTH EXCEEDS 198 PIXELS,
'THEN USER BOUNDARY IS TOO LARGE
If ((YLENG& > 198) Or (XLENG& > 198)) Then
MSGX$ = "PARTICLE WINDOW TOO LARGE:" + CRLF$
MSGX$ = MSGX$ + "ABSCISSA:" + Str$(XLENG&) + " (MAX=190)" + CRLF$
MSGX$ = MSGX$ + "ORDINATE:" + Str$(YLENG&) + " (MAX=190)" + CRLF$
MsgBox MSGX$
Exit Sub
End If
'ZERO THE COMPLETE IMAGEBOX
'IMAGEBOX(,)=0 OUTSIDE THE USER BOUNDARY
'IMAGEBOX(,)=1 INSIDE THE USER BOUNDARY
'IMAGEBOX(,)=2 INSIDE THRESHOLDED IMAGE
For HH& = 1 To YLENG&
For II& = 1 To XLENG&
IMAGEBOX&(HH&, II&) = 0
Next II&
Next HH&
'SET IMAGEBOX(,)=1 AT THE BOUNDARY OF THE IMAGEBOX
For II& = 1 To NBND&
XVL& = BNDX&(II&) - MINX& + 1
YVL& = BNDY&(II&) - MINY& + 1
IMAGEBOX&(YVL&, XVL&) = 1
Next II&
'READ IN THE IMAGE FROM FILE FLNMBMP$, LINE-BY-LINE
Close #1: Open FLNMBMP$ For Binary Access Read As #1
YSCREEN& = YBYTES%: XSCREEN& = XBYTES%
PXLINE$ = String$(XSCREEN& + 4, " ")
For II& = 1 To YLENG&
IIY& = II& + MINY& + 1
FILESTART& = (((YSCREEN& + 1) - IIY&) * (XSCREEN&)) + (1080 - (XSCREEN&))
Get #1, FILESTART&, PXLINE$
IMAGELIN$(II&) = Mid$(PXLINE$, MINX&, XLENG&)
Next II&
Close #1
'FILL IN ADDITIONAL IMAGEBOX(,) POINTS WITHIN USER BOUNDARY
OBND& = NBND&
For IB& = 1 To NBND&
IC& = IB& + 1
If (IB& = NBND&) Then IC& = 1
XL& = BNDX&(IB&): YL& = BNDY&(IB&)
XU& = BNDX&(IC&): YU& = BNDY&(IC&)
XN& = XL&: XX& = XU&
If (XN& > XX&) Then
XN& = XU&: XX& = XL&
End If
YN& = YL&: YX& = YU&
If (YN& > YX&) Then
YN& = YU&: YX& = YL&
End If
If (XL& <> XU&) Then
SLP! = (YU& - YL&) / (XU& - XL&)
For XI& = (XN& + 1) To (XX& - 1)
YI& = ((XI& - XL&) * SLP!) + YL&
IMAGEBOX&(YI& - MINY& + 1, XI& - MINX& + 1) = 1
OBND& = OBND& + 1
If (OBND& > 499) Then
MSGX$ = "EDGE TOO LONG"
MsgBox MSGX$, 48, "USER GUIDE:"
Exit Sub
End If
BNDX&(OBND&) = XI&: BNDY&(OBND&) = YI&
Next XI&
End If
If (YL& <> YU&) Then
SLP! = (XU& - XL&) / (YU& - YL&)
For YI& = (YN& + 1) To (YX& - 1)
XI& = ((YI& - YL&) * SLP!) + XL&
IMAGEBOX&(YI& - MINY& + 1, XI& - MINX& + 1) = 1
OBND& = OBND& + 1
If (OBND& > 499) Then
MSGX$ = "EDGE TOO LONG"
MsgBox MSGX$, 48, "USER GUIDE:"
Exit Sub
End If
BNDX&(OBND&) = XI&: BNDY&(OBND&) = YI&
Next YI&
End If
Next IB&
For II& = 1 To YLENG&
JLO& = 1: IMSW& = 0
Do While ((IMSW& = 0) And (JLO& < XLENG&))
IMSW& = IMAGEBOX&(II&, JLO&)
If (IMSW& = 0) Then JLO& = JLO& + 1
Loop
JHI& = XLENG&: IMSW& = 0
Do While ((IMSW& = 0) And (JHI& > 1))
IMSW& = IMAGEBOX&(II&, JHI&)
If (IMSW& = 0) Then JHI& = JHI& - 1
Loop
For JJ& = JLO& To JHI&
IMAGEBOX&(II&, JJ&) = 1
Next JJ&
Next II&
WORKAREA& = 0
For II& = 0 To 256
HIST&(II&) = 0
Next II&
AJN! = 0: AJS! = 0: AJQ! = 0
For II& = 1 To YLENG&
IML$ = IMAGELIN$(II&)
For JJ& = 1 To XLENG&
If (IMAGEBOX&(II&, JJ&) > 0) Then
WORKAREA& = WORKAREA& + 1
ASJ& = Asc(Mid$(IML$, JJ&, 1))
HIST&(ASJ&) = 1 + HIST&(ASJ&)
AJN! = AJN! + 1: AJS! = AJS! + ASJ&
AJQ! = AJQ! + (ASJ& * ASJ&)
End If
Next JJ&
Next II&
SELFERRORSW% = 0
End Sub
Sub WORKSPACEPCT ()
'CREATE HISTOGRAM WITHIN THE USER WORKSPACE
If (HISTOPCT& < 1) Then
MSGX$ = "NO HISTOGRAM PERCENT" + CRLF$ + "HAS BEEN SELECTED"
MsgBox MSGX$: Exit Sub
End If
If (2 < 1) Then
WORKAREA& = 0
For II& = 1 To 256
HIST&(II&) = 0
Next II&
For II& = 1 To YLENG&
IML$ = IMAGELIN$(II&)
For JJ& = 1 To XLENG&
If (IMAGEBOX&(II&, JJ&) > 0) Then
WORKAREA& = WORKAREA& + 1
ASJ& = Asc(Mid$(IML$, JJ&, 1))
HIST&(ASJ&) = 1 + HIST&(ASJ&)
End If
Next JJ&
Next II&
End If
II& = 256: HJN! = 0#: WORKPCT! = (HISTOPCT& * WORKAREA&) * .01
Do While (II& > 1)
II& = II& - 1: HJN! = HJN! + HIST&(II&): THRESHOLDLONGI& = II&
If (HJN! > WORKPCT!) Then II& = -999
Loop
THRESHOLDVALUE! = THRESHOLDLONGI&
SELFERRORSW% = 0
End Sub
Last Updated: January 23, 2003, by G. William Moore, MD, PhD.