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)
waltermilenium@hotmail.com
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 waltermilenium@hotmail.com, 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


ir al índice