ماكرو لعمل مربع حوار -فتح - حفظ - اختيار لون

[حسام نور]

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

مطلوب عمل ماكرو بيحث عند الضغط على الزر تظهر شاشة (حفظ بأسم ) لكي أستطيع عمل حفظ للملف بأسم آخر

وشكراً

[محمد طاهر عرفه]

يتم ذلك بدوال ال API

و تحديدا

دالة

GetSaveFileName

ولكن لتشغيلها فى الاكسيل ، تحتاج الي تعديلات بخلاف الاكسس و البيزيك

و هي تعديلات طفيفة مثل تحويل app الي application

وحذف أو تعديل بعض الخواص التي لا تناسب الاكسيل

بالاضافة الي ضافة استقبال الناتج ليناسب الاكسيل

سأحاول تجهيز مثال بإذن الله

[محمد طاهر عرفه]

مرفق ملف اكسيل به 3 ماكروهات

الاول لاظهار مربع حوار فتح ملف ثم الفتح

الثاني لاظهار مربع حوار حفظ ملف ثم الحفظ

الثالث لاختيار الالوان و تطبيق الاختيار علي الخلايا المختارة

لتشغيل الماكرو

من قائمة

tools

Macros

أو

ALT+F8

Dialogs.rar

[حسام نور]

سؤال دكتور محمد

أردت أن أستخلص الماكرو الخاص بـ ( الحفظ بأسم ) فقط من بين الأكواد لأصمم له زر أمر بذلك ولكن لم أنجح . فهل تكرمت بوضع الكود الخاص بالحفظ بأسم هنا لأتمكن من ذلك ؟

ورمضان كريم

[محمد طاهر عرفه]

Option Explicit


Private Type OPENFileName

    lStructSize As Long

    hwndOwner As Long

    hInstance As Long

    lpstrFilter As String

    lpstrCustomFilter As String

    nMaxCustFilter As Long

    nFilterIndex As Long

    lpstrFile As String

    nMaxFile As Long

    lpstrFileTitle As String

    nMaxFileTitle As Long

    lpstrInitialDir As String

    lpstrTitle As String

    flags As Long

    nFileOffset As Integer

    nFileExtension As Integer

    lpstrDefExt As String

    lCustData As Long

    lpfnHook As Long

    lpTemplateNaselection As String

End Type




Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenFileName As OPENFileName) As Long

Dim OFName As OPENFileName


Sub ExcelSave()

    Dim sFile As String

    sFile = ShowSave

    If sFile <> "" Then

        MsgBox "You chose this file: " + sFile

        ActiveWorkbook.SaveAs Filename:=sFile

    Else

        MsgBox "You pressed cancel"

    End If

    

End Sub


Private Function ShowSave() As String

    'Set the structure size

    OFName.lStructSize = Len(OFName)

    'Set the owner window

    'OFName.hwndOwner = Selection.Hwnd

    'Set the application's instance

    OFName.hInstance = Application.hInstance

    'Set the filet

    OFName.lpstrFilter = "Excel Files (*.xls)" + Chr$(0) + "*.xls" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)

    'Create a buffer

    OFName.lpstrFile = Space$(254)

    'Set the maximum number of chars

    OFName.nMaxFile = 255

    'Create a buffer

    OFName.lpstrFileTitle = Space$(254)

    'Set the maximum number of chars

    OFName.nMaxFileTitle = 255

    'Set the initial directory

    OFName.lpstrInitialDir = "C:\"

    'Set the dialog title

    OFName.lpstrTitle = OFName.lpstrTitle = "Save File - KPD-Team - Excel example BY www.officena.net"

    'no extra flags

    OFName.flags = 0


    'Show the 'Save File'-dialog

    If GetSaveFileName(OFName) Then

        ShowSave = Trim$(OFName.lpstrFile)

    Else

        ShowSave = ""

    End If

End Function

[حسام نور]

وضعت الكود في زر أمر ولكن لم يعمل .. لا أعلم هل هناك مشكله معينه دكتور محمد ؟ أم أن الكود يوضع بشكل طبيعي ؟

[محمد طاهر عرفه]

ضع الكود السابق كله فى موديول

و فى الكود الخاص بزر الامر استدع الروتين الفرعي ExcelSave

مثال

Private Sub CommandButton1_Click()

ExcelSave

End Sub