Formularios Con Forma by Ciberwalter

13/Octubre/2003 (publicado 07/Dic/2003)
Autor: Walter Martínez O. (Ciberwalter)
waltermilenium@hotmail.com
http://www.geocities.com/gnivel4


Después de todo el Guille tenía razón y se me olvidó colocar el código del Formulario Con Forma o más bien llamado, "Form as de Form" ustedes se preguntarán por que le puse ese nombre, la verdad es que yo también me lo pregunto, le iba a poner un nombre en japonés pero sería más enredado aún.
  
Con este ejemplo podrás realizar unos Formularios con Forma Bastante Entretenidos, La Utilización de este Programa es la Siguiente: Ojo con esto,... Primero Abre el programa...   ... Luego Carga Una Imagen desde el Menú Herramientas > Abrir Imagen ... y Luego hechale un vistazo a este tutorial hecho en flash, que explica de forma sencilla como funciona el programa, dicen que una imagen vale más que mil palabras pero en este caso, una animación hecha en flash vale más que una explicación.


Ver Tutorial hecho en flash -> 
Nota del Guille: La página y el fichero Flash está en un zip: ciberwalter_tutorial.zip 106 KB
 


Tus Formularios se verían así (Ejemplo):


 

Option Explicit On 

' Esta Opcion abre el VisualBasic6.0 para ver tu formulario
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


Dim Raya As String
Dim SePuede As String
Dim colores

Dim i, ter

Private Sub Command1_Click()
    ArribaForm.SelStart = 0
    ArribaForm.SelLength = Len(ArribaForm)
    Clipboard.SetText(ArribaForm.SelText)
End Sub
' El funcionamiento de este ejemplo es muy similar que el Area Map by Ciberwalter
Private Sub Command2_Click()

    FormerFRM = Variab & Chr(13) + Chr(10) & ArribaForm & Chr(13) + Chr(10) & "' Estas Líneas de Abajo son innecesarias y puedes borrarlas, sólo es la imagen de fondo que se carga" & Chr(13) + Chr(10) & "Private Sub Form_Activate()" & Chr(13) + Chr(10) & "Form1.Picture = LoadPicture(App.Path & " & Chr(34) & "\Imagen.jpg" & Chr(34) & ")" & Chr(13) + Chr(10) & "End Sub"

    Dim Fram, Fram2
    Dim f As Long
    f = FreeFile()

    Fram = App.Path & "\Tu Forma.frm"
    Fram2 = App.Path & "\Tu Forma.vbp"

    ' Estas líneas escriben el Form de VisualBasic
Open Fram For Output As f
Print #f, FormerFRM.Text
    Close(f)

Open Fram2 For Output As f
Print #f, Text8.Text
    Close(f)

    Dim AbrirFRM As Integer
    AbrirFRM = ShellExecute(Me.hwnd, "Run Project", Fram2, "", "", 3)
End Sub


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

Private Sub Form_DblClick()
    Form2.Visible = False

    Dim Punto1, Punto2, Total1, Punto12, Punto22, Total12, Result1, Result2
    Dim Ultimo, Penultimo
    Dim Ultimo2, Penultimo2
    Dim Ultimo3, Penultimo3
    Dim Ultimo4, Penultimo4

    If SePuede = "True" Then
        List1.AddItem("lpPoint(" & Cuenta + 1 & ").X =" & Text4 & " + positx")
        List1.AddItem("lpPoint(" & Cuenta + 1 & ").Y =" & Text3 & " + posity")

        Penultimo = InStr(List1.List(0), "(")
        Ultimo = InStr(List1.List(1), "(")

        Penultimo3 = Left$(List1.List(0), Penultimo)
        Ultimo3 = Left$(List1.List(1), Ultimo)

        Penultimo2 = InStr(List1.List(0), ".")
        Ultimo2 = InStr(List1.List(1), ".")

        Penultimo4 = Mid$(List1.List(0), Penultimo + 2)
        Ultimo4 = Mid$(List1.List(1), Ultimo + 2)

        List1.AddItem(Penultimo3 & Cuenta + 2 & Penultimo4)
        List1.AddItem(Ultimo3 & Cuenta + 2 & Ultimo4)

        Punto1 = InStr(List1.List(0), "=")
        Total1 = Mid$(List1.List(0), Punto1 + 1)

        Punto2 = InStr(Total1, "+")
        Result1 = Left$(Total1, Punto2 - 1)

        Punto12 = InStr(List1.List(1), "=")
        Total12 = Mid$(List1.List(1), Punto12 + 1)

        Punto22 = InStr(Total12, "+")
        Result2 = Left$(Total12, Punto22 - 1)

Line (Result1, Result2)-(Text4, Text3), QBColor(colores)

        Raya = "Nada"

        Generar.Enabled = True

    End If
End Sub

Private Sub Form_Load()
    colores = 0
    Raya = "True"
    i = -1
    Form1.Picture = LoadPicture(App.Path & "\Imagen.jpg")
    Text7 = App.Path & "\Imagen.jpg"
    Form2.Visible = True
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
        Dim DeseasB
        DeseasB = MsgBox("Ya Existe una Selección Para Realizar otra y borrar esta presiona ''Nueva Area''", vbOKOnly, "No se Puede")
    End If

    If Raya = "False" Then
        Cuenta = Cuenta + 1

        Text3 = Y
        Text4 = X
	Line (Text2, Text1)-(Text4, Text3), QBColor(colores)
        List1.AddItem("lpPoint(" & Cuenta & ").X =" & Text2 & " + positx")
        List1.AddItem("lpPoint(" & Cuenta & ").Y =" & Text1 & " + posity")

        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()
    Command2.Enabled = True
    Command1.Enabled = True

    Timer2.Enabled = True
    SePuede = "False"

End Sub
' Esto Varía el color de la línea trazada
Private Sub mAmarillo_Click()
    colores = 14
End Sub

Private Sub mBlanco_Click()
    colores = 15
End Sub

Private Sub mClose_Click()
    End
End Sub

Private Sub mHelp_Click()
    MsgBox("Formularios Personalizados 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 esta es una modificación de Area Map Shape HTM Hecho por Mí (Ciberwalter)jo, jo, jo,", 0, "Acerca de Ciberwalter")
End Sub

Private Sub mNegro_Click()
    colores = 0
End Sub

Private Sub Mostrar_Click()
    Frame1.Visible = True
    Ocultar.Enabled = True
    Mostrar.Enabled = False
End Sub

Private Sub mRojo_Click()
    colores = 12
End Sub

Private Sub Ocultar_Click()
    Frame1.Visible = False
    Ocultar.Enabled = False
    Mostrar.Enabled = True
End Sub

Private Sub Otra_Click()

    Command2.Enabled = False
    Command1.Enabled = False

    Refresh()

    Form2.Visible = True

    ArribaForm = ""
    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

    Cuenta = -1
    i = -1
    SePuede = "True"
    Raya = "True"
End Sub

Private Sub Timer1_Timer()
    Text5 = List1.ListCount

    If Form1.WindowState = 2 Then
        Frame1.Left = 535
        Frame1.Height = 533
        ArribaForm.Height = 7065
    Else
        Frame1.Left = 272
        Frame1.Height = 345
        ArribaForm.Height = 4225
    End If

End Sub

