Yasser Fathi Albanna

كود إنتهاء صلاحية ملف إكسيل Private Sub Workbook_Open() Dim Edate As Date Edate = Format("31/12/2012", "DD/MM/YYYY") ' Replace this with the date you want If Date > Edate + 2 Then MsgBox "This workbook is Expired and will now close !!!" ActiveWorkbook.Close End If End Sub

تنسيقات الملفات النصية التنسيق الملحق الوصف Formatted Text (Space-delimited)‎ prn. تنسيق Lotus المحدد بمسافة. يحفظ الأوراق النشطة فقط. Text (Tab-delimited)‎ txt. يحفظ مصنفاً كملف نصي محدد بعلامات جدولة لاستخدامه على نظام تشغيل Microsoft Windows آخر، ويضمن تفسير أحرف الجدولة وفواصل الأسطر والأحرف الأخرى بشكل صحيح. يحفظ الأوراق النشطة فقط. Text (Macintosh)‎ txt. يحفظ مصنفاً كملف نصي محدد بعلامات جدولة لاستخدامه على نظام التشغيل Macintosh، ويضمن تفسير أحرف الجدولة وفواصل الأسطر والأحرف الأخرى بشكل صحيح. يحفظ الأوراق النشطة فقط. Text (MS-DOS)‎ txt. يحفظ مصنفاً كملف نصي محدد بعلامات جدولة لاستخدامه على نظام التشغيل MS-DOS، ويضمن تفسير أحرف الجدولة وفواصل الأسطر والأحرف الأخرى بشكل صحيح. يحفظ الأوراق النشطة فقط. Unicode Text txt. يحفظ مصنفاً كنص Unicode، وهو معيار لترميز أحرف تم تطويره من قِبل مجموعة Unicode Consortium. CSV (comma delimited)‎ csv. يحفظ مصنفاً كملف نصي محدد بفواصل لاستخدامه على نظام تشغيل Windows آخر، ويضمن تفسير أحرف الجدولة وفواصل الأسطر والأحرف الأخرى بشكل صحيح. يحفظ الأوراق النشطة فقط. CSV (Macintosh)‎ csv. يحفظ مصنفاً كملف نصي محدد بفواصل لاستخدامه على نظام التشغيل Macintosh، ويضمن تفسير أحرف الجدولة وفواصل الأسطر والأحرف الأخرى بشكل صحيح. يحفظ الأوراق النشطة فقط. CSV (MS-DOS)‎ csv. يحفظ مصنفاً كملف نصي محدد بفواصل لاستخدامه على نظام التشغيل MS-DOS، ويضمن تفسير أحرف الجدولة وفواصل الأسطر والأحرف الأخرى بشكل صحيح. يحفظ الأوراق النشطة فقط. DIF dif. تنسيق تبادل البيانات. يحفظ الأوراق النشطة فقط. SYLK slk. تنسيق ارتباط رمزي. يحفظ الأوراق النشطة فقط.

