هر تصویر یا فایل دارای خروجی رو جای پس زمینه دسکتاپ قرار دهید!

[moslem-visual]

سلام، من روی یه پروژه کار میکردم که بخشی از اون باید اطلاعات اچ تی ام ال رو به جای تصویر دستتاپ دتکت میکرد، خیلی اینور و انور گشتم تا بلاخره از یه سایت استرالیایی این قطعه کد رو گیر آواردم که میتونه انواع تصاویر JPG,BMP,Gif و ... رو به اضافه ی اسناد HTML و بعضی دیگه که من ازشون سر در نیاوردم رو جایگزین تصویر دستکتاپ کنه، در واقع در محیط کاربری ویندوز دست میبره، یه نکته هم اینکه بعد از اعمال این کد، نمیتونید از طریق properties دستکتاپ پس زمینه رو تغییر بددید ، برای انجام اینکار باید روی تصویر مورد نظر راست کلیک و set as wallpaper رو انتخاب کنید.

این کد شامل دو بخش هست که بخش اول رو در یک ماژول دلخواه و بخش دوم رو در فرمتون مینویسید (خودتون باهاش کار کنید)، مخصوص نسخه ی 6 وی بی :افسرده: :


Module1.BAS -------

Option Explicit

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 Const IID_ActiveDesktop As String = "{F490EB00-1240-11D1-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 As GUID

Dim obj As Long
Dim hRes As Long

' CLSID (BSTR) to CLSID (GUID)
hRes = IIDFromString(StrPtr(CLSID_ActiveDesktop), classid)
If hRes <> 0 Then
Exit Function
End If

' IID (BSTR) to IID (GUID)
hRes = IIDFromString(StrPtr(IID_ActiveDesktop), iid)
If hRes <> 0 Then
Exit Function
End If

' create an instance of IActiveDesktop
' (Set IActiveDesktop = New IActiveDesktop)
hRes = CoCreateInstance(classid, 0, CLSCTX_INPROC_SERVER, iid, VarPtr(obj))
If hRes <> 0 Then
Exit Function
End If

' obj points now to a pointer to the VTable
' of IActiveDesktop
'
' dereference the VTable pointer
RtlMoveMemory vtblptr, ByVal obj, 4
' copy the VTable to our IActiveDesktop structure
RtlMoveMemory vtbl, ByVal vtblptr, Len(vtbl)

' call IActiveDesktop::SetWallpaper
'
' the first parameter is always the object pointer
' the return value should always be a HRESULT (0 = S_OK)
hRes = CallPointer(vtbl.SetWallpaper, obj, StrPtr(strFile), 0)
If hRes = 0 Then
ActiveDesktopSetWallpaper = True
End If

' call IActiveDesktop::ApplyChanges
hRes = CallPointer(vtbl.ApplyChanges, obj, AD_APPLY_ALL Or AD_APPLY_FORCE)

' release IActiveDesktop to free memory
' (Set IActiveDesktop = Nothing)
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





'--------- Form1 -------------

If ActiveDesktopSetWallpaper("C:\Program Files\Yahoo!\Messenger\nofriend.html") Then
MsgBox "Successfully set new wallpaper"
Else
MsgBox "Failed to set new wallpaper"
End If