إنشاء اختصار لملف اكسل به صورتك على سطح المكتب

[مختار حسين محمود]

السلام عليكم اخوانى وأساتذتى فى المنتدى وكل عام وأنتم بخير بمناسبة عيد الفطر

 

اليوم أقدم لكم كيفية عمل اختصار لملف اكسل به صورتك على سطح المكتب فقد لفت نظرى طلب أحد الأخوة  لهذا الموضوع 

لذلك قررت أن أضع بين أيديكم الطريقة الآتية

1 - فى ملف اكسل أدرج هذا المديول

Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetActiveWindow Lib "user32" () As Integer
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hWnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Const CSIDL_PERSONAL = &H5
Private Type SHITEMID
    cb As Long
    abID As Byte
End Type
Private Type ITEMIDLIST
    mkid As SHITEMID
End Type
Dim FSO As New FileSystemObject
Dim FLD As Folder
Function UserNameOffice() As String
    UserNameOffice = Application.UserName
End Function
Public Function DesktopAddress() As String
    DesktopAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator
End Function
Private Function GetSpecialFolder(CSIDL As Long) As String
Dim Path As String
Dim FolderPath As Object
Dim IDL As ITEMIDLIST
Dim sh As New Shell32.Shell
Set FolderPath = sh.NameSpace(5)
If Not FolderPath Is Nothing Then
    GetSpecialFolder = FolderPath.Self.Path
    Exit Function
End If
    GetSpecialFolder = ""
End Function
Function DirExists(strDirectory As String) As Boolean
    DirExists = (Dir(strDirectory, vbDirectory) <> "")
End Function
Sub Desktop_Shortcut()
    Dim WBName As String, Path As String, WB_Link As String, WB_Name As String
    Dim DesktopPath As String, TargetPath As String, StrSave As String
    Dim WSHShell As Object, MyShortcut As Object
    Set WSHShell = CreateObject("WScript.Shell")
    Dim FSO As Object, Folder As Object, File As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Dim WB As Workbook
    Set WB = ThisWorkbook
    Dim WSh As Worksheet
    Set WSh = Sheet1
        WBName = WB.Name
        Path = "MyFile"
        DesktopPath = WSHShell.SpecialFolders("Desktop")
        WSh.Range("C2").Value = WB.Name
        WB_Name = WSh.Range("C3").Value
        WB_Link = WSh.Range("C4").Value
