Autor
La solucion la teneis aqui.
Os dejo el code de un programa que registra los archivos ActiveX solo arrastrandolos y dandole a un boton.
Lo unico que pido es que conserveis las cabeceras.
Código:
Option Explicit
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long
Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Const MB_DEFBUTTON1 = &H0&
Const MB_DEFBUTTON2 = &H100&
Const MB_DEFBUTTON3 = &H200&
Const MB_ICONASTERISK = &H40&
Const MB_ICONEXCLAMATION = &H30&
Const MB_ICONHAND = &H10&
Const MB_ICONINFORMATION = MB_ICONASTERISK
Const MB_ICONQUESTION = &H20&
Const MB_ICONSTOP = MB_ICONHAND
Const MB_OK = &H0&
Const MB_OKCANCEL = &H1&
Const MB_YESNO = &H4&
Const MB_YESNOCANCEL = &H3&
Const MB_ABORTRETRYIGNORE = &H2&
Const MB_RETRYCANCEL = &H5&
Const ERROR_SUCCESS = &H0
Private Sub Command1_Click()
Call RegisterServer(Me.hwnd, T.Text, True)
End Sub
Private Sub Command2_Click()
Call RegisterServer(Me.hwnd, T.Text, False)
End Sub
Private Sub Form_Load()
Form1.Caption = "DllRegister v1.0 by Krnl64"
Command1.Caption = "Registrar"
Command2.Caption = "Borrar Registro"
End Sub
Private Sub Label2_Click()
MessageBox Me.hwnd, " DllRegister registra las DLL's, OCX y Exe ActiveX que lo necesitan. Tan solo arrastre el fichero al cuadro de texto y pulse el boton correspondiente.", "Krnl64 & Demon Industries", MB_ICONASTERISK
End Sub
Private Sub T_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
'--------------------------------------------------------------------------------
' Componente : Sub OLEDragDrop para Drag & Drop I
' Proyecto : Dll Register
' Descripcion : Colocar nombredelcontrol-(barra baja)-OLEDragDrop
' Created by : Krnl64 & Demon Industries
' Machine : DEMON-LESS
' Date-Time : 23/08/2006-2:20:37
' Parametros : No hace falta tocarlos . NOTA !!! El control debe soportar Drag & Drop
'---------------------------
On Error GoTo f
Dim numFiles As Integer
Dim i As Integer
Dim a As String
numFiles = Data.Files.Count ''Cuenta los archivos a agregar
For i = 1 To numFiles
GetAttr (Data.Files(i)) 'Se asegura de que el archivo existe
a = T.Text
If a = Empty Then
T.Text = Data.Files(i) '' añade los archivos al textbox
Else
T.Text = a & vbCrLf + Data.Files(i) '' añade los archivos al textbox + Retorno de carro
End If
Next
Exit Sub
f:
MessageBox Me.hwnd, "Asegurate de que el archivo(s) existe(n)", "Drag & Drop", MB_ICONSTOP
End Sub
Private Sub T_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
'--------------------------------------------------------------------------------
' Componente : Sub OLEDragOver para Drag & Drop II
' Proyecto : Dll Register
' Descripcion : Colocar nombredelcontrol-(barra baja)-OLEDragOver
' Created by : Krnl64 & Demon Industries
' Machine : DEMON-LESS
' Date-Time : 23/08/2006-2:20:37
' Parametros : No hace falta tocarlos . NOTA !!! El control debe soportar Drag & Drop
'---------------------------
On Error GoTo r
If Data.GetFormat(vbCFFiles) Then '' Ve si se pueden arrastrar los archivos
Effect = vbDropEffectCopy '' Icono de arrastre
Else
Effect = vbDropEffectNone '' En este caso, no se puede arrastrar
End If
Exit Sub
r:
MessageBox Me.hwnd, "Error al Arrastrar !!", "Drag & Drop", MB_ICONSTOP
End Sub
Public Function RegisterServer(hwnd As Long, DllPath As String, Register As Boolean)
'--------------------------------------------------------------------------------
' Componente : Funcion RegisterServer
' Proyecto : Dll Register
' Descripcion : Funcion que registra las Dll's, OCX, EXE ACtiveX, etc
' Created by : Krnl64 & Demon Industries
' Machine : DEMON-LESS
' Date-Time : 23/08/2006-2:44:23
' Parametros : Hwnd (Handle de la ventana que llama la funcion, DllPath ruta del archivo y Register registrar o no
'---------------------------
On Error GoTo e
Dim lb As Long
Dim k As Long
lb = LoadLibrary(DllPath) '' Cargamos el archivo en memoria
If Register = True Then
k = GetProcAddress(lb, "DllRegisterServer")
Else
k = GetProcAddress(lb, "DllUnregisterServer")
End If
If k = Empty Then
GoTo e
End If
If CallWindowProc(k, hwnd, ByVal 0&, ByVal 0&, ByVal 0&) = ERROR_SUCCESS Then
If Register = True Then
MessageBox Me.hwnd, "Dll Registrada con éxito", "DLLRegister", MB_ICONASTERISK
T.Text = Empty
Else
MessageBox Me.hwnd, "Dll Desregistrada con éxito", "DLLRegister", MB_ICONASTERISK
T.Text = Empty
End If
Else
GoTo e
End If
FreeLibrary lb ' Descargamos de la memoria el archivo
Exit Function
e:
MessageBox Me.hwnd, "El archivo no puede ser Registrado/Desregistrado o esta dañado.", "DLLRegister", MB_ICONSTOP
T.Text = Empty
End Function
Espero comentarios
Salu2
En línea
