Realizar Area Map Shape by Ciberwalter
al Igual que lo hace DreamWeaver

12/Octubre/2003 (publicado 07/Dic/2003)
Autor: Walter Mart�nez O. (Ciberwalter)
[email protected]
http://www.geocities.com/gnivel4

Como el Guille no public� los ZIP's porque faltaba el c�digo explicativo (que por cierto al publicar esa "nota del guille" me dej� muy mal parado)
aqu� por fin los termin� y los incluyo en esta p�gina.
Bueno, Como podr�n imaginarse este ejemplo se trata de realizar una Area en una Imagen para una p�gina Web, en realidad este ejemplo no sirve de mucho, pero realizando una modificaci�n al c�digo podemos transformarlo en un editor de Formularios. Pero, Bueno, Al Fin y al cabo debemos ver este ejemplillo primero.
Bueno, resumiendo todo, tu imagen se ver� As�, ... Pulsa sobre la Cabeza Grande!!!

En este caso la p�gina vinculada es la m�a


 

 

Dim Raya As String
Dim SePuede As String

Dim i, ter

' Esto Limpia la Imagen del Form 

Private Sub DelImg_Click()
    Form1.Picture = Image1.Picture
End Sub


' Al Hacer DobleClick en el formulario el Area se Cierra haciendo una l�nea desde�
' el �ltimo punto hasta el primero cerrando as� el pol�gono

Private Sub Form_DblClick()
    If SePuede = "True" Then
        List1.AddItem(Text4)
        List1.AddItem(Text3)

        List1.AddItem(List1.List(0))
        List1.AddItem(List1.List(1))

        ' Aqu� Traza la l�nea desde el final hasta el principio
	Line (List1.List(0), List1.List(1))-(Text4, Text3)

        ' Establece el TextBox "Raya" con la palabra Nada para que no se hagan m�s l�neas sobre el Form  
        Raya = "Nada"

        ' Habilita el Bot�n para Generar el C�digo 
        Generar.Enabled = True

    End If
End Sub

Private Sub Form_Load()
    Raya = "True"
    i = -1
    ' Aqu� carga la imagen�
    Form1.Picture = LoadPicture(App.Path & "\Imagen.jpg")
    Text7 = App.Path & "\Imagen.jpg"
End Sub

Private Sub Form_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Raya = "Nada" Then
        MsgBox("Para realizar otra selecci�n, debes seleccionar ''Nueva Area''", 0, "No se Puede")
    End If

    ' Al Pulsar el Mouse agrega al List1 las coordenadas y agrega una l�nea 
    If Raya = "False" Then
        Text3 = Y
        Text4 = X
	Line (Text2, Text1)-(Text4, Text3)
        List1.AddItem(Text2)
        List1.AddItem(Text1)

        Text1 = Text3
        Text2 = Text4
        SePuede = "True"
    End If

    If Raya = "True" Then
        Text1 = Y
        Text2 = X
        Raya = "False"
    End If

End Sub

Private Sub Form_Unload(ByVal Cancel As Integer)
    End
End Sub

Private Sub Generar_Click()
    ' Al pulsar el bot�n "Generar" comienza a crear las coordenadas y el c�digo completo 
    Timer2.Enabled = True
    SePuede = "False"
    Form2.Visible = True

End Sub

Private Sub mClose_Click()
    End
End Sub

Private Sub mHelp_Click()
    ' Por si nadie lo recuerda este ejemplo fue hecho por Ciberwalter
    MsgBox("Map Polygon fue Escrito Por Ciberwalter, Para cualquier felicitaci�n, alago o cualquier gesto de aprecio escriban a mi mail [email protected], o visiten my website www.geocities.com/gnivel4", 0, "Acerca de Ciberwalter")
End Sub

' Para Mostrar el C�digo en caso de que lo hayas ocultado 
Private Sub Mostrar_Click()
    Frame1.Visible = True
    Ocultar.Enabled = True
    Mostrar.Enabled = False
End Sub

