Hi,
kleines B+ Proggie das beim erstellen von area Tags für HTML hilft. Einfach Bild laden, Punkte setzten und den Tag aus dem Editfeld kopieren.
Mfg Xenon
BlitzBasic: [AUSKLAPPEN] [EINKLAPPEN] Global gw = ClientWidth(Desktop())
Global gh = ClientHeight(Desktop())
Const ww = 800
Const wh = 600
Const mn = 0
Global gf$ = Chr$(34)
Const m_clear = 3
Const m_open = 4
Const m_close = 5
Global hwnd = CreateWindow("Area Tag Generator", (gw-ww)/2, (gh-wh)/2, ww, wh, 0, 5)
cw = ClientWidth(hwnd)
ch = ClientHeight(hwnd)
Global edResult = CreateTextField(0, 0, cw, 20, hwnd)
Global canvas = CreateCanvas(0, 20, cw-16, ch-36, hwnd)
Global vslider = CreateSlider(cw-16, 20, 16, ch-36, hwnd, 2)
Global hslider = CreateSlider(0, ch-16, cw-16, 16, hwnd, 1)
SetScroll
Global img = 0
Global pointanz = 0
Dim temp(0, 1)
Dim points(0, 1)
SetBuffer CanvasBuffer(canvas)
menu = WindowMenu(hwnd)
filemenu = CreateMenu("&Datei", mn, menu)
CreateMenu("&Punkte löschen Entf", m_clear, filemenu)
CreateMenu("Bild &laden Strg+O", m_open, filemenu)
CreateMenu("&Beenden Alt+F4", m_close, filemenu)
UpdateWindowMenu hwnd
HotKeyEvent 24, 2, $1001, m_open, 0, 0, 0, 0
HotKeyEvent 211, 0, $1001, m_clear, 0, 0, 0, 0
Repeat
Select WaitEvent()
Case $201
If EventSource() = canvas Then
Select EventData()
Case 1
MouseLKlick(MouseX(canvas), MouseY(canvas))
End Select
End If
Case $401
Select EventSource()
Case hslider
DrawImg
Case vslider
DrawImg
End Select
Case $803
Quit
Case $1001
Select EventData()
Case m_clear
DeletePoints
Case m_open
Open
Case m_close
Quit
End Select
End Select
Forever
Function Quit()
End
End Function
Function Open()
imagefile$ = RequestFile$("Bild laden", "jpg,jpeg,bmp,png,tga", 0)
img = LoadImage(imagefile$)
If (img = 0) And (imagefile$ <> "") Then
Notify "Kein unterstütztes Dateiformat!"
End If
pointanz = 0
Dim temp(0, 1)
Dim points(0, 1)
DrawImg
SetScroll
End Function
Function SetScroll()
iw = 0
ih = 0
If img <> 0 Then
iw = ImageWidth(img)
ih = ImageHeight(img)
End If
gw = GadgetWidth(canvas)
gh = GadgetHeight(canvas)
SetSliderRange(hslider, gw, iw)
SetSliderRange(vslider, gh, ih)
End Function
Function DrawImg()
Cls
sh = SliderValue(hslider)
sv = SliderValue(vslider)
If img <> 0 Then
DrawBlock img, -sh, -sv
End If
Color 255, 0, 0
For i=0 To pointanz-2
Line points(i, 0)-sh, points(i, 1)-sv, points(i+1, 0)-sh, points(i+1, 1)-sv
Oval points(i, 0)-3-sh, points(i, 1)-3-sv, 7, 7, 0
Next
If pointanz > 0 Then
Oval points(pointanz-1, 0)-3-sh, points(pointanz-1, 1)-3-sv, 7, 7, 0
Line points(0, 0)-sh, points(0, 1)-sv, points(pointanz-1, 0)-sh, points(pointanz-1, 1)-sv
End If
FlipCanvas canvas
ShowAreaTag
End Function
Function MouseLKlick(x, y)
x = x+SliderValue(hslider)
y = y+SliderValue(vslider)
If img <> 0 Then
iw = ImageWidth(img)
ih = ImageHeight(img)
If (x<iw) And (y<ih) Then
AddPoint(x, y)
End If
DrawImg()
End If
End Function
Function AddPoint(x, y)
found = False
For i=0 To pointanz-1
If (points(i, 0) = x) And (points(i, 1) = y) Then found = True
Next
If Not found Then
Dim temp(pointanz-1, 1)
For i=0 To pointanz-1
temp(i, 0) = points(i, 0)
temp(i, 1) = points(i, 1)
Next
Dim points(pointanz, 1)
For i=0 To pointanz-1
points(i, 0) = temp(i, 0)
points(i, 1) = temp(i, 1)
Next
points(pointanz, 0) = x
points(pointanz, 1) = y
pointanz = pointanz+1
End If
End Function
Function DeletePoints()
pointanz = 0
DrawImg
End Function
Function ShowAreaTag()
If pointanz > 0 Then
s$ = "<area alt="+gf+"AlternativText"+gf+" href="+gf+"Link"+gf+" shape="+gf+"poly"+gf+" coords="+gf
For i=0 To pointanz-1
s$ = s$+points(i, 0)+","+points(i,1)
If i<>pointanz-1 Then s$ = s$+","
Next
s$ = s$+gf+">"
Else
s$ = ""
End If
SetGadgetText edResult, s$
End Function
|
BlitzBasic 
Do, Jul 01, 2004 0:52