تنسيقات ملفات Excel التنسيق الملحق الوصف Excel Workbook xlsx. تنسيق الملفات الافتراضي الذي يستند إلى XML لكلٍ من Excel 2010 وExcel 2007. لا يمكنه تخزين تعليمات الماكرو البرمجية لـ Microsoft Visual Basic for Applications (VBA)‎‎ أو أوراق الماكرو لـ Microsoft Office Excel 4.0 ‎(.xlm)‎.‎ Excel Workbook ‎(code)‎ xlsm. تنسيق الملف الذي يستند إلى XML والممكّن بماكرو لكلٍ من Excel 2010 وExcel 2007. يخزّن تعليمات الماكرو البرمجية لـ VBA أو أوراق الماكرو لـ Excel 4.0 (.xlm)‎. Excel Binary Workbook xlsb. تنسيق الملف الثنائي (BIFF12) لكلٍ من Excel 2010 وExcel 2007. Template xltx. تنسيق الملف الافتراضي لقالب Excel لكلٍ من Excel 2010 وExcel 2007. لا يمكنه تخزين تعليمات الماكرو البرمجية لـ VBA أو أوراق الماكرو لـ Excel 4.0 ‏(xlm.). Template (code)‎ xltm. تنسيق الملف الممكّن بماكرو لقالب Excel لكلٍ من Excel 2010 وExcel 2007. لا يمكنه تخزين تعليمات الماكرو البرمجية لـ VBA أو أوراق الماكرو لـ Excel 4.0 ‏(xlm.). Excel 97- Excel 2003 Workbook xls. تنسيق الملف الثنائي (BIFF8) في Excel 97 - Excel 2003. Excel 97- Excel 2003 Template xlt. تنسيق الملف الثنائي (BIFF8) في Excel 97 - Excel 2003 لقالب Excel. Microsoft Excel 5.0/95 Workbook xls. تنسيق الملف الثنائي (BIFF5) في Excel 5.0/95. XML Spreadsheet 2003 xml. تنسيق الملف XML Spreadsheet 2003 (XMLSS)‎. XML Data xml. تنسيق بيانات XML. Excel Add-In xlam. تنسيق الوظيفة الإضافية الذي يستند إلى XML والممكّن بماكرو ماكرو لكلٍ من Excel 2010 وExcel 2007. الوظيفة الإضافية هي عبارة عن برنامج تكميلي مصمم لتشغيل تعليمات برمجية إضافية. يعتمد هذا التنسيق استخدام مشاريع VBA وأوراق الماكرو في Excel 4.0 ‏(xlm.). Excel 97-2003 Add-In xla. وظيفة Excel 97-2003 الإضافية، برنامج تكميلي مصمم لتشغيل تعليمات برمجية إضافية. يعتمد هذا التنسيق استخدام مشاريع VBA. Excel 4.0 Workbook xlw. تنسيق ملف Excel 4.0 الذي يحفظ أوراق العمل وأوراق المخططات وأوراق الماكرو فقط. يمكنك فتح مصنف بتنسيق الملف هذا في Excel 2010، لكن لا يمكنك حفظ ملف Excel بتنسيق الملف هذا.

كود تحويل صفحة الإكسيل إلى Pdf مرفق تطبيق للكود Sub ExcelToPDF() Dim iPtr As Long Dim sFileName As String iPtr = InStrRev(ActiveWorkbook.FullName, ".") If iPtr = 0 Then sFileName = ActiveWorkbook.FullName & ".pdf" Else sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".pdf" End If sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="PDF Files (*.pdf), *.pdf") If sFileName = "False" Then Exit Sub ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFileName, Quality:=xlQualityStandard, openAfterPublish:=True End Sub Excel To Pdf.rar

إحنا إخوات يا أ / ياسر وهانحن نسعى لتعم الفائدة على الجميع ولا داعى للإعتذار فأنت من الأخوة الأعزاء أنا إللى بعتذر لأننى لم أوضح شرح للأكواد وشكرا لمجهودك العظيم

معزرة أخى الفاضل ياسر

وهذا الكود يوضع فى thisworkbook لحماية جميع الشيتات من التعديل Private Sub Workbook_Open() Me.Worksheets("Sheet1").Protect UserInterfaceOnly:=True Me.Worksheets("Sheet2").Protect UserInterfaceOnly:=True Me.Worksheets("Sheet3").Protect UserInterfaceOnly:=True End Sub

وهذان أيضا كودان حماية لشيت الإكسيل Private Sub Workbook_Open() 'If you have different passwords 'for each Worksheet. Sheets(1).Protect Password:="Secret", _ UserInterFaceOnly:=True Sheets(2).Protect Password:="Carrot", _ UserInterFaceOnly:=True 'Repeat as needed. End Sub Private Sub Workbook_Open() Dim wSheet As Worksheet For Each wSheet In Worksheets wSheet.Protect Password:="Secret", _ UserInterFaceOnly:=True Next wSheet End Sub

كود لإلغاء الحماية Sub UnrotectAll() Dim sh As Worksheet Dim myPassword As String myPassword = "password" For Each sh In ActiveWorkbook.Worksheets sh.Unprotect Password:=myPassword Next sh End Sub

كود حماية شيت الإكسل Sub ProtectAll() Dim sh As Worksheet Dim myPassword As String myPassword = "password" For Each sh In ActiveWorkbook.Worksheets sh.Protect Password:=myPassword Next sh End Sub

