Videos in VB
lima-city → Forum → Programmiersprachen → Basic
all
dateiname
error
exit
fehler
fenster
format
fram
ger
millisekunde
movie
pausen
play
resume
right
set
source
status
window
zeichenfolge
-
Hi!
Ich m?chte in einem Programm ein Inro hinzuf?gen, das ich vorher erstellt habe. Ich habe es im avi und im mpeg Format, und ich w?rde sie gerne im Programm abspielen, und zwaer automatisch, ohne dass Schaltfl?chen angezeigt werden.
Ich lerne zwar jetzt C++, aber ich w?rde es trotzdem wissen, bevor ich mein Programm auf C++ umstelle. Allgemeinwissen ist immer gut
.
Das Video ist nicht lang und soll nur kurz als startanimation angezeigt werden.
Ich hoffe auf viele Antworten
Zualio -
Diskutiere mit und stelle Fragen: Jetzt kostenlos anmelden!
lima-city: Gratis werbefreier Webspace für deine eigene Homepage
-
dass m?sst mit dem windows media teil gehn, den kannst irgentwie auch direkt steuern, schau ma auf
http://msdn.com -
Meines Wissens geht das nicht, aber jeder kann sich irren, falls es doch geht, dann schreib es bitt hier hin.
-
http://www.vbarchiv.net/archiv/tipp_details.php?pid=624
http://www.vbarchiv.net/archiv/tipp_details.php?pid=944
Ich hoffe konnte dir help?n! -
Hallo!
Ich hatte mal f?r ein Projekt ein Video Objekt gebraucht! Ich hatte aber schoneinmal probiert den Kompletten Source-Code hochzuladen, aber hat nicht geklappt. Ich werde das dann nun auf mehrere Threads aufgeben, also mit bitte nicht ?ber nehmen. Hier aber schon der Source-Code des eigentlichen Programms (also deins):
Nur eine PictureBox (Picture1) erstellen in der dieses angezeigt wird:
Dim foMCI As New MCIClass
Private Sub Form_Load()
foMCI.SetFilename "C:\test.avi"
foMCI.OpenMovieWindow Picture1.hWnd, Child
foMCI.PlayMovie
End Sub
Mfg
Meme -
Hier die Komplette Klasse: Bitte f?r das Klassenmodul auch "MCIClass" als Namen verwenden:
Option Explicit
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long 'Get the error message of the mcidevice if any
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long 'Send command strings to the mci device
Private fsData As String * 128 ' Puffer f?r Dateninput
Private flError As Long ' Error Message
Private fsFilename As String ' Dateiname
Public Enum MCIWindowStyles
popUp = 0
Child = 1
Overlapped = 2
End Enum
Public Sub SetFilename(ByVal lsFilename As String)
' Zuweisung des Dateinamens
fsFilename = lsFilename
End Sub
Public Function GetFilename() As String
' Abfrage des Dateinamens
GetFilename = fsFilename
End Function
Public Function StepFrames(ByVal llValue As Long)
' Get eine Anzahl von Frames vor (im Movie)
flError = mciSendString("step movie by " & llValue, 0, 0, 0)
End Function
Public Function RestoreSizeDefault()
' Resettet die Einstelluing f?r Gr?sse des Videos auf Standard (nicht im Child-Modus)
flError = mciSendString("put movie window", 0, 0, 0)
End Function
Public Function OpenMovie()
Dim llStelle As Long
Dim lsMCIHandler As String
' ?ffnet ein Video in einem Fenster (Fenstermodus)
flError = mciSendString("close movie", 0, 0, 0) ' Falls noch ein Video ge?ffnet ist
' ?ffnet das Video mit dem MPEGVIDEO Treiber
If Len(fsFilename) <= 4 Then Exit Function
llStelle = InStrRev(fsFilename, ".")
lsMCIHandler = GetKeyValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\MCI Extensions", LCase(Left(fsFilename, Len(fsFilename) - llStelle)))
If lsMCIHandler <> "" Then
flError = mciSendString("open " & GetFilenameAsAPICommand & " type " & lsMCIHandler & " alias movie", 0, 0, 0)
Else
flError = mciSendString("open " & GetFilenameAsAPICommand & " type mpegvideo alias movie", 0, 0, 0)
End If
' Auskommentieren, falls oberes nicht funktioniert (MCI sucht selbst Treiber)
'flError = mciSendString("open " & GetFilenameAsAPICommand & " alias movie", 0, 0, 0)
End Function
Public Function OpenMovieWindow(ByVal llHWND As Long, Optional ByVal loWindowStyle As MCIWindowStyles = popUp)
Dim llStelle As Long
Dim lsMCIHandler As String
' ?ffnet ein Video in einem Fenster (nach Auswahl)
Dim lsOption As String
Select Case loWindowStyle
Case 0: lsOption = "popup"
Case 1: lsOption = "child"
Case 2: lsOption = "overlapped"
End Select
flError = mciSendString("close movie", 0, 0, 0) ' Falls noch ein Video ge?ffnet ist
' ?ffnet das Video mit dem MPEGVIDEO Treiber
If Len(fsFilename) <= 4 Then Exit Function
llStelle = InStrRev(fsFilename, ".")
lsMCIHandler = GetKeyValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\MCI Extensions", LCase(Left(fsFilename, Len(fsFilename) - llStelle)))
If lsMCIHandler <> "" Then
flError = mciSendString("open " & GetFilenameAsAPICommand & " type " & lsMCIHandler & " alias movie parent " & llHWND & " style " & lsOption & " ", 0, 0, 0)
Else
flError = mciSendString("open " & GetFilenameAsAPICommand & " type mpegvideo alias movie parent " & llHWND & " style " & lsOption & " ", 0, 0, 0)
End If
' Auskommentieren, falls oberes nicht funktioniert (MCI sucht selbst Treiber)
'flError = mciSendString("open " & GetFilenameAsAPICommand & " alias movie parent " & hWnd & " style " & WindowStyle & " ", 0, 0, 0)
End Function
Public Function CaptureMovie(ByVal lsFilename As String)
' Screenshot des Videos (wird selten unterst?tzt)
flError = mciSendString("save movie " & lsFilename & " wait", 0, 0, 0)
End Function
Public Function MinimizeMovie()
' Minimiert das Videofenster
flError = mciSendString("window movie state minimized", 0, 0, 0)
End Function
Public Function PlayMovie()
' Play des Videos (nach ?ffnen des Videos)
flError = mciSendString("play movie", 0, 0, 0)
End Function
Public Function HideMovie()
' Versteckt das Video Fenster
flError = mciSendString("window movie state hide", 0, 0, 0)
End Function
Public Function ShowMovie()
' Zeigt das Video Fenster (wenn HideMovie benutzt wurde)
flError = mciSendString("window movie state show", 0, 0, 0)
End Function
Public Function RestoreMovie()
' Resettet das Fenster zum Anfangspunkt
flError = mciSendString("window movie state restore", 0, 0, 0)
End Function
Public Function StopMovie()
' Stopped das Video
flError = mciSendString("stop movie", 0, 0, 0)
End Function
Public Function ExtractCurrentMovieSize(ByRef llLeft As Long, ByRef llTop As Long, ByRef llWidth As Long, ByRef llHeight As Long)
' Gibt die aktuelle Gr?sse des Videos zur?ck
Dim a As String
Dim b As String
Dim c As String
Dim f As String
Dim g As String
On Error Resume Next
a = GetCurrentSize
b = InStr(1, a, " ")
c = InStr(b + 1, a, " ")
f = Mid(a, c + 1)
g = InStr(1, f, " ")
llLeft = 0
llTop = 0
llWidth = Val(Left(f, g)) 'width
llHeight = Val(Mid(f, g)) 'height
On Error GoTo 0
End Function
Public Function ExtractDefaultMovieSize(ByRef llWidth As Long, ByRef llHeight As Long)
'Returns the default size of the movie even if the size
'of the movie has been changed
Dim a As String
Dim b As String
Dim c As String
Dim f As String
Dim g As String
On Error Resume Next
a = GetDefaultSize
b = InStr(1, a, " ") '2
c = InStr(b + 1, a, " ") '4
f = Mid(a, c + 1) '9
g = InStr(1, f, " ")
llWidth = Val(Left(f, g)) 'width
llHeight = Val(Mid(f, g)) 'height
On Error GoTo 0
End Function
Public Function GetBitsPerPixel()
' Ermittelt die BitsPerPixel (Nur bei AVI)
flError = mciSendString("status movie bitsperpel", fsData, 128, 0)
GetBitsPerPixel = Val(fsData)
End Function
Public Function GetMovieInput() As String
' Gibt die aktuelle Input-Quelle zur?ck
flError = mciSendString("status movie monitor input", fsData, 128, 0)
GetMovieInput = fsData
End Function
Public Function GetMovieOutput() As String
' Gibt die aktuelle Output-Quelle zur?ck
flError = mciSendString("status movie monitor output", fsData, 128, 0)
GetMovieOutput = fsData
End Function
Public Function GetAudioStatus() As String
' Gibt zur?ck, ob Audio an oder aus ist
flError = mciSendString("status movie audio", fsData, 128, 0)
GetAudioStatus = fsData
End Function
Public Function SizeLocateMovie(ByVal llLeft As Long, ByVal llTop As Long, ByVal llWidth As Long, ByVal llHeight As Long)
' ?ndert Position und Gr?sse eines Videos (in Pixel)
flError = mciSendString("put movie window at " & llLeft & " " & llTop & " " & llWidth & " " & llHeight, 0, 0, 0)
End Function
Public Function IsMoviePlaying() As Boolean
' Gibt zur?ck, ob das Video l?uft
Dim lsIsPlaying As String
flError = mciSendString("status movie mode", fsData, 128, 0)
lsIsPlaying = Left(fsData, 7)
If lsIsPlaying = "playing" Then
IsMoviePlaying = True
Else
IsMoviePlaying = False
End If
End Function
Public Function CheckError() As String
' Ermittelt den Klartext eines Fehlers
CheckError = Space$(255)
mciGetErrorString flError, CheckError, Len(CheckError)
End Function
Public Function GetDeviceName() As String
' Gibt den aktuellen Ger?tetreiber zur?ck
flError = mciSendString("info movie product", fsData, 128, 0)
GetDeviceName = fsData
End Function
Public Function GetDeviceVersion() As String
' Gibt die aktuelle Version des Ger?tetreibers zur?ck
flError = mciSendString("info movie version", fsData, 128, 0)
GetDeviceVersion = fsData
End Function
Public Function GetNominalFrameRate() As Long
' Gibt die Nominale FrameRate des Videos zur?ck
flError = mciSendString("status movie nominal frame rate wait", fsData, 128, 0)
GetNominalFrameRate = Val(fsData)
End Function
Public Function GetFramePerSecRate() As Long
' Gibt die Frames/sec eines Videos zur?ck (AVI und MPEG)
flError = mciSendString("status movie frame rate", fsData, 128, 0)
GetFramePerSecRate = Val(fsData) \ 1000
End Function
Public Function GetCurrentSize() As String
' Gibt aktuelle H?he und Breite des Videos zur?ck
flError = mciSendString("where movie destination max", fsData, 128, 0)
GetCurrentSize = fsData
End Function
Public Function GetDefaultSize() As String
' Gibt eigentliche H?he und Breite des Videos zur?ck
flError = mciSendString("where movie source", fsData, 128, 0)
GetDefaultSize = fsData
End Function
Public Function GetLengthInFrames() As Long
' Gibt die Gesamtanzahl der Frames zur?ck
flError = mciSendString("set movie time format frames", 0, 0, 0)
flError = mciSendString("status movie length", fsData, 128, 0)
GetLengthInFrames = Val(fsData)
End Function
Public Function GetLengthInMS() As Long
' Gibt die Gesamtanzahl der Millisekunden zur?ck
flError = mciSendString("set movie time format ms", 0, 0, 0)
flError = mciSendString("status movie length", fsData, 128, 0)
GetLengthInMS = Val(fsData)
End Function
Public Function PlayFullScreen()
' Abspielen des Videos in Fullscreen
flError = mciSendString("play movie fullscreen", 0, 0, 0)
End Function
Public Function GetLengthInSec() As Long
' Gibt die Gesamtl?nge des Videos in Sekunden zur?ck
GetLengthInSec = GetLengthInMS \ 1000
End Function
Public Function SetVideoOff()
' Schaltet das Video-Ger?t aus
flError = mciSendString("set all video off", 0, 0, 0)
End Function
Public Function SetVideoOn()
' Schaltet das Video-Ger?t ein
flError = mciSendString("set all video on", 0, 0, 0)
End Function
Public Function PauseMovie()
' Pause
flError = mciSendString("pause movie", 0, 0, 0)
End Function
Public Function ResumeMovie()
' Pause aufheben
flError = mciSendString("resume movie", 0, 0, 0)
End Function
Public Function GetPositionInMS() As Long
' Aktuelle Position in Millisekunden
flError = mciSendString("set movie time format ms", 0, 0, 0)
flError = mciSendString("status movie position wait", fsData, 128, 0)
GetPositionInMS = Val(fsData)
End Function
Public Function GetRate() As Long
' Ermittelt die aktuelle Geschwindigkeit des Videos
flError = mciSendString("status movie speed", fsData, 128, 0)
GetRate = Val(fsData)
End Function
Public Function GetPositionInFrames() As Long
' Aktuelle Position in Frames
flError = mciSendString("set movie time format frames wait", 0, 0, 0)
flError = mciSendString("status movie position", fsData, 128, 0)
GetPositionInFrames = Val(fsData)
End Function
Public Function GetStatus() As String
' Aktueller Modus des Videos
' (Playing, Stopped, Paused, Not Ready)
flError = mciSendString("status movie mode", fsData, 128, 0)
GetStatus = StrConv(fsData, vbProperCase)
End Function
Public Function CloseMovie()
' MCI Treiber schliessen
flError = mciSendString("close movie", 0, 0, 0)
End Function
Public Function GetFormatPosition() As String
' Gibt die Position in einer Benutzerfreundlichen Form zur?ck
GetFormatPosition = GetThisTime(GetPositionInMS)
End Function
Public Function GetFormatLength() As String
' Gibt die L?nge in einer Benutzerfreundlichen Form zur?ck
GetFormatLength = GetThisTime(GetLengthInMS)
End Function
Private Function GetThisTime(ByVal llTimeIn As Long) As String
' Zeitformatierung
Dim liConH As Integer
Dim liConM As Integer
Dim liConS As Integer
Dim llRemTime As Long
Dim lsRetTime As String
On Error GoTo MCI_Fehler
llRemTime = llTimeIn / 1000
liConH = Int(llRemTime / 3600)
llRemTime = llRemTime Mod 3600
liConM = Int(llRemTime / 60)
llRemTime = llRemTime Mod 60
liConS = llRemTime
If liConH > 0 Then
lsRetTime = Trim(Str(liConH)) & ":"
Else
lsRetTime = ""
End If
If liConM >= 10 Then
lsRetTime = lsRetTime & Trim(Str(liConM))
ElseIf liConM > 0 Then
lsRetTime = lsRetTime & Trim(Str(liConM))
Else
lsRetTime = lsRetTime & "0"
End If
lsRetTime = lsRetTime & ":"
If liConS >= 10 Then
lsRetTime = lsRetTime & Trim(Str(liConS))
ElseIf liConS > 0 Then
lsRetTime = lsRetTime & "0" & Trim(Str(liConS))
Else
lsRetTime = lsRetTime & "00"
End If
GetThisTime = lsRetTime
On Error GoTo 0
Exit Function
MCI_Fehler:
MsgBox Err.Description, , " Error"
On Error GoTo 0
End Function
Public Function GetVolume() As Long
' Ermittelt Lautst?rke
flError = mciSendString("status movie volume", fsData, 128, 0)
GetVolume = Val(fsData)
End Function
Public Function GetVideoStatus() As String
' Ermittelt Status des Videos (An/Aus)
flError = mciSendString("status movie video", fsData, 128, 0)
GetVideoStatus = fsData
End Function
Public Function GetTimeFormat() As String
' Gibt aktuelles Zeit-Format zur?ck (Frames oder Millisekunden)
flError = mciSendString("status movie time format", fsData, 128, 0)
GetTimeFormat = fsData
End Function
Public Function GetLeftVolume() As Long
' Gibt Lautst?rke f?r linken Kanal zur?ck
flError = mciSendString("status movie left volume", fsData, 128, 0)
GetLeftVolume = Val(fsData)
End Function
Public Function GetPositionInSec() As Long
' Ermittelt Position in Sekunden
GetPositionInSec = GetPositionInMS \ 1000
End Function
Public Function GetRightVolume() As Long
' Gibt Lautst?rke f?r rechten Kanal zur?ck
flError = mciSendString("status movie right volume", fsData, 128, 0)
GetRightVolume = fsData
End Function
Public Function SetAudioOff()
' Audio aus
flError = mciSendString("set movie audio all off", 0, 0, 0)
End Function
Public Function SetAudioOn()
' Audio an
flError = mciSendString("set movie audio all on", 0, 0, 0)
End Function
Public Function SetLeftOff()
' Linker Audio-Kanal aus
flError = mciSendString("set movie audio left off", 0, 0, 0)
End Function
Public Function SetRightOff()
' Rechter Audio-Kanal aus
flError = mciSendString("set movie audio right off", 0, 0, 0)
End Function
Public Function SetLeftOn()
' Linker Audio-Kanal an
flError = mciSendString("set movie audio left on", 0, 0, 0)
End Function
Public Function SetRightOn()
' Rechter Audio-Kanal an
flError = mciSendString("set movie audio right on", 0, 0, 0)
End Function
Public Function SetDoorOpen()
' ?ffnet CD-Rom Laufwerk
flError = mciSendString("set cdaudio door open", 0, 0, 0)
End Function
Public Function SetDoorClosed()
' Schliesst CD-Rom Laufwerk
flError = mciSendString("set cdaudio door closed", 0, 0, 0)
End Function
Public Function SetVolume(ByVal llValue As Long)
' Stellt Lautst?rke f?r beide Kan?le ein
If llValue > 1000 Then llValue = 1000
If llValue < 0 Then llValue = 0
flError = mciSendString("setaudio movie volume to " & llValue, 0, 0, 0)
End Function
Public Function SetPositionTo(ByVal llSecond As Long)
' Setzt Position des Videos
llSecond = llSecond * 1000
If IsMoviePlaying = True Then
mciSendString "play movie from " & llSecond, 0, 0, 0
ElseIf IsMoviePlaying = False Then
mciSendString "seek movie to " & llSecond, 0, 0, 0
End If
End Function
Public Function SetPositionToMS(ByVal llMS As Long)
' Setzt Position des Videos
If IsMoviePlaying = True Then
mciSendString "play movie from " & llMS, 0, 0, 0
ElseIf IsMoviePlaying = False Then
mciSendString "seek movie to " & llMS, 0, 0, 0
End If
End Function
Public Function PlayAtPosition(ByVal llMS As Long)
' Setzt Position des Videos
mciSendString "play movie from " & llMS, 0, 0, 0
End Function
Public Function RestartMovie()
' Startet das Video vom Beginn
flError = mciSendString("seek movie to start", 0, 0, 0)
PlayMovie
End Function
Public Function RewindByMS(ByVal llNumMS As Long)
' Zur?ckspulen in MS
flError = mciSendString("set movie time format ms", 0, 0, 0)
flError = mciSendString("play movie from " & GetPositionInMS - llNumMS, 0, 0, 0)
End Function
Public Function RewindByFrames(ByVal llNumFrames As Long)
' Zur?ckspulen in Frames
flError = mciSendString("set movie time format frames", 0, 0, 0)
flError = mciSendString("play movie from " & GetPositionInFrames - llNumFrames, 0, 0, 0)
End Function
Public Function RewindBySeconds(ByVal llNumSec As Long)
' Zur?ckspulen in Sekunden
flError = mciSendString("set movie time format ms", 0, 0, 0)
flError = mciSendString("play movie from " & GetPositionInMS - 1000 * llNumSec, 0, 0, 0)
End Function
Public Function ForwardByFrames(ByVal llNumFrames As Long)
' Vorspulen in Frames
flError = mciSendString("set movie time format frames", 0, 0, 0)
flError = mciSendString("play movie from " & GetPositionInFrames + llNumFrames, 0, 0, 0)
End Function
Public Function ForwardByMS(ByVal llNumMS As Long)
' Vorspulen in MS
flError = mciSendString("set movie time format ms", 0, 0, 0)
flError = mciSendString("play movie from " & GetPositionInMS + llNumMS, 0, 0, 0)
End Function
Public Function ForwardBySeconds(ByVal llNumSec As Long)
' Vorspulen in Sekunden
flError = mciSendString("set movie time format ms", 0, 0, 0)
flError = mciSendString("play movie from " & GetPositionInMS + 1000 * llNumSec, 0, 0, 0)
End Function
Public Function CheckDeviceReady() As String
' Pr?ft, ob Ger?t Betriebsbereit ist
flError = mciSendString("status movie ready", fsData, 128, 0)
CheckDeviceReady = fsData
End Function
Public Function SetSpeed(ByVal llValue As Long)
' Setzt Geschwindigkeit des Videos
' 0 = so schnell wie m?glich
If llValue > 2000 Then llValue = 2000
If llValue < 0 Then llValue = 0
flError = mciSendString("set movie speed " & llValue, 0, 0, 0)
End Function
Public Function SetLeftVolume(ByVal llValue As Long)
' Setzt Lautst?rke f?r linken Kanal
flError = mciSendString("setaudio movie left volume to " & llValue, 0, 0, 0)
End Function
Public Function SetRightVolume(ByVal llValue As Long)
' Setzt Lautst?rke f?r rechten Kanal
flError = mciSendString("setaudio movie right volume to " & llValue, 0, 0, 0)
End Function
Sub TimeOut(ByVal llDuration As Long)
' Pause f?r angegebene Millisekunden
Dim llStartTime As Long
llStartTime = Timer
Do While Timer - llStartTime < llDuration
DoEvents
Loop
End Sub
Private Function GetFilenameAsAPICommand() As String
' F?gt Anf?hrungsstriche um den Dateinamen ein
GetFilenameAsAPICommand = Chr$(34) & fsFilename & Chr$(34)
End Function
-
Zum Ausf?hren wird auch das Registry Modul von Visual Basic gebraucht, wenn ihr nicht wisst wie Ihr dran kommt, dann hier der Source-Code:
' Dieses Modul liest und schreibt Registrierungsschl?ssel. Im Gegensatz
' zu den internen Registrierungszugriffsmethoden von VB, kann es
' Registrierungsschl?ssel mit Zeichenfolgenwerten lesen und schreiben.
'---------------------------------------------------------------
'- API-Deklarationen der Registrierung...
'---------------------------------------------------------------
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32" 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, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef phkResult As Long, ByRef lpdwDisposition As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" 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
'---------------------------------------------------------------
'- API-Konstanten der Registrierung...
'---------------------------------------------------------------
' Registrierungsdatentypen...
Const REG_SZ = 1 ' Null-terminierte Unicode-Zeichenfolge
Const REG_EXPAND_SZ = 2 ' Null-terminierte Unicode-Zeichenfolge
Const REG_DWORD = 4 ' 32-Bit-Zahl
' Registrierungsschl?ssel-Typwerte erstellen...
Const REG_OPTION_NON_VOLATILE = 0 ' Schl?ssel bleibt beim Neustart erhalten
' Registrierungsschl?ssel-Sicherheitsoptionen...
Const READ_CONTROL = &H20000
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 + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Const KEY_EXECUTE = KEY_READ
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
' Registrierungsschl?ssel-Stammtypen...
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
' R?ckgabewert...
Const ERROR_NONE = 0
Const ERROR_BADKEY = 2
Const ERROR_ACCESS_DENIED = 8
Const ERROR_SUCCESS = 0
'---------------------------------------------------------------
'- Sicherheitsattributtyp der Registrierung...
'---------------------------------------------------------------
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
'-------------------------------------------------------------------------------------------------
'Verwendungsbeispiel - Debug.Print UpodateKey(HKEY_CLASSES_ROOT, "keyname", "newvalue")
'-------------------------------------------------------------------------------------------------
Public Function UpdateKey(KeyRoot As Long, KeyName As String, SubKeyName As String, SubKeyValue As String) As Boolean
Dim rc As Long ' R?ckgabe-Code
Dim hKey As Long ' Zugriffsnummer f?r Registrierungsschl?ssel
Dim hDepth As Long '
Dim lpAttr As SECURITY_ATTRIBUTES ' Sicherheitstyp der Registrierung
lpAttr.nLength = 50 ' Sicherheitsattribute auf Standardeinstellungen setzen...
lpAttr.lpSecurityDescriptor = 0 ' ...
lpAttr.bInheritHandle = True ' ...
'------------------------------------------------------------
'- Registrierungsschl?ssel erstellen/?ffnen...
'------------------------------------------------------------
rc = RegCreateKeyEx(KeyRoot, KeyName, _
0, REG_SZ, _
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, _
hKey, hDepth) ' //KeyRoot//KeyName erstellen/?ffnen
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' Fehler behandeln...
'------------------------------------------------------------
'- Schl?sselwert erstellen/bearbeiten...
'------------------------------------------------------------
If (SubKeyValue = "") Then SubKeyValue = " " ' F?r RegSetValueEx() wird zur korrekten Ausf?hrung ein Leerzeichen ben?tigt...
' Schl?sselwert erstellen/bearbeiten
rc = RegSetValueEx(hKey, SubKeyName, _
0, REG_SZ, _
SubKeyValue, LenB(StrConv(SubKeyValue, vbFromUnicode)))
If (rc <> ERROR_SUCCESS) Then GoTo CreateKeyError ' Fehler behandeln
'------------------------------------------------------------
'- Registrierungsschl?ssel schlie?en...
'------------------------------------------------------------
rc = RegCloseKey(hKey) ' Schl?ssel schlie?en
UpdateKey = True ' Erfolgreiche Ausf?hrung zur?ckgeben
Exit Function ' Beenden
CreateKeyError:
UpdateKey = False ' Fehlerr?ckgabe-Code festlegen
rc = RegCloseKey(hKey) ' Versuchen, den Schl?ssel zu schlie?en
End Function
'-------------------------------------------------------------------------------------------------
'Verwendungsbeispiel - Debug.Print GetKeyValue(HKEY_CLASSES_ROOT, "COMCTL.ListviewCtrl.1\CLSID", "")
'-------------------------------------------------------------------------------------------------
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String) As String
Dim i As Long ' Schleifenz?hler
Dim rc As Long ' R?ckgabe-Code
Dim hKey As Long ' Zugriffsnummer f?r einen offenen Registrierungsschl?ssel
Dim hDepth As Long '
Dim sKeyVal As String
Dim lKeyValType As Long ' Datentyp eines Registrierungsschl?ssels
Dim tmpVal As String ' Tempor?rer Speicher eines Registrierungsschl?sselwertes
Dim KeyValSize As Long ' Gr??e einer Registrierungsschl?sselvariablen
' Registrierungsschl?ssel unter dem Stamm {HKEY_LOCAL_MACHINE...} ?ffnen
'------------------------------------------------------------
rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' Registrierungsschl?ssel ?ffnen
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Fehler behandeln...
tmpVal = String$(1024, 0) ' Platz f?r Variable reservieren
KeyValSize = 1024 ' Gr??e der Variable markieren
'------------------------------------------------------------
' Registrierungsschl?sselwert abrufen...
'------------------------------------------------------------
rc = RegQueryValueEx(hKey, SubKeyRef, 0, _
lKeyValType, tmpVal, KeyValSize) ' Schl?sselwert abrufen/erstellen
If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError ' Fehler behandeln
tmpVal = Left$(tmpVal, InStr(tmpVal, Chr(0)) - 1)
'------------------------------------------------------------
' Schl?sselwerttyp f?r Konvertierung bestimmen...
'------------------------------------------------------------
Select Case lKeyValType ' Datentypen durchsuchen...
Case REG_SZ, REG_EXPAND_SZ ' Zeichenfolge f?r Registrierungsschl?sseldatentyp
sKeyVal = tmpVal ' Zeichenfolgenwert kopieren
Case REG_DWORD ' Registrierungsschl?sseldatentyp DWORD
For i = Len(tmpVal) To 1 Step -1 ' Jedes Bit konvertieren
sKeyVal = sKeyVal + Hex(Asc(Mid(tmpVal, i, 1))) ' Wert Zeichen f?r Zeichen erstellen
Next
sKeyVal = Format$("&h" + sKeyVal) ' DWORD in Zeichenfolge konvertieren
End Select
GetKeyValue = sKeyVal ' Wert zur?ckgeben
rc = RegCloseKey(hKey) ' Registrierungsschl?ssel schlie?en
Exit Function ' Beenden
GetKeyError: ' Bereinigen, nachdem ein Fehler aufgetreten ist...
GetKeyValue = vbNullString ' R?ckgabewert auf leere Zeichenfolge setzen
rc = RegCloseKey(hKey) ' Registrierungsschl?ssel schlie?en
End Function
-
Hallo!
Gibt es als m?glichkeit eigentlich ein Upload von Dateien? Dann h?tte ich mir all diese Posts sparen k?nnen und es alles nur in einem Post hochladen k?nnen. W?r' f?rs Programmieren auch einfacher!
Mfg
Meme -
Diskutiere mit und stelle Fragen: Jetzt kostenlos anmelden!
lima-city: Gratis werbefreier Webspace für deine eigene Homepage