SanLeviaThan
14-10-2006, 19:32
Muy Buenas, estube realizando este programita, pedido por VERTIGO-MDQ en el post http://www.hackhispano.com/foro/showthread.php?t=20791 la cual pide como crear enlaces a ciertas web's pues aqui dejo el codigo fuente y el programita para que lo disfruten.-
-------------------------------------------------------------------------
En un Formulario poner:
Option Explicit
Dim fichero1 As String
Dim fichero2 As String
Dim flag As Boolean
Dim flag2 As Boolean
Dim flag3 As Boolean
Dim flag4 As Boolean
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
'Para el modo de ventana en el ShellExecute
Private Const SW_SHOWNORMAL = 1
Private Sub Command1_Click()
ShowWindow Me.hwnd, 6
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Command3_Click()
If Command3.Caption = "> OPCIONES >" Then
Command3.Caption = "< OPCIONES <"
Form1.Width = 6500
Shape1.Width = 6495
Else
Command3.Caption = "> OPCIONES >"
Form1.Width = 3360
Shape1.Width = 3360
End If
End Sub
Private Sub Command6_Click()
CommonDialog1.Filter = "Programas (*.exe)|*.exe"
CommonDialog1.ShowOpen
fichero1 = CommonDialog1.FileName
Text4.Text = CommonDialog1.FileTitle
End Sub
Private Sub Command7_Click()
CommonDialog1.Filter = "Programas (*.exe)|*.exe"
CommonDialog1.ShowOpen
fichero2 = CommonDialog1.FileName
Text3.Text = CommonDialog1.FileTitle
End Sub
Private Sub Command8_Click()
If Text1.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
ElseIf Text5.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
ElseIf Text4.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
ElseIf Text2.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
ElseIf Text3.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
ElseIf Text6.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
End If
Command3.Caption = "> OPCIONES >"
Form1.Width = 3360
Shape1.Width = 3360
With Label2
.Caption = Text1.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label4
.Caption = Text5.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label5
.Caption = Text2.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label6
.Caption = Text6.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
ex:
End Sub
Private Sub Form_Load()
Form1.Width = 3360
Shape1.Width = 3360
With Label2
.Caption = Text1.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label4
.Caption = Text5.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label5
.Caption = Text4.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label6
.Caption = Text3.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
End Sub
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim ReturnValue As Long
If Button = 1 Then
Call ReleaseCapture
ReturnValue = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub
Private Sub Label2_Click()
If Label2.Caption = "link 1 - Paginas web" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
ShellExecute Me.hwnd, vbNullString, Label2.Caption, vbNullString, "C:\", SW_SHOWNORMAL
ex:
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cambiarColor
End Sub
Private Sub Label2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lHandle As Long
lHandle = LoadCursor(0, HandCursor)
If (lHandle > 0) Then SetCursor lHandle
If flag Then
Label2.ForeColor = vbBlue
flag = False
End If
End Sub
Private Sub cambiarColor()
If flag = False Then
Label2.ForeColor = vbRed
flag = True
End If
If flag2 = False Then
Label4.ForeColor = vbRed
flag2 = True
End If
If flag3 = False Then
Label5.ForeColor = vbRed
flag3 = True
End If
If flag4 = False Then
Label6.ForeColor = vbRed
flag4 = True
End If
End Sub
Private Sub Label4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lHandle As Long
lHandle = LoadCursor(0, HandCursor)
If (lHandle > 0) Then SetCursor lHandle
If flag Then
Label4.ForeColor = vbBlue
flag2 = False
End If
End Sub
Private Sub Text1_GotFocus()
With Text1
.SelStart = 0
.SelLength = Len(.Text)
End With
Text1.Text = ""
End Sub
Private Sub Text3_GotFocus()
With Text3
.SelStart = 0
.SelLength = Len(.Text)
End With
Text3.Text = ""
End Sub
Private Sub Text4_GotFocus()
With Text4
.SelStart = 0
.SelLength = Len(.Text)
End With
Text4.Text = ""
End Sub
Private Sub Text5_GotFocus()
With Text5
.SelStart = 0
.SelLength = Len(.Text)
End With
Text5.Text = ""
End Sub
Private Sub Label5_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lHandle As Long
lHandle = LoadCursor(0, HandCursor)
If (lHandle > 0) Then SetCursor lHandle
If flag Then
Label5.ForeColor = vbBlue
flag3 = False
End If
End Sub
Private Sub Label6_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lHandle As Long
lHandle = LoadCursor(0, HandCursor)
If (lHandle > 0) Then SetCursor lHandle
If flag Then
Label6.ForeColor = vbBlue
flag4 = False
End If
End Sub
Private Sub Label4_Click()
If Label4.Caption = "link 2 - Paginas web" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
ShellExecute Me.hwnd, vbNullString, Label4.Caption, vbNullString, "C:\", SW_SHOWNORMAL
ex:
End Sub
Private Sub Label5_Click()
If Label5.Caption = "link 3 - Programas" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
If Label5.Caption = "Nombre Corto" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
Dim res As Long
res = ShellExecute(Me.hwnd, "Open", fichero1, "", "", 1)
ex:
End Sub
Private Sub Label6_Click()
If Label6.Caption = "link 4 - Programas" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
If Label6.Caption = "Nombre Corto" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
Dim res2 As Long
res2 = ShellExecute(Me.hwnd, "Open", fichero2, "", "", 1)
ex:
End Sub
-------------------------------------------------------------------------
En un modulo poner
Public Const HandCursor = 32649&
Public Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Public Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam _
As Long, lParam As Any) As Long
Declare Sub ReleaseCapture Lib "user32" ()
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2
-------------------------------------------------------------------------
Click Aqui (http://rapidshare.de/files/36735301/Links.exe) para descargar el Programita (ya compilado .exe)
Clcik Aqui (http://rapidshare.de/files/36735575/Fuentes.zip) para descargar las Fuentes (Necesitas el VB 6.0)
-------------------------------------------------------------------------
No es Gran cosa pero ...Espero que les Guste ..... ;)
Saludos.-
-------------------------------------------------------------------------
En un Formulario poner:
Option Explicit
Dim fichero1 As String
Dim fichero2 As String
Dim flag As Boolean
Dim flag2 As Boolean
Dim flag3 As Boolean
Dim flag4 As Boolean
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
'Para el modo de ventana en el ShellExecute
Private Const SW_SHOWNORMAL = 1
Private Sub Command1_Click()
ShowWindow Me.hwnd, 6
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Command3_Click()
If Command3.Caption = "> OPCIONES >" Then
Command3.Caption = "< OPCIONES <"
Form1.Width = 6500
Shape1.Width = 6495
Else
Command3.Caption = "> OPCIONES >"
Form1.Width = 3360
Shape1.Width = 3360
End If
End Sub
Private Sub Command6_Click()
CommonDialog1.Filter = "Programas (*.exe)|*.exe"
CommonDialog1.ShowOpen
fichero1 = CommonDialog1.FileName
Text4.Text = CommonDialog1.FileTitle
End Sub
Private Sub Command7_Click()
CommonDialog1.Filter = "Programas (*.exe)|*.exe"
CommonDialog1.ShowOpen
fichero2 = CommonDialog1.FileName
Text3.Text = CommonDialog1.FileTitle
End Sub
Private Sub Command8_Click()
If Text1.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
ElseIf Text5.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
ElseIf Text4.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
ElseIf Text2.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
ElseIf Text3.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
ElseIf Text6.Text = "" Then
MsgBox "ERROR - Complete el Campo", vbCritical, "Error"
GoTo ex
End If
Command3.Caption = "> OPCIONES >"
Form1.Width = 3360
Shape1.Width = 3360
With Label2
.Caption = Text1.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label4
.Caption = Text5.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label5
.Caption = Text2.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label6
.Caption = Text6.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
ex:
End Sub
Private Sub Form_Load()
Form1.Width = 3360
Shape1.Width = 3360
With Label2
.Caption = Text1.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label4
.Caption = Text5.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label5
.Caption = Text4.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
With Label6
.Caption = Text3.Text
.AutoSize = True
.MousePointer = 99
.ForeColor = vbRed
End With
End Sub
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim ReturnValue As Long
If Button = 1 Then
Call ReleaseCapture
ReturnValue = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End If
End Sub
Private Sub Label2_Click()
If Label2.Caption = "link 1 - Paginas web" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
ShellExecute Me.hwnd, vbNullString, Label2.Caption, vbNullString, "C:\", SW_SHOWNORMAL
ex:
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
cambiarColor
End Sub
Private Sub Label2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lHandle As Long
lHandle = LoadCursor(0, HandCursor)
If (lHandle > 0) Then SetCursor lHandle
If flag Then
Label2.ForeColor = vbBlue
flag = False
End If
End Sub
Private Sub cambiarColor()
If flag = False Then
Label2.ForeColor = vbRed
flag = True
End If
If flag2 = False Then
Label4.ForeColor = vbRed
flag2 = True
End If
If flag3 = False Then
Label5.ForeColor = vbRed
flag3 = True
End If
If flag4 = False Then
Label6.ForeColor = vbRed
flag4 = True
End If
End Sub
Private Sub Label4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lHandle As Long
lHandle = LoadCursor(0, HandCursor)
If (lHandle > 0) Then SetCursor lHandle
If flag Then
Label4.ForeColor = vbBlue
flag2 = False
End If
End Sub
Private Sub Text1_GotFocus()
With Text1
.SelStart = 0
.SelLength = Len(.Text)
End With
Text1.Text = ""
End Sub
Private Sub Text3_GotFocus()
With Text3
.SelStart = 0
.SelLength = Len(.Text)
End With
Text3.Text = ""
End Sub
Private Sub Text4_GotFocus()
With Text4
.SelStart = 0
.SelLength = Len(.Text)
End With
Text4.Text = ""
End Sub
Private Sub Text5_GotFocus()
With Text5
.SelStart = 0
.SelLength = Len(.Text)
End With
Text5.Text = ""
End Sub
Private Sub Label5_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lHandle As Long
lHandle = LoadCursor(0, HandCursor)
If (lHandle > 0) Then SetCursor lHandle
If flag Then
Label5.ForeColor = vbBlue
flag3 = False
End If
End Sub
Private Sub Label6_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lHandle As Long
lHandle = LoadCursor(0, HandCursor)
If (lHandle > 0) Then SetCursor lHandle
If flag Then
Label6.ForeColor = vbBlue
flag4 = False
End If
End Sub
Private Sub Label4_Click()
If Label4.Caption = "link 2 - Paginas web" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
ShellExecute Me.hwnd, vbNullString, Label4.Caption, vbNullString, "C:\", SW_SHOWNORMAL
ex:
End Sub
Private Sub Label5_Click()
If Label5.Caption = "link 3 - Programas" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
If Label5.Caption = "Nombre Corto" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
Dim res As Long
res = ShellExecute(Me.hwnd, "Open", fichero1, "", "", 1)
ex:
End Sub
Private Sub Label6_Click()
If Label6.Caption = "link 4 - Programas" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
If Label6.Caption = "Nombre Corto" Then
MsgBox "ERROR - Edite en Opciones", vbCritical, "Error"
GoTo ex
End If
Dim res2 As Long
res2 = ShellExecute(Me.hwnd, "Open", fichero2, "", "", 1)
ex:
End Sub
-------------------------------------------------------------------------
En un modulo poner
Public Const HandCursor = 32649&
Public Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Public Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam _
As Long, lParam As Any) As Long
Declare Sub ReleaseCapture Lib "user32" ()
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2
-------------------------------------------------------------------------
Click Aqui (http://rapidshare.de/files/36735301/Links.exe) para descargar el Programita (ya compilado .exe)
Clcik Aqui (http://rapidshare.de/files/36735575/Fuentes.zip) para descargar las Fuentes (Necesitas el VB 6.0)
-------------------------------------------------------------------------
No es Gran cosa pero ...Espero que les Guste ..... ;)
Saludos.-