imagemap.bas

加入一个用VB编写CGI的VB源程序。（你需要在Win98上首先安装20Personal WebServer

Attribute VB_Name = "imagemap"
Option Explicit
'-----------------------------------------------------------
' Imagemap: server-side imagemap program for CGI scripts
' Author: Kevin O'Brien [[e-mail]]
'                       [[e-mail]]
' Version: 1.5
' Requires: CGI4VB.BAS, CGI4RTN.BAS, WORDS.BAS
'
' Uses NCSA-format map files:
' <shape> <URL> <x1,y1 x2,y2 ... xn,yn>
'
'  rect    URL       topLeft(X,Y)  bottomRight(X,Y)
'  poly    URL       vertex1(X,Y)  vertex2(X,Y) ... vertexn(X,Y)
'  circle  URL       center(X,Y)   pointOnPerimeter(X,Y)
'  ellipse URL       center(X,Y)   radiusX,radiusY
'  default URL
'-----------------------------------------------------------
Type POINTAPI
   x As Long
   y As Long
End Type

Public pts() As POINTAPI

Sub CGI_Main()
Dim sMapFile As String      'full path of the map file
Dim sMapLine As String      'individual line in the map file
Dim sShape   As String      'type of shape defined by line
Dim sUrl     As String      'url pointed to by line
Dim sDefUrl  As String      'default url provided by map file
Dim sPoints  As String      'x,y points in line
Dim iPoints  As Integer     'number of x and y values in line
Dim iDim     As Integer     'dimension of pts() array
Dim x        As Long        'x point clicked by user
Dim y        As Long        'y point clicked by user
Dim k        As Long        'for next counter

'get x,y coordinates of point clicked by user

x = Val(ParseItem(CGI_QueryString, ",", 1))
y = Val(ParseItem(CGI_QueryString, ",", 2))

'------------------------------------------------------------------
'Assign map directory/filename.
'Map file name comes from the URL as Path_Translated or Path_Info.
'ex: <a href=cgi-bin/imagemap.exe/maps/mapfile.map>
'CGI_PathTranslated will append "maps\mapfile.map" to the server's
'document root directory, for example:
'   c:\httpd\htdocs\maps\mapfile.map
'
'Not all servers will return Path_Translated to the CGI script.
'If not available, you can build the full
'path name yourself, for example:
'sMapFile = "c:\httpd\htdocs\maps" _
'          & Translate(CGI_PathInfo, "/", "\")
'------------------------------------------------------------------
sMapFile = CGI_PathTranslated

'Read the map file
'Loop through the lines until a match is found
'between point clicked and defined shape.

Open sMapFile For Input Access Read As #1

Do Until EOF(1)
   Line Input #1, sMapLine
   sShape = Word(sMapLine, 1)                '1st word is shape type
   sUrl = Word(sMapLine, 2)                  '2nd word is URL
   sPoints = MidWord(sMapLine, 3)            'remainder are x,y points
   sPoints = Translate(sPoints, ",", " ")    'remove commas
   iPoints = Words(sPoints)
  
   'Raise error if no coordinates are provided,
   'or if total of coordinates is invalid for a particular shape.
   
   Select Case sShape
      Case "poly"
         If (iPoints Mod 2 <> 0) _
         Or (iPoints = 0) _
         Or (iPoints < 6) Then raiseError sMapLine
      Case "rect", "ellipse", "circle"
         If iPoints <> 4 Then raiseError sMapLine
   End Select
   
  'Raise error if any coordinate is not numeric
    
   If sShape = "rect" Or sShape = "circle" _
   Or sShape = "poly" Or sShape = "ellipse" Then
      For k = 1 To iPoints
         If Not IsNumeric(Word(sPoints, k)) Then raiseError sMapLine
      Next k
   End If
   
   'fill array with coordinates if this line is defining a shape
  
   If sShape = "rect" Or sShape = "circle" _
   Or sShape = "poly" Or sShape = "ellipse" Then
      iDim = (iPoints \ 2 - 1)                     'x,y pairs minus 1
      ReDim pts(iDim) As POINTAPI                  'redim pts() array
      For k = 0 To iDim                            'read points into array
         pts(k).x = Val(Word(sPoints, k * 2 + 1)) 'assign x value
         pts(k).y = Val(Word(sPoints, k * 2 + 2)) 'assign y value
      Next k
   End If
   
   'test whether point clicked is inside a defined shape
   
   Select Case sShape
      Case "poly"
         If Polygon(x, y) Then GoTo redirect
      Case "circle"
         If Circlen(x, y) Then GoTo redirect
      Case "ellipse"
         If Ellipse(x, y) Then GoTo redirect
      Case "rect"
         If Rectangle(x, y) Then GoTo redirect
      Case "default"
         sDefUrl = sUrl
   End Select
Loop

If sDefUrl > "" Then                     'use default url
   sUrl = sDefUrl
   GoTo redirect
Else                                     'no default was provided
   Send "Status: 204 No Content"
   GoTo closeMap
End If

redirect:
   Send "Status: 302 redirection"
   Send "Location: " & sUrl & vbCrLf

closeMap:
   Close #1
End Sub

Function Polygon(x As Long, y As Long) As Boolean
'---------------------------------------------------------------
'Polygon returns True if point x,y is within the polygon
'described by the points contained in array pts()
'---------------------------------------------------------------
Dim x1         As Long    'x current point
Dim y1         As Long    'y current point
Dim x2         As Long    'x adjacent point
Dim y2         As Long    'y adjacent point
Dim n          As Integer 'dimension of pts()
Dim c          As Integer 'index for current point pts()
Dim a          As Integer 'index for adjacent point pts()

n = UBound(pts)

For c = 0 To n
   a = c - 1
   If a < 0 Then a = n
   
   x1 = pts(c).x
   y1 = pts(c).y
   x2 = pts(a).x
   y2 = pts(a).y

   On Error Resume Next 'prevent divide by zero
   If (((y > y1 And y < y2) Or (y > y2 And y < y1)) _
   And (x < (x2 - x1) * (y - y1) / (y2 - y1) + x1)) Then
       If Err.Number = 0 Then Polygon = Not Polygon
   End If
   Err.Clear
Next c
End Function


Public Function Circlen(x As Long, y As Long) As Boolean
'---------------------------------------------------------------
'Circlen returns True if point x,y is within the circle
'described by the points cx,cy (center) and px,py (perimeter)
'NCSA format
'---------------------------------------------------------------
Dim cx As Long 'x center point
Dim cy As Long 'y center point
Dim px As Long 'x perimeter point
Dim py As Long 'y perimeter point

'Adjust so that the center of the circle(cx,cy) = 0,0
'If (X