Crear archivos con extensiones personalizadas

Diego
18 de Julio del 2004
Necesito desarrollar un programa en visual basic 6 que maneje sus propias extensiones de archivos, y que estas sean reconocidas por windows

tecniCam
18 de Julio del 2004
Naturalmente que puedes hacerlo y para ello debes manejar el API y registrarlo convenientemente.
____________________
EN UN MÓDULO y ya llamarás a las distintas funciones...

' Estas son las funciones para acceder al Registro
' mediante llamadas a la Win API.
'
Function ExistKey(ByVal Root As Long, ByVal key As String) As Boolean
' Comporbar si acaso existe o no una clave
Dim lResult As Long
Dim keyhandle As Long

' Intentar abrir la clave...
lResult = RegOpenKeyEx(Root, key, 0, KEY_READ, keyhandle)

' si la clave existe,entonces cerrarla.(es tan sólo una prueba)
If lResult = ERROR_SUCCESS Then RegCloseKey keyhandle

' Devolver el valor true o false
ExistKey = (lResult = ERROR_SUCCESS)
End Function

Function GetValue(Root As Long, key As String, Field As String, Value As Variant) As Boolean
' Leer un valor de una clave especificada
' La clave se define como: Root, key and name
Dim lResult As Long
Dim keyhandle As Long
Dim dwType As Long
Dim zw As Long
Dim bufsize As Long
Dim buffer As String
Dim i As Integer
Dim tmp As String

' Abrir la clave
lResult = RegOpenKeyEx(Root, key, 0, KEY_READ, keyhandle)
GetValue = (lResult = ERROR_SUCCESS) ' ¿Hubo éxito?

If lResult <> ERROR_SUCCESS Then Exit Function ' La clave no existe
' Obtener el valor
lResult = RegQueryValueEx(keyhandle, Field, 0&, dwType, _
ByVal 0&, bufsize)
GetValue = (lResult = ERROR_SUCCESS) ' ¿Hubo éxito?

If lResult <> ERROR_SUCCESS Then Exit Function ' Name doesn't exist

Select Case dwType
Case REG_SZ ' cadena terminada en cero
buffer = Space(bufsize + 1)
lResult = RegQueryValueEx(keyhandle, Field, 0&, dwType, ByVal buffer, bufsize)
GetValue = (lResult = ERROR_SUCCESS)
If lResult <> ERROR_SUCCESS Then Exit Function ' Error
Value = buffer
Value = Trim(Mid(buffer, 1, Len(Trim(buffer)) - 1))
Case REG_DWORD ' Número de 32-Bits ! Word
bufsize = 4 ' = 32 Bits
lResult = RegQueryValueEx(keyhandle, Field, 0&, dwType, zw, bufsize)
GetValue = (lResult = ERROR_SUCCESS)
If lResult <> ERROR_SUCCESS Then Exit Function ' Error
Value = zw

Case REG_BINARY ' Binary
buffer = Space(bufsize + 1)
lResult = RegQueryValueEx(keyhandle, Field, 0&, dwType, ByVal buffer, bufsize)
GetValue = (lResult = ERROR_SUCCESS)
If lResult <> ERROR_SUCCESS Then Exit Function ' Error
Value = ""
For i = 1 To bufsize
tmp = Hex(Asc(Mid(buffer, i, 1)))
If Len(tmp) = 1 Then tmp = "0" + tmp
Value = Value + tmp + " "
Next i
' Aquí hay lugar para otros tipos de datos
End Select

If lResult = ERROR_SUCCESS Then RegCloseKey keyhandle
GetValue = True

End Function

Function CreateKey(Root As Long, newkey As String, Class As String) As Boolean
Dim lResult As Long
Dim keyhandle As Long
Dim Action As Long

lResult = RegCreateKeyEx(Root, newkey, 0, Class, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, keyhandle, Action)
If lResult = ERROR_SUCCESS Then
If RegFlushKey(keyhandle) = ERROR_SUCCESS Then RegCloseKey keyhandle
Else
CreateKey = False
Exit Function
End If
CreateKey = (Action = REG_CREATED_NEW_KEY)

End Function

Function SetValue(Root As Long, key As String, Field As String, Value As Variant) As Boolean
Dim lResult As Long
Dim keyhandle As Long
Dim s As String
Dim l As Long

lResult = RegOpenKeyEx(Root, key, 0, KEY_ALL_ACCESS, keyhandle)
If lResult <> ERROR_SUCCESS Then
SetValue = False
Exit Function
End If

Select Case VarType(Value)
Case vbInteger, vbLong
l = CLng(Value)
lResult = RegSetValueEx_DWord(keyhandle, Field, 0, REG_DWORD, l, 4)
Case vbString
s = CStr(Value)
lResult = RegSetValueEx_String(keyhandle, Field, 0, REG_SZ, s, Len(s) + 1) ' +1 para un 00 al final

' Aquí hay lugar para otros tipos de datos
End Select

RegCloseKey keyhandle
SetValue = (lResult = ERROR_SUCCESS)

End Function

Function DeleteKey(Root As Long, key As String) As Boolean
Dim lResult As Long

lResult = RegDeleteKey(Root, key)
DeleteKey = (lResult = ERROR_SUCCESS)
End Function

Function DeleteValue(Root As Long, key As String, Field As String) As Boolean
Dim lResult As Long
Dim keyhandle As Long

lResult = RegOpenKeyEx(Root, key, 0, KEY_ALL_ACCESS, keyhandle)
If lResult <> ERROR_SUCCESS Then
DeleteValue = False
Exit Function
End If

lResult = RegDeleteValue(keyhandle, Field)
DeleteValue = (lResult = ERROR_SUCCESS)
RegCloseKey keyhandle
End Function