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