كود فتح إمتداد Xlsm وحفظة بإمتداد Xlsx حتى ولو كان به أكواد Sub Copy_ActiveSheet_2() 'Working in Excel 2000-2013 Dim fname As Variant Dim NewWb As Workbook Dim FileFormatValue As Long 'Check the Excel version If Val(Application.Version) < 9 Then Exit Sub If Val(Application.Version) < 12 Then 'Only choice in the "Save as type" dropdown is Excel files(xls) 'because the Excel version is 2000-2003 fname = Application.GetSaveAsFilename(InitialFileName:="", _ filefilter:="Excel Files (*.xls), *.xls", _ Title:="This example copies the ActiveSheet to a new workbook") If fname <> False Then 'Copy the ActiveSheet to new workbook ActiveSheet.Copy Set NewWb = ActiveWorkbook 'We use the 2000-2003 format xlWorkbookNormal here to save as xls NewWb.SaveAs fname, FileFormat:=-4143, CreateBackup:=False NewWb.Close False Set NewWb = Nothing End If Else 'Give the user the choice to save in 2000-2003 format or in one of the 'new formats. Use the "Save as type" dropdown to make a choice,Default = 'Excel Macro Enabled Workbook. You can add or remove formats to/from the list fname = Application.GetSaveAsFilename(InitialFileName:="", filefilter:= _ " Excel Macro Free Workbook (*.xlsx), *.xlsx," & _ " Excel Macro Enabled Workbook (*.xlsm), *.xlsm," & _ " Excel 2000-2003 Workbook (*.xls), *.xls," & _ " Excel Binary Workbook (*.xlsb), *.xlsb", _ FilterIndex:=2, Title:="This example copies the ActiveSheet to a new workbook") 'Find the correct FileFormat that match the choice in the "Save as type" list If fname <> False Then Select Case LCase(Right(fname, Len(fname) - InStrRev(fname, ".", , 1))) Case "xls": FileFormatValue = 56 Case "xlsx": FileFormatValue = 51 Case "xlsm": FileFormatValue = 52 Case "xlsb": FileFormatValue = 50 Case Else: FileFormatValue = 0 End Select 'Now we can create/Save the file with the xlFileFormat parameter 'value that match the file extension If FileFormatValue = 0 Then MsgBox "Sorry, unknown file extension" Else 'Copies the ActiveSheet to new workbook ActiveSheet.Copy Set NewWb = ActiveWorkbook 'Save the file in the format you choose in the "Save as type" dropdown NewWb.SaveAs fname, FileFormat:= _ FileFormatValue, CreateBackup:=False NewWb.Close False Set NewWb = Nothing End If End If End If End Sub

كود لعمل نسخة من الشيت الأصلى Sub Copy_ActiveSheet_1() 'Working in Excel 97-2013 Dim FileExtStr As String Dim FileFormatNum As Long Dim Sourcewb As Workbook Dim Destwb As Workbook Dim TempFilePath As String Dim TempFileName As String With Application .ScreenUpdating = False .EnableEvents = False End With Set Sourcewb = ActiveWorkbook 'Copy the sheet to a new workbook ActiveSheet.Copy Set Destwb = ActiveWorkbook 'Determine the Excel version and file extension/format With Destwb If Val(Application.Version) < 12 Then 'You use Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else 'You use Excel 2007-2013 Select Case Sourcewb.FileFormat Case 51: FileExtStr = ".xlsx": FileFormatNum = 51 Case 52: If .HasVBProject Then FileExtStr = ".xlsm": FileFormatNum = 52 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If Case 56: FileExtStr = ".xls": FileFormatNum = 56 Case Else: FileExtStr = ".xlsb": FileFormatNum = 50 End Select End If End With ' 'Change all cells in the worksheet to values if you want ' With Destwb.Sheets(1).UsedRange ' .Cells.Copy ' .Cells.PasteSpecial xlPasteValues ' .Cells(1).Select ' End With ' Application.CutCopyMode = False 'Save the new workbook and close it TempFilePath = Application.DefaultFilePath & "\" TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss") With Destwb .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum .Close SaveChanges:=False End With MsgBox "You can find the new file in " & TempFilePath With Application .ScreenUpdating = True .EnableEvents = True End With End Sub