On Error GoTo ErrHandle
    If Not DirExists("C:\" & WB_Name) Then 'Check C Drive
    If Not DirExists(GetSpecialFolder(CSIDL_PERSONAL) & "\" & WB_Name) Then 'Check My Documents
    Set FSO = CreateObject("Scripting.FileSystemObject") 'If not in C Drive or My Documents - then create shortcut
        FSO.CreateFolder "C:\" & WB_Name
        ChDir "C:\" & WB_Name
        SavePicture Sheet1.Image1.Picture, WB_Name & ".ico" 'Picture pasted onto Image1 on Sheet 1 - Link Shortcut
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set MyShortcut = WSHShell.CreateShortcut(DesktopPath & "\" & WB_Link)
    With MyShortcut
        .TargetPath = WB.FullName
        .IconLocation = "C:\" & WB_Name & "\" & WB_Name & ".ico"
        .WindowStyle = 1
        .Description = "EEZIAdmin"
        .WorkingDirectory = WB.Path
        .Save
    End With
    Else
            End If
        End If
ErrHandle:
    Set WSHShell = Nothing
End Sub

2 - فى شيت 1 الخلية C3  ضع المعادلة

=IF($C$2="";"";IF(MID($C$2;(LEN($C$2)-4);"1")=".";LEFT($C$2;LEN($C$2)-5);IF(MID($C$2;(LEN($C$2)-3);"1")=".";LEFT($C$2;LEN($C$2)-4);"")))

وفى الخلية  C4  ضع المعادلة الآتية

=IF($C$3<>"";$C$3&".lnk";"")

 3 - فى شيت 1  ادراج   Image   وعليها صورة :

 

ندرج الـ   Image  كالتالى   من developet tab  ثم insert   ثم  more controls  ثم  Microsoft forms 2.0 image  ثم ok

 

ارسم الـــــ     Image     فى الشيت   وبعدين كليك يمين عليها واخنر Properties

 

فى قائمة الخصائص التى تظهر دور على الخيار Picture   واعمل  ادراج  لأى صورة من على جهازك على الـ Image    واحفظ  وشغل الكود

 

لكم كل التحية والتقدير

 

 

 

 

Desktop Shortcut mokhtar.rar

[عبد العزيز البسكري]

السلام عليكم و رحمة الله و بركاته

عيد فطر سعيد كل عام و أنت بمليون خير

طال غيابك كثيرا أستاذي العزيز مختار حسين محمود

حاولت الاتصال بك عبر الرسائل الخاصة للمعايدة فلم أتمكن من ذلك

كل عام و انت طيب يا طيب

أعاده الله عليك و علينا و على جميع المسلمين بالخير و اليمن و البركات

شكرا على الموضوع المتميز من مختار حسين المتميّز

أخوك / عبد العزيز البسكري

[مختار حسين محمود]

الله عليك يا زيزو وعلى كلماتك الرقيقة

 

معلش أنا قفلت الخاص عشان أتفرغ لحبيبنا رمضان

 

كل سنة وأنت طيب وبخير وسعادة 

[عبدالواحد احمد]

السلام عليكم و رحمة الله و بركاته اخي مختار حسين محمود طريقة جميلة جداَ لقيام بي اختصار لملف

[Yasser Fathi Albanna]

الله عليك يا أ / مختار

عودا حميدا أخى الحبيب بأعمالك الرائعة ومبارك مرة ثانية على الترقية المستحقة

وكل سنة وأنت والإسرة الكريمة بخير

[ياسر خليل أبو البراء]

أخي الحبيب الغالي مختار

الغائب عن العين الحاضر في القلب

بارك الله فيك وجزاك الله خير الجزاء ..

جربت الملف الخاص بك وعمل بشكل جيد مع صورتك الجميلة ..حبيت أجرب صورتي الوحشة لقيت صورتك الجميلة بردو منورة سطح المكتب .. قلت أحذف الاختصار وأنفذ الأمر مرة تانية الاقي مفيش اختصار بيتعمل ...إنت معزم على صورتك بس ..

هل هناك امتداد معين للصور أم أن أي امتداد يعمل ؟؟

جزيت خير الجزاء

[ياسر خليل أبو البراء]

اكتشفت إن لو الاختصار موجود على سطح المكتب يتم إنشاء مجلد على الدرايف C وفيه الاختصار

المهم حذفت اللي على سطح المكتب وحذفت المجلد .. وتمام التمام

وبعدين فتحت الملف وعدلت الصورة .. لصورتي الوحشة

 

وانفذ الأمر الاقي الأمر اتنفذ الحمد لله :signthankspin: :dance1:

 

متفرحش أوي يا عم ياسر الأمر اتنفذ لكن الصورة على الاختصار هي الصورة الحلوة بتاعت أخوك مختار مش صورتك الوحشة ..

ييييه .. يبدو إني هنتظر رد منك ... متسبنيش أعاني وأضطر أقرا الكود حرف حرف عشان أعرف الغلطة فين ؟؟!

[ياسر خليل أبو البراء]

بص بقا صورتك الجميلة دي زهقتني ... أنا حذفت الاختصارات من على سطح المكتب ومن على الدرايف C

وغيرت صورتك لصورتي اللي باين عليها الإكسيل مش قابلها

ونفذت الأمر لقيت صورتك بردو :wallbash:

 

المهم قلت مبدهاش لازم أعمل حاجة عملت كليك يمين على الاختصار لقيت Change Icon نقرت عليها وأنا متغاااااظ .. المفاجأة لقيت الأيقونة الخاصة بالصورة بتاعتي اختارتها وفلحت ..

بس أسلوب العافية ده مش بحبه

عايز أعرف السبب في عدم التغيير بشكل مباشر للصورة الجديدة

[ياسر خليل أبو البراء]

الحل الوحيد اللي خلاني مرضي شوية إني غيرت اسم الملف بتاعك وقبل التنفيذ غيرت الصورة ... ونجحت عملية إنشاء الاختصار بعد ما طلعت روحي   

الحمد لله هنام وأنا شايف صورتي الوحشة على سطح المكتب .. مقدرش أشوف سطح المكتب عندي عليه صورة حلوة وجميلة (دا مستحيل أبداً)

تقبل تحياتي أخي الغالي مختار :signthankspin:

[مختار حسين محمود]

أخى الحبيب عبدالواحد مشكور على مروركم الكريم وبارك الله فيك

 

أخى الحبيب ياسر فتحى بوركت و ربنا يخليك ليه وكل سنة وأنت وأحبابك بخير وسعادة

 

 

أخى وأستاذى العزيز ياسر خليل  بارك الله فيك  وجازاكم الله عنا خيرا متأسف لك وللأخوة على تأخر الرد  كنت فى مشوار توى راجع

بس تأخر الرد جعلك  تصل للحل بنفسك   وهو لما تغير الصورة ابقى غير فى اسم الملف ولو حرفا واحدا ليعمل الملف دون أخطاء

لأن تغيير الصورة فقط لن يغيير شكل الأيقونة  المهم اسم الملف أولا وقبل كل شىء

حتى جرب كده تغيير اسم الملف دون تغيير الصورة  هتلاقى الملف يعمل عادى

وأغلب الصور التى نستخدمها مع اكسل غالباً يكون امتدادها  jpg 

يا صاحب القلب و الفعل والقول الطيب سبت لك حاجة على الخاص ابقى شوفها

  كل سنة وأنت وأهلك وأحبابك بخير وصحة وسعادة

تحياتى للجميع

[محمد حسن المحمد]

الأخ العزيز مختار حسين محمود المحترم..

السلام عليكم ورحمة الله وبركاته...    عيد فطر مبارك وتقبل الله طاعتكم    ...اللهم أعده على عبادك وقد ازدادوا محبة وقرباً

أرجو الله أن ينفع بأعمالك الطيبة ..ويرفع من درجاتك في الدنيا والآخرة..

أما من حيث الموضوع والكود الذي وضعته لتغيير الصورة وجعلها على سطح المكتب فأنا أقل من أن أقيم أعمالكم التي تقدمونها

بل أقول : جزاكم الله خيراً

تقبل تحياتي والسلام عليكم ورحمة الله وبركاته.

[ياسر خليل أبو البراء]

أخي الغالي مختار

بارك الله فيك ... أنا لسه توي فاتح المنتدى وأول حاجة أعملها أرد عليك

بصيت ع الخاص ملقش حاجة إنت باعت رسالة سرية بالحبر السري !!!

[مختار حسين محمود]

الأستاذ الفاضل محمد حسن   بارك الله فيكم وأشكرك على دعائك وكلامك الطيب بحقى 

كما أشكرك على تواضعك فحضرتك أستاذ لنا بارك الله فيك وفى أهلك ومالك ووقتك وشبابك

 

أخى وأستاذى ياسر خليل بارك الله فيك

طالما ملقتش الرسالة أكيد هى بالحبر السرى والحبر السرى هتلاقيه فى جديد الفعاليات

[أبوبسمله]

جزاك الله كل خير اخى واستاذى الغالى مختار وان شاء الله تكون بخير

بالتوفيق

 

[حسام ميلكانا]

استاذنا الكبير - مختار حسن

جزاك الله كل خير على هذة الاعمال القيمة والتى تعتبر بمثابة الكنوز الغالية

بارك الله لك وجعل ما تقدمة فى ميزان حسناتك

ممكن لو تكرمت شرح بسيط عن كيفية تغير الصور وياجبذا لوكان شرح بالصور يبقى عملت الصح

بارك الله لك استاذى الكريم

وجزاك الله خير الجزاء

 

[محمد لطفى]

جزاك الله خيرا