vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
TOP-Angebot: 17 bzw. 24 Entwickler-Vollversionen zum unschlagbaren Preis!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: System/Windows · Desktop/Bildschirm/Display   |   VB-Versionen: VB626.09.05
JPEGs als Wallpapers

Mit IActiveDesktop können auch JPEGs als Wallpapers genommen werden

Autor:   Arne ElsterBewertung:     [ Jetzt bewerten ]Views:  10.812 
actorics.de/rm_codeSystem:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 Beispielprojekt auf CD 

Der weitverbreitete Tipp zum Setzen eines Wallpapers per SystemParametersInfo() hat einen Nachteil: Er erlaubt nur BMPs.

Der Active Desktop macht es da besser; er unterstützt mehrere Formate, u.a. JPEGs und GIFs. Allerdings gibt's den Active Desktop nur in der COM Variante, besser gesagt, als Interface. Und hier bockt VB, es unterstützt nur Interfaces, die es kennt oder die per Type Lib definiert wurden. Mit ein wenig Getrickse lässt sich das aber aushebeln. Als "Objekt", das das IActiveDesktop Interface aufnimmt, nehmen wir einfach einen Long, klauen uns über den die VTable des Interfaces und rufen die gewünschten Funktionen SetWallpaper() und ApplyChanges() mit Hilfe von ein wenig Assembler auf.

Modul modWallpaper

Option Explicit
 
' Benötigte API-Deklarationen
Private Declare Function IIDFromString Lib "ole32" ( _
  ByVal lpszIID As Long, _
  iid As Any) As Long
 
Private Declare Function CoCreateInstance Lib "ole32" ( _
  rclsid As Any, _
  ByVal pUnkOuter As Long, _
  ByVal dwClsContext As Long, _
  riid As Any, _
  ByVal ppv As Long) As Long
 
Private Declare Function CallWindowProcA Lib "user32" ( _
  ByVal addr As Long, _
  ByVal p1 As Long, _
  ByVal p2 As Long, _
  ByVal p3 As Long, _
  ByVal p4 As Long) As Long
 
Private Declare Sub RtlMoveMemory Lib "kernel32" ( _
  pDst As Any, _
  pSrc As Any, _
  ByVal dlen As Long)
 
Private Const CLSCTX_INPROC_SERVER  As Long = 1&
Private Const CLSID_ActiveDesktop   As String = _
  "{75048700-EF1F-11D0-9888-006097DEACF9}"
 
Private Type GUID
  data1                   As Long
  data2                   As Integer
  data3                   As Integer
  data4(7)                As Byte
End Type
 
Private Type IActiveDesktop
  ' IUnknown
  QueryInterface          As Long
  AddRef                  As Long
  Release                 As Long
  ' IActiveDesktop
  ApplyChanges            As Long
  GetWallpaper            As Long
  SetWallpaper            As Long
  GetWallpaperOptions     As Long
  SetWallpaperOptions     As Long
  GetPattern              As Long
  SetPattern              As Long
  GetDesktopItemOptions   As Long
  SetDesktopItemOptions   As Long
  AddDesktopItem          As Long
  AddDesktopItemWithUI    As Long
  ModifyDesktopItem       As Long
  RemoveDesktopItem       As Long
  GetDesktopItemCount     As Long
  GetDesktopItem          As Long
  GetDesktopItemByID      As Long
  GenerateDesktopItemHtml As Long
  AddUrl                  As Long
  GetDesktopItemBySource  As Long
End Type
 
Private Enum AD_APPLY
  AD_APPLY_SAVE = &H1
  AD_APPLY_HTMLGEN = &H2
  AD_APPLY_REFRESH = &H4
  AD_APPLY_ALL = &H7
  AD_APPLY_FORCE = &H8
  AD_APPLY_BUFFERED_REFRESH = &H10
  AD_APPLY_DYNAMICREFRESH = &H20
End Enum
Public Function ActiveDesktopSetWallpaper( _
  ByVal strFile As String) As Boolean
 
  Dim vtbl         As IActiveDesktop
  Dim vtblptr      As Long
 
  Dim classid      As GUID
  Dim IID_IUnknown As GUID
 
  Dim obj          As Long
  Dim hRes         As Long
 
  With IID_IUnknown
    .data4(0) = &HC0
    .data4(7) = &H46
  End With
 
  ' CLSID String in Struktur umschiffen
  hRes = IIDFromString(StrPtr(CLSID_ActiveDesktop), classid)
  If hRes <> 0 Then
    Debug.Print "Konnte String nicht in IID umwandeln"
    Exit Function
  End If
 
  ' IActiveDesktop Instanz erstellen
  hRes = CoCreateInstance(classid, 0, &H1, IID_IUnknown, VarPtr(obj))
  If hRes <> 0 Then
    Debug.Print "Konnte IActiveDesktop Instanz nicht erstellen"
    Exit Function
  End If
 
  ' VTable von Instanz kopieren
  RtlMoveMemory vtblptr, ByVal obj, 4
  RtlMoveMemory vtbl, ByVal vtblptr, Len(vtbl)
 
  ' SetWallpaper aus VTable aufrufen
  hRes = CallPointer(vtbl.SetWallpaper, obj, StrPtr(strFile), 0)
  If hRes <> 0 Then
    Debug.Print "Konnte neues Wallpaper nicht setzen"
  Else
    ActiveDesktopSetWallpaper = True
  End If
 
  ' ApplyChanges aus VTable aufrufen
  hRes = CallPointer(vtbl.ApplyChanges, obj, AD_APPLY_ALL Or AD_APPLY_FORCE)
  If hRes <> 0 Then
    Debug.Print "Konnte Desktop nicht aktualisieren"
  End If
 
  ' Instanz zerstören
  CallPointer vtbl.Release, obj
End Function
Private Function CallPointer(ByVal fnc As Long, ParamArray params()) As Long
  Dim btASM(&HEC00& - 1)  As Byte
  Dim pASM                As Long
  Dim i                   As Integer
 
  pASM = VarPtr(btASM(0))
 
  AddByte pASM, &H58                  ' POP EAX
  AddByte pASM, &H59                  ' POP ECX
  AddByte pASM, &H59                  ' POP ECX
  AddByte pASM, &H59                  ' POP ECX
  AddByte pASM, &H59                  ' POP ECX
  AddByte pASM, &H50                  ' PUSH EAX
 
  For i = UBound(params) To 0 Step -1
    AddPush pASM, CLng(params(i))     ' PUSH dword
  Next
 
  AddCall pASM, fnc                   ' CALL rel addr
  AddByte pASM, &HC3                  ' RET
 
  CallPointer = CallWindowProcA(VarPtr(btASM(0)), 0, 0, 0, 0)
End Function
Private Sub AddPush(pASM As Long, lng As Long)
  AddByte pASM, &H68
  AddLong pASM, lng
End Sub
Private Sub AddCall(pASM As Long, addr As Long)
  AddByte pASM, &HE8
  AddLong pASM, addr - pASM - 4
End Sub
Private Sub AddLong(pASM As Long, lng As Long)
  RtlMoveMemory ByVal pASM, lng, 4
  pASM = pASM + 4
End Sub
Private Sub AddByte(pASM As Long, bt As Byte)
  RtlMoveMemory ByVal pASM, bt, 1
  pASM = pASM + 1
End Sub

Code zum Testen:

If ActiveDesktopSetWallpaper("C:\wallpaper.jpg") Then
  MsgBox "Neues Wallpaper erfolgreich gesetzt"
Else
  MsgBox "Konnte neues Wallpaper nicht setzen"
End If

Dieser Tipp wurde bereits 10.812 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel