Wallpaper Mover - Desktop Hintergrundbild verschieben

Desktop Hintergrundbild verschieben mit VBA

Registry bearbeiten, Dateieigenschaften auslesen

ScreenResulotion auslesen, Windows Script Host

Userform anzeigen und Excel dabei minimieren

Cursor in Userform bestimmen und vieles mehr...

Mit Excel ist beinahe alles möglich. Will heißen: Was der Rechner kann, das kann Excel auch. Wir können Anwendungen entwickeln, die mit der eigentlichen Aufgabe von Excel gar nichts mehr zu tun haben und diese auch noch so aussehen lassen, dass man von Excel im Hintergrund fast gar nichts mehr mitbekommt.
    Das hier vorliegende Beispiel gibt uns einen kleinen Eindruck davon. Es soll das Desktop Hintergrundbild in die gewünschte Position bringen und legt zu diesem Zweck zwei neue Schlüssel in der Registry an, bzw. verändert ihre Werte, wenn sie bereits vorhanden sind. Im Prinzip ist das schon alles. Aber damit wir die neue Position nicht umständlich von Hand ausrechnen müssen, übernimmt das Programm auch noch diese Aufgabe und läßt uns wählen zwischen fünf Standard-Positionen (oben links und rechts, unten links und rechts sowie zentriert), inkremental verschieben um eine frei wählbare Anzahl Pixel und eine frei wählbare absolute Position, die wir uns selber ausgerechnet haben.

    Die Arbeitsmappe verfährt dabei zweigleisig: die Einstellungen können in Tabelle1 vorgenommen und ausgeführt werden, oder es kann alternativ die zugehörige UserForm gestartet werden. Diese minimiert dann beim Aufruf Excel und bleibt selber im im Vordergrund, so dass eine freie Sicht auf den Desktop bei der Ausführung gegeben ist. Das ist hilfreich, um die neue Position auch sofort sehen zu können.
    Ach ja, bevor ich es vergesse: vor dem Positionieren des Hintergrundbildes mit diesem VBA-Programm muss natürlich eines vorhanden sein. Das bedeutet unter Rechtsklick auf leeren Desktop, dann "Eigenschaften/Desktop/durchsuchen eines auszuwählen.

Natürlich würde das auch gehen, wenn wir Excel so weit verkleinern, bis nur noch die wenigen Eingabezellen und CommandButtons zu sehen sind. Dennoch ist die UserForm besser, weil sie noch kleiner ist und somit mehr Sicht auf den Desktop ermöglicht und ausserdem auch schneller, weil wir nicht erst umständlich das Excel-Fenster verkleinern müssen.
Wer gleich beim Start der Arbeitsmappe nur die Userform sehen will, der kann das kleine Makro in "DieseArbeitsmappe" aktivieren, indem er die Auskommentierung entfernt.

Achtung: Dieses Programm ändert die Registryschlüssel
WallpaperOriginX und WallpaperOriginY in
HKEY_CURRENT_USER\Control Panel\Desktop\ bzw. legt diese neu an. Beim Arbeiten an der Registry empfiehlt es sich stets, vorher ein Backup davon zu machen. Die Benutzung dieses Programmes geschieht auf eigene Gefahr
Der CommandButton "Zentrieren" zentriert das Hintergrundbild und stellt außerdem den Windows-Standard wieder her, indem er die neu angelegten Schlüssel wieder löscht.

Modul 1 Modul 2 CommandButtons Alternative Startmöglichkeit

Hier gibts die ganze Arbeitsmappe zum Download als Zip (49KB), hier ein Hintergrundbild (88KB), welches sich gut für "unten rechts" eignet, und hier das gleiche Bild noch einmal kleiner: kleines Bild (43KB). Diese "Lady" haben wir sicher alle schon mal gesehen ^^.

Screenshot UserForm

Screenshot Tabelle1

Option Explicit
'****************************************************************
' das ist um zur Laufzeit der Userform Excel zu minimieren
' und die Userform trotzdem offen und im Vordergrung zu halten
' gefunden auf http://www.vb-fun.de
Private Declare Function FindWindow Lib "user32" Alias _
      "FindWindowA" (ByVal lpClassName As String, ByVal _
      lpWindowName As String) As Long

Private Declare Function EnableWindow Lib "user32" (ByVal _
      hWnd As Long, ByVal fEnable As Long) As Long
'****************************************************************
' das ist für die Cursersteuerung des Hyperlinks in der Userform
' gefunden auf http://www.office-loesung.de
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" ( _
    ByVal hInstance As Long, _
    ByVal lpCursorName As Long) As Long

    Private Const HandCursor = 32649&
'****************************************************************
'weitere Quellen:
' Windows API Referenz von Dieter Otter: http://www.vbarchiv.net/api/index.php
' http://www.vb-fun.de/cgi-bin/loadframe.pl?ID=vb/tipps/tip0168.shtml
' Sebastian Koch`s Windows Scripting Host Seite, auf der ich viel gelernt habe:
' http://www.quaschtel.de/wsh/


Private Sub HSWPM_Activate()
  Dim hwndForm As Long

  If Left$(Application.Version, 1) = 8 Then
     hwndForm = FindWindow("XLMAIN", vbNullString)
     If hwndForm <> 0 Then
        EnableWindow hwndForm, True

        SendKeys "{Esc}"
        Application.Dialogs(xlDialogShowToolbar).Show
     End If
  End If
End Sub

Private Sub CommandButton1_Click()
    If testNumeric(TextBox3) = False Then Exit Sub
    If TextBox3.Value <> "" And TextBox3.Value <> 0 Then
      TextBox3.Value = Int(TextBox3.Value)
      Worksheets(1).Range("B2").Value = TextBox3.Value
      Verschieben ("ML")
    End If
End Sub

Private Sub CommandButton2_Click()
    If testNumeric(TextBox3) = False Then Exit Sub
    If TextBox3.Value <> "" And TextBox3.Value <> 0 Then
      TextBox3.Value = Int(TextBox3.Value)
      Worksheets(1).Range("B2").Value = TextBox3.Value
      Verschieben ("MR")
    End If
End Sub

Private Sub CommandButton3_Click()
    If testNumeric(TextBox3) = False Then Exit Sub
    If TextBox3.Value <> "" And TextBox3.Value <> 0 Then
      TextBox3.Value = Int(TextBox3.Value)
      Worksheets(1).Range("B2").Value = TextBox3.Value
      Verschieben ("MAUF")
    End If
End Sub

Private Sub CommandButton4_Click()
    If testNumeric(TextBox3) = False Then Exit Sub
    If TextBox3.Value <> "" And TextBox3.Value <> 0 Then
      TextBox3.Value = Int(TextBox3.Value)
      Worksheets(1).Range("B2").Value = TextBox3.Value
      Verschieben ("MAB")
    End If
End Sub

Private Sub CommandButton5_Click()
    Verschieben ("OL")
End Sub

Private Sub CommandButton6_Click()
    Verschieben ("OR")
End Sub

Private Sub CommandButton7_Click()
    Verschieben ("UL")
End Sub

Private Sub CommandButton8_Click()
    Verschieben ("UR")
End Sub

Private Sub CommandButton9_Click()
    Zentrieren
End Sub

Private Sub CommandButton10_Click()
    If testNumeric(TextBox1) = False Then Exit Sub
    If testNumeric(TextBox2) = False Then Exit Sub
    If TextBox1.Value <> "" Then TextBox1.Value = Int(TextBox1.Value)
    If TextBox2.Value <> "" Then TextBox2.Value = Int(TextBox2.Value)
    Worksheets(1).Range("B13").Value = TextBox1.Value
    Worksheets(1).Range("B14").Value = TextBox2.Value
    Verschieben ("ABS")
End Sub

Private Sub Label6_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
    ByVal X As Single, ByVal Y As Single)
    'gefunden in http://www.office-loesung.de
    Dim hWnd As Long
    hWnd = LoadCursor(0, HandCursor)
    If (hWnd > 0) Then SetCursor hWnd
End Sub

Private Sub Label6_Click()
ThisWorkbook.FollowHyperlink "http://www.scheidgen.de"
End Sub

Private Sub Label8_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
    ByVal X As Single, ByVal Y As Single)
    'gefunden in http://www.office-loesung.de
    Dim hWnd As Long
    hWnd = LoadCursor(0, HandCursor)
    If (hWnd > 0) Then SetCursor hWnd
End Sub

Private Sub Label8_Click()
    Dim lPixelH As Long, lPixelV As Long
    Call Wallpaper_Size(lPixelH, lPixelV)
    Label8.Caption = "CurPictureSize" & Chr(13) & lPixelH & " x " & lPixelV
End Sub

Private Sub UserForm_Initialize()
    Dim lHSize As Long 'horizontale Bildschirmauflösung
    Dim lVSize As Long 'vertikale Bildschirmauflösung
    Dim lPixelH As Long, lPixelV As Long 'Größe des Hintergrundbildes
    Call ScreenResolution(lHSize, lVSize)
    Label7.Caption = "CurScreenSize" & Chr(13) & lHSize & " x " & lVSize
    Call Wallpaper_Size(lPixelH, lPixelV)
    Label8.Caption = "CurPictureSize" & Chr(13) & lPixelH & " x " & lPixelV
End Sub

'Private Sub UserForm_Terminate()
    'Workbooks("Hintergrundbild verschieben.xls").Close savechanges:=False
'End Sub

Function testNumeric(InputWert) As Boolean
    Dim Meldung
    If IsNumeric(InputWert) = True Or InputWert = "" Then
        testNumeric = True
    Else
        testNumeric = False
        Meldung = MsgBox("IsNumeric Test for InputBox = False" & Chr(13) _
        & "Please insert a numeric Value", , "IsNumericTest Message")
        InputWert.Value = ""
        Worksheets(1).Range("B2").Value = TextBox3.Value
    End If
End Function

Modul 1

nach oben

Option Explicit

Sub Verschieben(Vorgabe As String)
    Dim lHSize As Long                    'horizontale Bildschirmauflösung
    Dim lVSize As Long                    'vertikale Bildschirmauflösung
    Dim lPixelH As Long, lPixelV As Long  'Bildbreite- und Höhe     
    Dim lnewPosH As Long                  'neue X-Position        
    Dim lnewPosV As Long                  'neue Y-Position          
    Dim myNewRegKeyX As String            'selbsterklärend             
    Dim myNewRegKeyY As String            'selbsterklärend            
    Dim myWSH As Object

    Set myWSH = CreateObject("WScript.Shell")

    Call ScreenResolution(lHSize, lVSize)
    Call Wallpaper_Size(lPixelH, lPixelV)

    myNewRegKeyX = "HKEY_CURRENT_USER\Control Panel\Desktop\WallpaperOriginX"
    myNewRegKeyY = "HKEY_CURRENT_USER\Control Panel\Desktop\WallpaperOriginY"

    Select Case Vorgabe
        Case Is = "UR"
            lnewPosH = lHSize - lPixelH
            lnewPosV = lVSize - lPixelV
        Case Is = "UL"
            lnewPosH = 1
            lnewPosV = lVSize - lPixelV
        Case Is = "OL"
            lnewPosH = 1
            lnewPosV = 1
        Case Is = "OR"
            lnewPosH = lHSize - lPixelH
            lnewPosV = 1
        Case Is = "ML"
            Call Schluessel_lesen(lnewPosH, lnewPosV, lHSize, lVSize, lPixelH, lPixelV)
            lnewPosH = lnewPosH - Worksheets(1).Range("B2").Value
        Case Is = "MR"
            Call Schluessel_lesen(lnewPosH, lnewPosV, lHSize, lVSize, lPixelH, lPixelV)
            lnewPosH = lnewPosH + Worksheets(1).Range("B2").Value
        Case Is = "MAUF"
            Call Schluessel_lesen(lnewPosH, lnewPosV, lHSize, lVSize, lPixelH, lPixelV)
            lnewPosV = lnewPosV - Worksheets(1).Range("B2").Value
        Case Is = "MAB"
            Call Schluessel_lesen(lnewPosH, lnewPosV, lHSize, lVSize, lPixelH, lPixelV)
            lnewPosV = lnewPosV + Worksheets(1).Range("B2").Value
        Case Is = "ABS"
            Call Schluessel_lesen(lnewPosH, lnewPosV, lHSize, lVSize, lPixelH, lPixelV)
            lnewPosH = Worksheets(1).Range("B13").Value
            lnewPosV = Worksheets(1).Range("B14").Value
    End Select

    Call Schluessel_anlegen(myNewRegKeyX, lnewPosH)
    Call Schluessel_anlegen(myNewRegKeyY, lnewPosV)
    Call Kontrolle(lHSize, lVSize, lPixelH, lPixelV, lnewPosH, lnewPosV)

    myWSH.Run "%windir%\System32\RUNDLL32.EXE user32.dll,UpdatePerUserSystemParameters", 1, True
    Set myWSH = Nothing

End Sub

Sub Zentrieren()
    'dieses Programm zentriert das Hintergrundbild und
    'setzt alle Wallpaper-Einstellungen in der Registry
    'auf die Windows-Defaults zurück.
    Dim myNewRegKey As String
    Dim myNewValue As Integer
    Dim lHSize As Long 'horizontale Bildschirmauflösung
    Dim lVSize As Long 'vertikale Bildschirmauflösung
    Dim lPixelH As Long, lPixelV As Long 'Bildbreite- und Höhe  
    Dim myWSH As Object

    Set myWSH = CreateObject("WScript.Shell")

    Call ScreenResolution(lHSize, lVSize)
    Call Wallpaper_Size(lPixelH, lPixelV)

    myNewRegKey = "HKEY_CURRENT_USER\Control Panel\Desktop\WallpaperOriginX"
    Call Schluessel_loeschen(myNewRegKey)

    myNewRegKey = "HKEY_CURRENT_USER\Control Panel\Desktop\WallpaperOriginY"
    Call Schluessel_loeschen(myNewRegKey)

    'zur Info:
    'TileWallpaper   1 = gekachelt,  0 = zentriert
    'WallpaperStyle  2 = auf desktop vergrößert, ansonsten 0

    myNewRegKey = "HKEY_CURRENT_USER\Control Panel\Desktop\TileWallpaper"
    myNewValue = 0
    Call Schluessel_anlegen(myNewRegKey, myNewValue)

    myNewRegKey = "HKEY_CURRENT_USER\Control Panel\Desktop\WallpaperStyle"
    myNewValue = 0
    Call Schluessel_anlegen(myNewRegKey, myNewValue)

    Call Kontrolle(lHSize, lVSize, lPixelH, lPixelV, "zentriert", "zentriert")

    myWSH.Run "%windir%\System32\RUNDLL32.EXE user32.dll,UpdatePerUserSystemParameters", 1, True
    Set myWSH = Nothing
End Sub

Public Sub WPM_anzeigen()
  With Application
    .WindowState = xlMinimized
  End With

  #If VBA6 Then
    HSWPM.Show vbModeless
  #Else
    HSWPM.Show
  #End If
End Sub

Modul 2

nach oben

Option Explicit

'**********************Function ScreenResolution****************************
'das wird für das Auslesen der Sreenresulotion benötigt (gefunden bei Herber)
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
    ByVal nIndex As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
    ByVal hdc As Long) As Long

Const HORZRES = 8
Const VERTRES = 10
'**********************Function ScreenResolution****************************

Sub Schluessel_anlegen(newRegKey, newValue)
Dim myWSH As Object
    Set myWSH = CreateObject("WScript.Shell")
    myWSH.regWrite newRegKey, newValue
    Set myWSH = Nothing
End Sub

Sub Schluessel_loeschen(newRegKey)
Dim myWSH As Object
    On Error Resume Next
    Set myWSH = CreateObject("WScript.Shell")
    myWSH.regdelete newRegKey
    Set myWSH = Nothing
End Sub

Sub Schluessel_lesen(lPosH, lPosV, lHSize, lVSize, lPixelH, lPixelV)
    Dim myWSH As Object, RegKeyX As String, RegKeyY As String
    Dim Schluesselexist As Boolean

    Set myWSH = CreateObject("WScript.Shell")
    Schluesselexist = True
    RegKeyX = "HKEY_CURRENT_USER\Control Panel\Desktop\WallpaperOriginX"
    RegKeyY = "HKEY_CURRENT_USER\Control Panel\Desktop\WallpaperOriginY"

    On Error GoTo Fehler

    lPosH = myWSH.RegRead(RegKeyX)
    If Schluesselexist = False Then 'dann Schlüssel und Wert anlegen
        lPosH = Int((lHSize - lPixelH) / 2)
        Call Schluessel_anlegen(RegKeyX, lPosH)
        Schluesselexist = True
    End If

    lPosV = myWSH.RegRead(RegKeyY)
    If Schluesselexist = False Then 'dann Schlüssel und Wert anlegen
        lPosV = Int((lVSize - lPixelV) / 2)
        Call Schluessel_anlegen(RegKeyY, lPosV)
        Schluesselexist = True
    End If

    Set myWSH = Nothing
    Exit Sub

    Fehler:
        'MsgBox ("Der Registrierungsschlüssel" & Chr(13) _
        '& "wurde nicht gefunden und wird neu angelegt")
        Schluesselexist = False
        Resume Next
End Sub