كود تحويل إمتداد Xlsx إلى Xls Sub SaveAllAsXLSX() Dim strFilename As String Dim strDocName As String Dim strPath As String Dim wbk As Workbook Dim fDialog As FileDialog Dim intPos As Integer Dim strPassword As String Dim strWritePassword As String Dim varA As String Dim varB As String Dim colFiles As New Collection Dim vFile As Variant Set fDialog = Application.FileDialog(msoFileDialogFolderPicker) With fDialog .Title = "Select folder and click OK" .AllowMultiSelect = True .InitialView = msoFileDialogViewList If .Show <> -1 Then MsgBox "Cancelled By User", , "List Folder Contents" Exit Sub End If strPath = fDialog.SelectedItems.Item(1) If Right(strPath, 1) <> "\" Then strPath = strPath + "\" End With If Left(strPath, 1) = Chr(34) Then strPath = Mid(strPath, 2, Len(strPath) - 2) End If Set obj = CreateObject("Scripting.FileSystemObject") RecursiveDir colFiles, strPath, "*.xls", True For Each vFile In colFiles Debug.Print vFile strFilename = vFile varA = Right(strFilename, 3) If (varA = "xls" Or varA = "XLS") Then Set wbk = Workbooks.Open(Filename:=strFilename) If wbk.HasVBProject Then wbk.SaveAs Filename:=strFilename & "m", FileFormat:=xlOpenXMLWorkbookMacroEnabled Else wbk.SaveAs Filename:=strFilename & "x", FileFormat:=xlOpenXMLWorkbook End If wbk.Close SaveChanges:=False obj.DeleteFile (strFilename) End If Next vFile End Sub Public Function RecursiveDir(colFiles As Collection, _ strFolder As String, _ strFileSpec As String, _ bIncludeSubfolders As Boolean) Dim strTemp As String Dim colFolders As New Collection Dim vFolderName As Variant 'Add files in strFolder matching strFileSpec to colFiles strFolder = TrailingSlash(strFolder) strTemp = Dir(strFolder & strFileSpec) Do While strTemp <> vbNullString colFiles.Add strFolder & strTemp strTemp = Dir Loop If bIncludeSubfolders Then 'Fill colFolders with list of subdirectories of strFolder strTemp = Dir(strFolder, vbDirectory) Do While strTemp <> vbNullString If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then colFolders.Add strTemp End If End If strTemp = Dir Loop 'Call RecursiveDir for each subfolder in colFolders For Each vFolderName In colFolders Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True) Next vFolderName End If End Function Public Function TrailingSlash(strFolder As String) As String If Len(strFolder) > 0 Then If Right(strFolder, 1) = "\" Then TrailingSlash = strFolder Else TrailingSlash = strFolder & "\" End If End If End Function

كود مسح أى خلايا محددة بها أرقام Sub SmartDel() Application.ScreenUpdating = False Dim selRange As Range Set selRange = Intersect(Selection, ActiveSheet.UsedRange) If selRange Is Nothing Then GoTo exit_SmartDel End If For Each myRange In selRange If IsNumeric(myRange.Formula) = True Then If ActiveSheet.ProtectContents = False Then myRange.MergeArea.ClearContents Else If myRange.Locked = False Then myRange.MergeArea.ClearContents End If End If End If Next myRange exit_SmartDel: Application.ScreenUpdating = True End Sub

أ / ياسر وجدت هذا الكود عندى ولكن لا أعرف فى ماذا يستخدم للإستفاده منه Sub TestInputBox() Dim myRange As Range Set myRange = Application.InputBox(Prompt:= _ "Please Select a Range", _ Title:="InputBox Method", Type:=8) If myRange Is Nothing Then ' Range is blank Else myRange.Select End If End Sub

كود عند تفعيل الماكرو يقوم بإضافة فى كل تفعيل شيت جديد Private Sub GenerateNewWorksheet() Dim ActSheet As Worksheet Dim NewSheet As Worksheet ' Prevents screen refreshing. Application.ScreenUpdating = False Set ActSheet = ActiveSheet Set NewSheet = ThisWorkbook.Sheets().Add() NewSheet.Move After:=Sheets(ThisWorkbook.Sheets().Count) ActSheet.Select ' Enables screen refreshing. Application.ScreenUpdating = True End Sub