Private Sub Timer2_Timer()

    Do While i < List1.ListCount
        i = i + 1
        ter = List1.List(i)
        Text = Text & Chr(13) + Chr(10) & ter
    Loop

    If Text = "" Then
    Else
        Dim coma1, coma2

        coord = List1.ListCount / 2

        ' Esta variación permite que las coordenadas obtenidas en el List se distribuyan en forma de Puntos 
        ' Y estos puntos específicos realizan el polígono en el formulario

        Area = "Private Sub DoSetPolygonPoints()" & Chr(13) + Chr(10) & Text & Chr(13) + Chr(10) & "End Sub"

        ' Esta Maraña de Letras Raras es el código que crea al pulsar el Botón Generar Código
        ' Saben Porque no lo puse más fácil añadiéndolo a un textbox, muy sencillo, porque no se me ocurrió 
        ' y porque de esta forma es más difícil de entender (Que malo soy, ji, ji, ji)
        ' Colorearla, ni pensarlo!!!

        ArribaForm = "Private Declare Function ScreenToClient Lib " & Chr(34) & "user32" & Chr(34) & " (ByVal hWnd As Long, lpPoint As POINTAPI) As Long" & Chr(13) + Chr(10) & "Private Declare Function SetWindowRgn Lib " & Chr(34) & "user32" & Chr(34) & " (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long" & Chr(13) + Chr(10) & "Private Declare Function CreatePolygonRgn Lib " & Chr(34) & "gdi32" & Chr(34) & " (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long" & Chr(13) + Chr(10) & Chr(13) + Chr(10) & "Private Type POINTAPI " & Chr(13) + Chr(10) & " X As Long " & Chr(13) + Chr(10) & " Y As Long " & Chr(13) + Chr(10) & " End Type" & Chr(13) + Chr(10) & Chr(13) _
        + Chr(10) & "Private Const posity = 22" & Chr(13) + Chr(10) & "Private Const positx = 4" & Chr(13) + Chr(10) & Chr(13) + Chr(10) & "Dim DifferenceX As Single" & Chr(13) + Chr(10) & "Dim DifferenceY As Single" & Chr(13) + Chr(10) & Chr(13) + Chr(10) & "Const MaxPolygonPoints = " & coord & Chr(13) + Chr(10) & Chr(13) + Chr(10) & "Dim lpPoint(MaxPolygonPoints) As POINTAPI" & Chr(13) + Chr(10) & Chr(13) + Chr(10) & "Private Sub Form_Load()" & Chr(13) + Chr(10) & " DoSetPolygonPoints" & Chr(13) + Chr(10) & " SetWindowRgn hWnd, CreatePolygonRgn(lpPoint(0), MaxPolygonPoints, 0), True" & Chr(13) + Chr(10) & "End Sub" & Chr(13) + Chr(10) & Chr(13) + Chr(10) & Area & Chr(13) + Chr(10) & Chr(13) + Chr(10) & _
        "Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)" & Chr(13) + Chr(10) & " If Button = 1 Then" & Chr(13) + Chr(10) & " If Timer1.Interval > 0 Then" & Chr(13) + Chr(10) & " DifferenceX = X" & Chr(13) + Chr(10) & " DifferenceY = Y" & Chr(13) + Chr(10) & " Timer1.Interval = 0" & Chr(13) + Chr(10) & " End If" & Chr(13) + Chr(10) & " ElseIf Button = 2 Then" & Chr(13) + Chr(10) & " Form1.PopupMenu MenuM" & Chr(13) + Chr(10) & " End If" & Chr(13) + Chr(10) & "End Sub" & Chr(13) + Chr(10) & Chr(13) + Chr(10) & "Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)" & _
        Chr(13) + Chr(10) & " If Button = 1 Then" & Chr(13) + Chr(10) & " If Timer1.Interval = 0 Then" & Chr(13) + Chr(10) & " Form1.Left = Form1.Left + (X - DifferenceX)" & Chr(13) + Chr(10) & " Form1.Top = Form1.Top + (Y - DifferenceY)" & Chr(13) + Chr(10) & " DoEvents" & Chr(13) + Chr(10) & " End If" & Chr(13) + Chr(10) & " End If" & Chr(13) + Chr(10) & "End Sub" & Chr(13) + Chr(10) & _
        "Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)" & Chr(13) + Chr(10) & " If Timer1.Interval = 0 Then" & Chr(13) + Chr(10) & " Timer1.Interval = 2" & Chr(13) + Chr(10) & " End If" & Chr(13) + Chr(10) & "End Sub" & Chr(13) + Chr(10) & "Private Sub mCerrar_Click()" & Chr(13) + Chr(10) & "End" & Chr(13) + Chr(10) & "End Sub"

    End If

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''' MENU ABRIR GUARDAR '''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''

No lo pondré porque no es tan necesario y además esta en el otro código
 


Descargar el Código-> Formularios con Forma ciberwalter_FormAsDeForm.zip 106 KB


ir al índice