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