' si la imagen es muy grande y no puedes realizar el Area correctamente ocultas el Cuadro  
Private Sub Ocultar_Click()
    Frame1.Visible = False
    Ocultar.Enabled = False
    Mostrar.Enabled = True
End Sub
' Para Realizar Otra Area 
Private Sub Otra_Click()
    Refresh()

    Timer2.Enabled = False
    Text.Text = ""
    Text1.Text = ""
    Text2.Text = ""
    Text3.Text = ""
    Text4.Text = ""
    Text5.Text = ""
    Text6.Text = ""
    Area.Text = ""
    coord.Text = ""
    List1.Clear()

    Generar.Enabled = False

    Raya = "True"
    i = -1
    SePuede = "True"

End Sub

Private Sub Timer1_Timer()
    Text5 = List1.ListCount
End Sub
' Este Timer es el encargado de juntar todas las coordenadas y organizarlas para la p�gina web  
Private Sub Timer2_Timer()

    Do While i < List1.ListCount
        i = i + 1
        ter = List1.List(i)
        Text = Text & "," & ter
    Loop

    If Text = "" Then
    Else
        Dim coma1, coma2
        ' Perd�n pero se me pasaron algunas comas as� que aqu� las quitamos, soy humano OK!!! 
        coma1 = InStr(Text, ",")
        coma2 = InStrRev(Text, ",")

        coord = Mid$(Text, coma1 + 1, coma2 - 2)

        Area = "<AREA SHAPE=" & Chr(34) & "polygon" & Chr(34) & " COORDS=" & Chr(34) & coord & Chr(34) & " HREF=" & Chr(34) & HReferencia & Chr(34) & " FRAME=" & Chr(34) & TargetFrame & Chr(34) & ">"
        Form2.Resultado = "<!-- Gracias a Area Shape Polygon Por Ciberwalter -->" & Chr(13) + Chr(10) & "<MAP NAME=" & Chr(34) & NameMap & Chr(34) & ">" & Chr(13) + Chr(10) & Area & Chr(13) + Chr(10) & "<IMG SRC=" & Chr(34) & NameImagen & Chr(34) & " USEMAP=" & Chr(34) & "#" & NameMap & Chr(34) & " BORDER=" & Chr(34) & "0" & Chr(34) & ">" & Chr(13) + Chr(10) & "</MAP>"

    End If

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' MENU ABRIR GUARDAR '''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
' En Realidad explicar todo esto es muy aburrido as� que lo dejamos para la pr�ximas
' todo lo que debemos saber es que es el menu para abrir y guardar un archivo� 
Private Sub mnuFileExitApp_Click()

    On Error GoTo mnuFileExitApp_Click_Error
    Unload(Me)
    End

mnuFileExitApp_Click_Exit:
    Exit Sub

mnuFileExitApp_Click_Error:
MsgBox "Error: " & Format$(Err) & " " & Error$, , "mnuFileExitApp_Click"
    Resume mnuFileExitApp_Click_Exit

End Sub


Private Sub mOpen_Click()

    Dim file As OPENFILENAME, sFile As String, sFileTitle As String, lResult As Long, iDelim As Integer

    On Error GoTo mnuFileOpenDialog_Click_Error
    file.lStructSize = Len(file)
    file.hwndOwner = Me.hwnd
    file.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_FILEMUSTEXIST

    file.lpstrFile = "Archivos de Imagen" & String$(250, 0)
    file.nMaxFile = 255

    file.lpstrFileTitle = String$(255, 0)
    file.nMaxFileTitle = 255

    file.lpstrInitialDir = Environ$("WinDir")

    file.lpstrFilter = "Solo Archivos de imagen" & Chr$(0) & "*.jpg;*.gif;*.bmp;*.dib;*.wmf;*.emf;*.ico;*.cur" & Chr$(0) & "Todos los Archivos" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
    file.nFilterIndex = 1

    file.lpstrTitle = "Abrir Imagen"

    lResult = GetOpenFileName(file)
    If lResult <> 0 Then
        iDelim = InStr(file.lpstrFileTitle, Chr$(0))
        If iDelim > 0 Then
            sFileTitle = Left$(file.lpstrFileTitle, iDelim - 1)
        End If
        iDelim = InStr(file.lpstrFile, Chr$(0))
        If iDelim > 0 Then
            sFile = Left$(file.lpstrFile, iDelim - 1)
        End If

        Text7 = sFile
        Form1.Picture = LoadPicture(sFile)
        NameImagen = sFileTitle

    End If

