Formularios Con Forma by Ciberwalter

13/Octubre/2003 (publicado 07/Dic/2003)
Autor: Walter Mart�nez O. (Ciberwalter)
[email protected]
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 [email protected], 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