AW: Verknüpfung auf Desktop-Bild selbst wählen
23.02.2010 19:58:55
Nepumuk
Hallo,
füg mal in deine Mappe ein Userform (Userform1) ein mit einem Image-Control. In das Image-Control ein belibiges (aber nicht zu großes) Bild. Benutzen kannst du alle Formate, nur kein Icon (.ico). Denn das bekomme ich nicht aus dem Clipboard.
Folgender Code in ein Standardmodul:
Option Explicit
Private Declare Function CopyImage Lib "user32.dll" ( _
ByVal handle As Long, _
ByVal imageType As Long, _
ByVal newWidth As Long, _
ByVal newHeight As Long, _
ByVal lFlags As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function SetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long, _
ByVal hMem As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" ( _
ByVal hObject As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
ByRef PicDesc As uPicDesc, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) As Long
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
lngSize As Long
lngType As Long
lnghPic As Long
lnghPal As Long
End Type
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const PICTYPE_BITMAP = 1
Private Const FOLDER_NAME = "C:\TEMP\"
Private Const FILE_NAME = "Image.ico"
Public Sub Create_Link()
Dim objPicture As Object, objWSH As Object, objLink As Object
Dim lngReturn As Long, lngTempPicture As Long
Dim strDesktop As String
Set objWSH = CreateObject("WScript.Shell")
strDesktop = objWSH.SpecialFolders("Desktop")
Set objLink = objWSH.CreateShortcut(strDesktop & "\" & _
Left$(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & ".lnk")
With objLink
.Targetpath = ThisWorkbook.FullName
.WorkingDirectory = ThisWorkbook.Path
.Hotkey = "CTRL+SHIFT+S"
.WindowStyle = vbMaximizedFocus
lngTempPicture = CopyImage(UserForm1.Image1.Picture, _
IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
If lngTempPicture <> 0 Then
Call OpenClipboard(Application.hWnd)
Call EmptyClipboard
Call SetClipboardData(CF_BITMAP, lngTempPicture)
Call CloseClipboard
Call DeleteObject(lngTempPicture)
Set objPicture = Create_Picture(lngTempPicture, 0, CF_BITMAP)
If Not objPicture Is Nothing Then
lngReturn = MakeSureDirectoryPathExists(FOLDER_NAME)
If lngReturn <> 0 Then
stdole.StdFunctions.SavePicture objPicture, FOLDER_NAME & FILE_NAME
.IconLocation = FOLDER_NAME & FILE_NAME
Else
.IconLocation = Application.Path & "\Excel.exe, 1"
End If
Else
.IconLocation = Application.Path & "\Excel.exe, 1"
End If
End If
.Save
End With
Set objPicture = Nothing
Set objWSH = Nothing
Set objLink = Nothing
End Sub
Private Function Create_Picture( _
ByVal lnghPic As Long, _
ByVal lnghPal As Long, _
ByVal lngPicType As Long) As IPicture
Dim udtPicInfo As uPicDesc, udtIID_IDispatch As GUID
Dim objIPicture As IPicture
With udtIID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With udtPicInfo
.lngSize = Len(udtPicInfo)
.lngType = PICTYPE_BITMAP
.lnghPic = lnghPic
.lnghPal = lnghPal
End With
Call OleCreatePictureIndirect(udtPicInfo, udtIID_IDispatch, True, objIPicture)
Set Create_Picture = objIPicture
End Function
Falls es das Programm nicht schafft ein Icon zu erzeugen, bekommt der Link das Standard-Excelicon.
Ich lad dir mal vorsichtshalber eine Musterdatei hoch: https://www.herber.de/bbs/user/68207.xls
Gruß
Nepumuk