Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0543: Programm mit Dateiendung assoziieren II

VB 5/6-Tipp 0543: Programm mit Dateiendung assoziieren II

 von Mario Grimm

Schwierigkeitsgrad:

Verwendete API-Aufrufe: RegCloseKey, RegCreateKeyExA (RegCreateKeyEx), RegDeleteKeyA (RegDeleteKey), RegDeleteValueA (RegDeleteValue), RegFlushKey, RegOpenKeyExA (RegOpenKeyEx), RegQueryValueExA (RegQueryValueEx), RegSetValueExA (RegSetValueEx), RegSetValueExA (RegSetValueEx_Str)

Download: Download des Beispielprojektes [3,68 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (COMDLG32.OCX)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit



Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
        Alias "RegOpenKeyExA" ( _
        ByVal hKey As Long, _
        ByVal lpSubKey As String, _
        ByVal ulOptions As Long, _
        ByVal samDesired As Long, _
        phkResult As Long) As Long
        
Private Declare Function RegCloseKey Lib "advapi32.dll" _
        (ByVal hKey As Long) As Long
        
Private Declare Function RegQueryValueEx Lib "advapi32.dll" _
        Alias "RegQueryValueExA" ( _
        ByVal hKey As Long, _
        ByVal lpValueName As String, _
        ByVal lpReserved As Long, _
        lpType As Long, _
        lpData As Any, _
        lpcbData As Any) As Long
        
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" _
        Alias "RegCreateKeyExA" ( _
        ByVal hKey As Long, _
        ByVal lpSubKey As String, _
        ByVal Reserved As Long, _
        ByVal lpClass As String, _
        ByVal dwOptions As Long, _
        ByVal samDesired As Long, _
        ByVal lpSecurityAttributes As Any, _
        phkResult As Long, _
        lpdwDisposition As Long) As Long
        
Private Declare Function RegFlushKey Lib "advapi32.dll" ( _
        ByVal hKey As Long) As Long
        
Private Declare Function RegSetValueEx Lib "advapi32.dll" _
        Alias "RegSetValueExA" ( _
        ByVal hKey As Long, _
        ByVal lpValueName As String, _
        ByVal Reserved As Long, ByVal _
        dwType As Long, _
        lpData As Long, _
        ByVal cbData As Long) As Long
        
Private Declare Function RegSetValueEx_Str Lib "advapi32.dll" _
        Alias "RegSetValueExA" ( _
        ByVal hKey As Long, _
        ByVal lpValueName As String, _
        ByVal Reserved As Long, _
        ByVal dwType As Long, _
        ByVal lpData As String, _
        ByVal cbData As Long) As Long

Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias _
        "RegDeleteKeyA" ( _
        ByVal hKey As Long, _
        ByVal lpSubKey As String) As Long
        
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias _
        "RegDeleteValueA" ( _
        ByVal hKey As Long, _
        ByVal lpValueName As String) As Long


Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_PERFORMANCE_DATA = &H80000004
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006

Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_READ = KEY_QUERY_VALUE Or _
                 KEY_ENUMERATE_SUB_KEYS _
                 Or KEY_NOTIFY
                 
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE Or _
                       KEY_SET_VALUE Or _
                       KEY_CREATE_SUB_KEY Or _
                       KEY_ENUMERATE_SUB_KEYS Or _
                       KEY_NOTIFY Or _
                       KEY_CREATE_LINK
                       
Const ERROR_SUCCESS = 0&

Const REG_NONE = 0
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_DWORD_LITTLE_ENDIAN = 4
Const REG_DWORD_BIG_ENDIAN = 5
Const REG_LINK = 6
Const REG_MULTI_SZ = 7

Const REG_OPTION_NON_VOLATILE = &H0
Dim PicturePath As String
Private RegRoot&

Private Sub Command1_Click()
    Dim Result&
    Dim StrVar$
    Dim SecondKey As String
    Dim RegRoot2&
    Dim SystemVerzeichnis As String
    'Schlüssel erstellen

    RegRoot = HKEY_CLASSES_ROOT

    Result = RegKeyCreate(RegRoot, Text1.Text)
    
    SecondKey = Text1.Text
    SecondKey = Replace(SecondKey, ".", "*")
    Result = RegKeyCreate(RegRoot, SecondKey & "file")
    Result = RegKeyCreate(RegRoot, SecondKey & "file\DefaultIcon")
    Result = RegKeyCreate(RegRoot, SecondKey & "file\Quickview")
    Result = RegKeyCreate(RegRoot, SecondKey & "file\Shell")
    Result = RegKeyCreate(RegRoot, SecondKey & "file\Shell\open")
    Result = RegKeyCreate(RegRoot, SecondKey & "file\Shell\print")
    Result = RegKeyCreate(RegRoot, SecondKey & "file\Shell\open\Command")
    Result = RegKeyCreate(RegRoot, SecondKey & "file\Shell\print\Command")
    
    StrVar = SecondKey & "file"
    Result = RegValueSet(RegRoot, Text1.Text, "", StrVar)
    
    StrVar = SecondKey & "file"
    
    If PicturePath <> "" Then
        Result = RegValueSet(RegRoot, SecondKey & "file\" & _
            "DefaultIcon", "", PicturePath & ",0")
    End If
    
    SystemVerzeichnis = Left$(Environ$("comspec"), Len(Environ$("comspec")) - 7)
    Result = RegValueSet(RegRoot, SecondKey & "file\" & _
        "Shell\open\Command", "", SystemVerzeichnis & "NOTEPAD.EXE %1")
        
    Result = RegValueSet(RegRoot, SecondKey & "file\" & _
        "Shell\print\Command", "", SystemVerzeichnis & "NOTEPAD.EXE /p %1")
    
    Open "C:\Sample" & Text1.Text For Output As #1
    Close #1
    
    MsgBox "Dateityp wurde erfolgreich erstellt!" _
    & vbCrLf & "Beispiel-Datei unter C:\ mit dem Namen Sample" & Text1.Text
    
End Sub

Private Sub Command2_Click()
    On Error Goto CancelIsPressed
    
    CommonDialog1.CancelError = True
    CommonDialog1.Filter = "Icons (*.ico)|*.ico"
    CommonDialog1.Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly
    CommonDialog1.ShowOpen
    
    If Right$(CommonDialog1.FileTitle, "3") <> "ico" Then
        MsgBox "Falscher Dateityp"
    End If
    
    Picture1.Picture = LoadPicture(CommonDialog1.FileName)
    Picture1.AutoSize = True
    PicturePath = CommonDialog1.FileName
    
CancelIsPressed:
End Sub

Function RegKeyCreate(Root&, Newkey$) As Long
    Dim Result&, hKey&, Back&
    'Neuen Schlüssel erstellen
    
    Result = RegCreateKeyEx(Root, Newkey, 0, vbNullString, _
                            REG_OPTION_NON_VOLATILE, _
                            KEY_ALL_ACCESS, 0&, hKey, Back)
                            
    If Result = ERROR_SUCCESS Then
        Result = RegFlushKey(hKey)
        If Result = ERROR_SUCCESS Then Call RegCloseKey(hKey)
        RegKeyCreate = Back
    End If
End Function


Function RegValueSet(Root&, Key$, Field$, Value As Variant) As Long
    Dim Result&, hKey&, s$, l&
    'Wert in ein Feld der Registry schreiben
    
    Result = RegOpenKeyEx(Root, Key, 0, KEY_ALL_ACCESS, hKey)
    If Result = ERROR_SUCCESS Then
        Select Case VarType(Value)
            Case vbInteger, vbLong
                l = CLng(Value)
                Result = RegSetValueEx(hKey, Field, 0, REG_DWORD, l, 4)
            Case vbString
                s = CStr(Value)
                Result = RegSetValueEx_Str(hKey, Field, 0, REG_SZ, _
                                        s, Len(s) + 1)
        End Select
        Result = RegCloseKey(hKey)
    End If
    
    RegValueSet = Result
End Function

Function RegValueGet(Root&, Key$, Field$, Value As Variant) As Long
    Dim Result&, hKey&, dwType&, Lng&, Buffer$, l&
    'Wert aus einem Feld der Registry auslesen
    
    Result = RegOpenKeyEx(Root, Key, 0, KEY_READ, hKey)
    If Result = ERROR_SUCCESS Then
        Result = RegQueryValueEx(hKey, Field, 0&, dwType, ByVal 0&, l)
        If Result = ERROR_SUCCESS Then
            Select Case dwType
                Case REG_SZ
                    Buffer = Space$(l + 1)
                    Result = RegQueryValueEx(hKey, Field, 0&, _
                                     dwType, ByVal Buffer, l)
                                     
                    If Result = ERROR_SUCCESS Then Value = Buffer
                Case REG_DWORD
                    Result = RegQueryValueEx(hKey, Field, 0&, _
                                      dwType, Lng, l)
                                      
                    If Result = ERROR_SUCCESS Then Value = Lng
            End Select
        End If
    End If
    
    If Result = ERROR_SUCCESS Then Result = RegCloseKey(hKey)
    RegValueGet = Result
End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.