كود تحويل صيغ الإكسيل إلى المطلقة أو النسبية Sub MakeAbsoluteorRelative() 'Written by OzGrid Business Applications 'www.ozgrid.com Dim RdoRange As Range Dim i As Integer Dim Reply As String 'Ask whether Relative or Absolute Reply = InputBox("Change formulas to?" & Chr(13) & Chr(13) _ & "Relative row/Absolute column = 1" & Chr(13) _ & "Absolute row/Relative column = 2" & Chr(13) _ & "Absolute all = 3" & Chr(13) _ & "Relative all = 4", "OzGrid Business Applications") 'They cancelled If Reply = "" Then Exit Sub On Error Resume Next 'Set Range variable to formula cells only Set RdoRange = Selection.SpecialCells(Type:=xlFormulas) 'determine the change type Select Case Reply Case 1 'Relative row/Absolute column For i = 1 To RdoRange.Areas.Count RdoRange.Areas(i).Formula = _ Application.ConvertFormula _ (Formula:=RdoRange.Areas(i).Formula, _ FromReferenceStyle:=xlA1, _ ToReferenceStyle:=xlA1, ToAbsolute:=xlRelRowAbsColumn) Next i Case 2 'Absolute row/Relative column For i = 1 To RdoRange.Areas.Count RdoRange.Areas(i).Formula = _ Application.ConvertFormula _ (Formula:=RdoRange.Areas(i).Formula, _ FromReferenceStyle:=xlA1, _ ToReferenceStyle:=xlA1, ToAbsolute:=xlAbsRowRelColumn) Next i Case 3 'Absolute all For i = 1 To RdoRange.Areas.Count RdoRange.Areas(i).Formula = _ Application.ConvertFormula _ (Formula:=RdoRange.Areas(i).Formula, _ FromReferenceStyle:=xlA1, _ ToReferenceStyle:=xlA1, ToAbsolute:=xlAbsolute) Next i Case 4 'Relative all For i = 1 To RdoRange.Areas.Count RdoRange.Areas(i).Formula = _ Application.ConvertFormula _ (Formula:=RdoRange.Areas(i).Formula, _ FromReferenceStyle:=xlA1, _ ToReferenceStyle:=xlA1, ToAbsolute:=xlRelative) Next i Case Else 'Typo MsgBox "Change type not recognised!", vbCritical, _ "OzGrid Business Applications" End Select 'Clear memory Set RdoRange = Nothing End Sub

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

سلمت يداك أستاذى الفاضل / جمال عبد السميع وكل عام وحضرتك بألف صحة وسلامة

أشكرك أخى وأستاذى الفاضل / ياسر خليل على دعائك الطيب أدام الله عمرك وجعلك الله زخرا لهذا المنتدى العظيم وزادك الله من العلم الكثير والكثير

من خلال هذا الكود المرفق تحويل خلايا الاكسيل إلى صورة كل ما عليك فتح الاكسيل واضافة موديول وضع بداخلة الكود بالمرفق ثم قم بتشغيل الماكرو وشاهد Private Declare Function ShellExecute _ Lib "shell32.dll" _ Alias "ShellExecuteA" ( _ ByVal hwnd As Long, _ ByVal lpOperation As String, _ ByVal lpFile As String, _ ByVal lpParameters As String, _ ByVal lpDirectory As String, _ ByVal nShowCmd As Long) _ As Long Sub SaveLogoAsGif() Dim MyChart As Chart Dim objPict As Object Dim RgCopy As Range On Error Resume Next Set RgCopy = Application.InputBox("Select the range to copy / Saveas", "Selection Save", Selection.Address, Type:=8) If RgCopy Is Nothing Then Exit Sub On Error GoTo 0 RgCopy.CopyPicture Appearance:=xlScreen, Format:=xlBitmap ActiveSheet.PasteSpecial Format:="Bitmap" Set objPict = Selection With objPict .CopyPicture 1, 1 ':=1 Set MyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width + 8, .Height + 8).Chart End With With MyChart .Paste .Export ThisWorkbook.Path & Application.PathSeparator & "Temp.gif" .Parent.Delete End With '// cleanup objPict.Delete Set RgCopy = Nothing Set objPict = Nothing '// Now lets View it ShellExecute 0, vbNullString, ThisWorkbook.Path & Application.PathSeparator & "Temp.gif", _ vbNullString, vbNullString, vbMaximizedFocus End Sub

حاضر يا ياسر باشا ربنا معاك ويجعله فى ميزان حسناتك أنا قلت أشارك بإيد مليانه مش فاضية لأن بجد الموضوع هايل ومجهودك رائع جدا جدا تسلم إيدك وأنا بعتذر لكثرة الأكواد