mnuFileOpenDialog_Click_Exit:
    Exit Sub

mnuFileOpenDialog_Click_Error:
    MsgBox "Error: " & Format$(Err) & " " & Error$, , "mnuFileOpenDialog_Click"
    Resume mnuFileOpenDialog_Click_Exit

End Sub

Bueno como ya termin� el Form1, �ste es el C�digo del Form2 que se Hace Visible cuando se genera el c�digo web.

 

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long


Public Function existeFichero(ByVal Ruta As String) As Boolean
    On Error GoTo ErrorHandler
    X = GetAttr(Ruta)
    existeFichero = True
    Exit Function
ErrorHandler:
    existeFichero = False
End Function


Private Sub PrevisualizarPagina_Click()
    Dim Error As Integer
    Error = ShellExecute(Me.hwnd, "Open", Text3, "", "", 3)
End Sub

Private Sub Form_Activate()
    Text1 = Form1.NameImagen
End Sub


Private Sub Saver_Click()

    On Error GoTo mnuFileSaveAsDialog_Click_Error
    Dim file As OPENFILENAME, sFile As String, sFileTitle As String, lResult As Long, iDelim As Integer

    file.lStructSize = Len(file)
    file.hwndOwner = Me.hwnd
    file.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_OVERWRITEPROMPT

    file.lpstrFile = String$(255, 0)
    file.nMaxFile = 255

    file.lpstrFileTitle = String$(255, 0)
    file.nMaxFileTitle = 255

    file.lpstrInitialDir = App.Path

    file.lpstrFilter = "Pagina Web Html" & Chr$(0) & "*.htm" & Chr$(0) & Chr$(0)
    file.nFilterIndex = 1

    file.lpstrTitle = "Guardar Como..."

    file.lpstrDefExt = "Htm"

    lResult = GetSaveFileName(file)
    If lResult <> 0 Then

        iDelim = InStr(file.lpstrFileTitle, Chr$(0))
        If iDelim > 0 Then
            sFileTitle = Left$(file.lpstrFileTitle, iDelim - 1)
        End If
        iDelim = InStr(file.lpstrFile, Chr$(0))
        If iDelim > 0 Then
            sFile = Left$(file.lpstrFile, iDelim - 1)
        End If

        Text3 = sFile
        PrevisualizarPagina.Enabled = True

        Dim CopiarImagen, parte1
        Dim w As Long

        parte1 = InStrRev(sFile, "\")

        Text2 = Left$(sFile, parte1)


        If existeFichero(Text2 & Text1) = True Then
        Else
            CopiarImagen = MsgBox("La Imagen ''No Existe'' en el directorio donde guard� la pagina web, �desea copiarla?", vbYesNo, "Desea Copiar La imagen")
            If CopiarImagen = vbYes Then FileCopy (Form1.Text7), (Text2 & Text1)
            If CopiarImagen = vbNo Then MsgBox("La Pagina web creada no funcionara correctamente si no copias la imagen al mismo directorio de la pagina.", 0, "Advertencia")
        End If


        w = FreeFile
        Open sFile For Output As w
        Print #w, Resultado.Text
        Close(w)

    End If

mnuFileSaveAsDialog_Click_Exit:
    Exit Sub

mnuFileSaveAsDialog_Click_Error:
    MsgBox "Error: " & Format$(Err) & " " & Error$, , "mnuFileSaveAsDialog_Click"
    Resume mnuFileSaveAsDialog_Click_Exit

End Sub

Descargar el C�digo y el ejecutable ->  ciberwalter_Area_Shape_Map.zip 99 KB