Sub Wallpaper_Size(lPixelH, lPixelV) ' FileProp(varFolder, varFile, iNr%)
    'Ermitteln der Breite und Höhe der aktiven Wallpaperdatei
    'durch Lesen der Dateieigenschaften.
    'Dazu wird in der Registry nachgesehen, welche Datei das ist
    'und wo sie sich befindet.

    Dim myWSH As Object
    Dim RegKeyCW As String          'Registryschlüssel "Wallpaper"
    Dim currentRegValueCW As String 'Pfad und Dateiname zur Wallpaperdatei
    Dim varFolder As Variant        'Pfad zur Wallpaperdatei
    Dim varFile As Variant          'Dateiname der Wallpapergrafik
    Dim objFolder As Object         'Dateiordner als Objekt
    Dim FileProp As String          'Dateieigenschaft (hier: "Abmessung")
    Dim Y As Integer                'Position des letzten Backslash in "currentRegValueCW"
    Dim I As Integer                'Schleifenzähler zum Ermitteln der letzten Backslash-Position

    Set myWSH = CreateObject("WScript.Shell")

    'Lesen des Pfades und des Namens der Wallpapergrafik aus der Registry:
    RegKeyCW = "HKEY_CURRENT_USER\Control Panel\Desktop\Wallpaper"
    currentRegValueCW = myWSH.RegRead(RegKeyCW)

    'Position des letzten Backslash in der Variable
    '"currentRegValueCW" ermitteln:
    'For I = 1 To Len(currentRegValueCW)
    '    If Mid(currentRegValueCW, I, 1) = "\" Then
    '       Y = I
    '    End If
    'Next
    ' aber das geht ja auch leichter ^^ :
    Y = InStrRev(currentRegValueCW, "\")

    'Auftrennen des Registrywertes "currentRegValueCW" in Pfad und Datei:
    varFile = Right(currentRegValueCW, Len(currentRegValueCW) - Y)
    varFolder = Left(currentRegValueCW, Y - 1)
    'varFile = "Ruby ATI-02.jpg"
    'varFolder = "C:\Dokumente und Einstellungen\scheihu\Eigene Dateien\Eigene Bilder"

    Set objFolder = CreateObject("Shell.Application").Namespace(varFolder)

    'Lesen der Dateieigenschaft "Abmessung" und Auftrennen in Breite und Höhe
    FileProp = objFolder.GetDetailsOf(objFolder.Items.Item(varFile), 26)
    lPixelH = Left(FileProp, InStr(1, UCase(FileProp), " X ") - 1) * 1
    lPixelV = Right(FileProp, Len(FileProp) - InStr(1, UCase(FileProp), " X ") - 2) * 1

    Set objFolder = Nothing
    Set myWSH = Nothing
End Sub

Function ScreenResolution(lHSize, lVSize)
   Dim lRval As Long
   Dim lDc As Long
'   Dim lHSize As Long
'   Dim lVSize As Long
   lDc = GetDC(0&)
   lHSize = GetDeviceCaps(lDc, HORZRES)
   lVSize = GetDeviceCaps(lDc, VERTRES)
   lRval = ReleaseDC(0, lDc)
   'ScreenResolution = lHSize & "x" & lVSize
End Function

Sub Kontrolle(lHSize, lVSize, lPixelH, lPixelV, lnewPosH, lnewPosV)
' falls etwas nicht funktioniert, kann man hier Kontrollwerte
' ins Tabellenblatt schreiben lassen
'        Worksheets(2).Range("A1").Value = "Bildschirmauflösung X"
'        Worksheets(2).Range("A2").Value = "Bildschirmauflösung Y"
'        Worksheets(2).Range("B1").Value = lHSize
'        Worksheets(2).Range("B2").Value = lVSize
'
'        Worksheets(2).Range("A3").Value = "Größe Wallpaper X"
'        Worksheets(2).Range("A4").Value = "Größe Wallpaper Y"
'        Worksheets(2).Range("B3").Value = lPixelH
'        Worksheets(2).Range("B4").Value = lPixelV
'
'        Worksheets(2).Range("A6").Value = "Neue X Position"
'        Worksheets(2).Range("A7").Value = "Neue Y Position"
'        Worksheets(2).Range("B6").Value = lnewPosH
'        Worksheets(2).Range("B7").Value = lnewPosV
End Sub

CommandButtons in Tabelle1

nach oben

Private Sub CommandButton1_Click()
    Verschieben ("UR")
End Sub

Private Sub CommandButton10_Click()
    Verschieben ("ABS")
End Sub>

Private Sub CommandButton11_Click()
    WPM_anzeigen
End Sub

Private Sub CommandButton2_Click()
    Zentrieren
End Sub

Private Sub CommandButton3_Click()
    Verschieben ("UL")
End Sub

Private Sub CommandButton4_Click()
    Verschieben ("OR")
End Sub

Private Sub CommandButton5_Click()
    Verschieben ("OL")
End Sub

Private Sub CommandButton6_Click()
    Verschieben ("ML")
End Sub

Private Sub CommandButton7_Click()
    Verschieben ("MR")
End Sub

Private Sub CommandButton8_Click()
    Verschieben ("MAUF")
End Sub

Private Sub CommandButton9_Click()
    Verschieben ("MAB")
End Sub

Alternative Startmöglichkeit

nach oben

'Private Sub Workbook_Open()
''  soll Excel beim Start der WallpaperMover Arbeitsmappe sofort minimiert
''  und die UserForm in den Vordergrund gebracht werden, empfiehlt es sich
''  diesen Code in das Codefenster von "DieseArbeitsmappe zu kopieren und
''  zu aktivieren. Dann ist gar nicht mehr zu sehen, dass Excel dabei im
''  Spiel ist.

'   With Application
'     .WindowState = xlMinimized
'   End With
'
'
'   #If VBA6 Then
'     HSWPM.Show vbModeless
'   #Else
'     HSWPM.Show
'   #End If
'End Sub