كود إنشاء مجلد جديد لنسخ الملفات فيه ولكن هذا الماكرو يفك ملف مضغوط في مجلد ثابت Sub Unzip3() Dim FSO As Object Dim oApp As Object Dim Fname As Variant Dim FileNameFolder As Variant Dim DefPath As String Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _ MultiSelect:=False) If Fname = False Then 'Do nothing Else 'Destination folder DefPath = "C:\Users\Ron\test\" '<<< Change path If Right(DefPath, 1) <> "\" Then DefPath = DefPath & "\" End If FileNameFolder = DefPath ' 'Delete all the files in the folder DefPath first if you want ' On Error Resume Next ' Kill DefPath & "*.*" ' On Error GoTo 0 'Extract the files into the Destination folder Set oApp = CreateObject("Shell.Application") oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items MsgBox "You find the files here: " & FileNameFolder On Error Resume Next Set FSO = CreateObject("scripting.filesystemobject") FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True End If End Sub Sub Unzip4() Dim FSO As Object Dim oApp As Object Dim Fname As Variant Dim FileNameFolder As Variant Dim DefPath As String Dim strDate As String Dim I As Long Dim num As Long Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _ MultiSelect:=True) If IsArray(Fname) = False Then 'Do nothing Else 'Root folder for the new folder. 'You can also use DefPath = "C:\Users\Ron\test\" DefPath = Application.DefaultFilePath If Right(DefPath, 1) <> "\" Then DefPath = DefPath & "\" End If 'Create the folder name strDate = Format(Now, " dd-mm-yy h-mm-ss") FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\" 'Make the normal folder in DefPath MkDir FileNameFolder 'Extract the files into the newly created folder Set oApp = CreateObject("Shell.Application") For I = LBound(Fname) To UBound(Fname) num = oApp.Namespace(FileNameFolder).items.Count oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname(I)).items Next I MsgBox "You find the files here: " & FileNameFolder On Error Resume Next Set FSO = CreateObject("scripting.filesystemobject") FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True End If End Sub

كود لتصفح ملف TXT من ملف مضغوط Sub Unzip2() Dim FSO As Object Dim oApp As Object Dim Fname As Variant Dim FileNameFolder As Variant Dim DefPath As String Dim strDate As String Dim fileNameInZip As Variant Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _ MultiSelect:=False) If Fname = False Then 'Do nothing Else 'Root folder for the new folder. 'You can also use DefPath = "C:\Users\Ron\test\" DefPath = Application.DefaultFilePath If Right(DefPath, 1) <> "\" Then DefPath = DefPath & "\" End If 'Create the folder name strDate = Format(Now, " dd-mm-yy h-mm-ss") FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\" 'Make the normal folder in DefPath MkDir FileNameFolder 'Extract the files into the newly created folder Set oApp = CreateObject("Shell.Application") 'Change this "*.txt" to extract the files you want For Each fileNameInZip In oApp.Namespace(Fname).items If LCase(fileNameInZip) Like LCase("*.txt") Then oApp.Namespace(FileNameFolder).CopyHere _ oApp.Namespace(Fname).items.Item(CStr(fileNameInZip)) End If Next MsgBox "You find the files here: " & FileNameFolder On Error Resume Next Set FSO = CreateObject("scripting.filesystemobject") FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True End If End Sub

كود لتصفح ملف مضغوط وفك ضغطه Sub Unzip1() Dim FSO As Object Dim oApp As Object Dim Fname As Variant Dim FileNameFolder As Variant Dim DefPath As String Dim strDate As String Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _ MultiSelect:=False) If Fname = False Then 'Do nothing Else 'Root folder for the new folder. 'You can also use DefPath = "C:\Users\Ron\test\" DefPath = Application.DefaultFilePath If Right(DefPath, 1) <> "\" Then DefPath = DefPath & "\" End If 'Create the folder name strDate = Format(Now, " dd-mm-yy h-mm-ss") FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\" 'Make the normal folder in DefPath MkDir FileNameFolder 'Extract the files into the newly created folder Set oApp = CreateObject("Shell.Application") oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items 'If you want to extract only one file you can use this: 'oApp.Namespace(FileNameFolder).CopyHere _ 'oApp.Namespace(Fname).items.Item("test.txt") MsgBox "You find the files here: " & FileNameFolder On Error Resume Next Set FSO = CreateObject("scripting.filesystemobject") FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True End If End Sub