|
Export sheets as JPEG files through a dialog box (Problems)
Hello,
I have a problem with some code I have and was hoping for some assistance. The code below is supose to do the following: 1. Create a dialog box in the current workbook (Centara Feasibility Study) 2. I select the sheets I would like to export to another (new) workbook in JPEG format by selecting the checkboxes in the dialog box. 3. Once i press OK the following is supose to happen: A. A new workbook is created (Centara Feasibility Copy 1.xls) B. Sheets on the original workbook are copied (if the dialog check box for that sheet was selected) and are then pasted in the new workbook as JPEG files. C. Just prior to this the macro is supose to add a new worksheet in the 'Copy 1' workbook and rename the sheet (the new name for the sheet is supose to be the same name as the sheet where the original was copied from). Thats it...except for a bug I cannot for the life of me figure out what to do. The bug is somewhere in the selecting of the sheets to copy and the nameing of the new worksheets. Any help on this would be appreciated. Thanks Tim Sub Export_Sheets() Dim mypass As String Dim i As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim CB As CheckBox Application.ScreenUpdating = False ' Check for protected workbook If ActiveWorkbook.ProtectStructure Then MsgBox "Workbook is protected.", vbCritical Exit Sub End If ' Add a temporary dialog sheet Set CurrentSheet = ActiveSheet Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 ' Add the checkboxes TopPos = 40 For i = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(i) ' Skip empty sheets sheets If Application.CountA(CurrentSheet.Cells) = 0 Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).text = _ CurrentSheet.Name If Worksheets(i).Visible < xlSheetVisible Then PrintDlg.CheckBoxes(SheetCount).Value = True End If TopPos = TopPos + 13 End If Next i ' Move the OK and Cancel buttons PrintDlg.Buttons.Left = 240 ' Set dialog height, width, and caption With PrintDlg.DialogFrame .Height = Application.Max _ (68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "Select sheets to export" End With ' Change tab order of OK and Cancel buttons ' so the 1st option button will have the focus PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront ' Display the dialog box CurrentSheet.Activate Application.ScreenUpdating = True If SheetCount < 0 Then If PrintDlg.Show Then Workbooks.Add ChDir "C:\Documents and Settings\Em\Desktop" ActiveWorkbook.SaveAs Filename:= _ "C:\Documents and Settings\Em\Desktop\Centara Feasibility Copy 1.xls", _ ReadOnlyRecommended:=False, CreateBackup:=False For Each CB In PrintDlg.CheckBoxes Worksheets(CB.Caption).Activate If CB.Value = xlOn Then Windows("Centara Feasibility Study Tool.xls").Activate Sheets(CB.SheetCount.text).Select Range("A1:X163").Select Range("A1:X163").Copy Windows("Centara Feasibility Copy 1.xls").Activate Sheets.Add Sheets(ActiveSheet).Name = PrintDlg.CheckBoxes(SheetCount).text Range("A1").Select ActiveSheet.Pictures.Paste.Select Selection.ShapeRange.ZOrder msoSendToBack Range("A1").Select Application.CutCopyMode = False Else ActiveSheet.Visible = xlSheetVisible End If Next CB End If Else MsgBox "All worksheets are empty." End If ' Delete temporary dialog sheet (without a warning) Application.DisplayAlerts = False PrintDlg.Delete ' Reactivate original sheet Cover.Activate End Sub |
Export sheets as JPEG files through a dialog box (Problems)
Tim,
There is no "Pictures" collection in Excel. Hence, your Paste is going to fail. Why do need it in jpeg format if you are pasting a range into a workbook ? NickHK "Tim" wrote in message m... Hello, I have a problem with some code I have and was hoping for some assistance. The code below is supose to do the following: 1. Create a dialog box in the current workbook (Centara Feasibility Study) 2. I select the sheets I would like to export to another (new) workbook in JPEG format by selecting the checkboxes in the dialog box. 3. Once i press OK the following is supose to happen: A. A new workbook is created (Centara Feasibility Copy 1.xls) B. Sheets on the original workbook are copied (if the dialog check box for that sheet was selected) and are then pasted in the new workbook as JPEG files. C. Just prior to this the macro is supose to add a new worksheet in the 'Copy 1' workbook and rename the sheet (the new name for the sheet is supose to be the same name as the sheet where the original was copied from). Thats it...except for a bug I cannot for the life of me figure out what to do. The bug is somewhere in the selecting of the sheets to copy and the nameing of the new worksheets. Any help on this would be appreciated. Thanks Tim Sub Export_Sheets() Dim mypass As String Dim i As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim CB As CheckBox Application.ScreenUpdating = False ' Check for protected workbook If ActiveWorkbook.ProtectStructure Then MsgBox "Workbook is protected.", vbCritical Exit Sub End If ' Add a temporary dialog sheet Set CurrentSheet = ActiveSheet Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 ' Add the checkboxes TopPos = 40 For i = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(i) ' Skip empty sheets sheets If Application.CountA(CurrentSheet.Cells) = 0 Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).text = _ CurrentSheet.Name If Worksheets(i).Visible < xlSheetVisible Then PrintDlg.CheckBoxes(SheetCount).Value = True End If TopPos = TopPos + 13 End If Next i ' Move the OK and Cancel buttons PrintDlg.Buttons.Left = 240 ' Set dialog height, width, and caption With PrintDlg.DialogFrame .Height = Application.Max _ (68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "Select sheets to export" End With ' Change tab order of OK and Cancel buttons ' so the 1st option button will have the focus PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront ' Display the dialog box CurrentSheet.Activate Application.ScreenUpdating = True If SheetCount < 0 Then If PrintDlg.Show Then Workbooks.Add ChDir "C:\Documents and Settings\Em\Desktop" ActiveWorkbook.SaveAs Filename:= _ "C:\Documents and Settings\Em\Desktop\Centara Feasibility Copy 1.xls", _ ReadOnlyRecommended:=False, CreateBackup:=False For Each CB In PrintDlg.CheckBoxes Worksheets(CB.Caption).Activate If CB.Value = xlOn Then Windows("Centara Feasibility Study Tool.xls").Activate Sheets(CB.SheetCount.text).Select Range("A1:X163").Select Range("A1:X163").Copy Windows("Centara Feasibility Copy 1.xls").Activate Sheets.Add Sheets(ActiveSheet).Name = PrintDlg.CheckBoxes(SheetCount).text Range("A1").Select ActiveSheet.Pictures.Paste.Select Selection.ShapeRange.ZOrder msoSendToBack Range("A1").Select Application.CutCopyMode = False Else ActiveSheet.Visible = xlSheetVisible End If Next CB End If Else MsgBox "All worksheets are empty." End If ' Delete temporary dialog sheet (without a warning) Application.DisplayAlerts = False PrintDlg.Delete ' Reactivate original sheet Cover.Activate End Sub |
Export sheets as JPEG files through a dialog box (Problems)
Dear NickHK
I can do this copy / paste picture manually by: 1. selecting the range 2. selecting EDIT COPY 3. selecting the new WB and range A1 4. holding down the SHIFT key select EDIT Paste Picture I want to do the same in a macro as below but through a dialog box. All on Excel XP Regards Tim NickHK" wrote in message ... Tim, There is no "Pictures" collection in Excel. Hence, your Paste is going to fail. Why do need it in jpeg format if you are pasting a range into a workbook ? NickHK "Tim" wrote in message m... Hello, I have a problem with some code I have and was hoping for some assistance. The code below is supose to do the following: 1. Create a dialog box in the current workbook (Centara Feasibility Study) 2. I select the sheets I would like to export to another (new) workbook in JPEG format by selecting the checkboxes in the dialog box. 3. Once i press OK the following is supose to happen: A. A new workbook is created (Centara Feasibility Copy 1.xls) B. Sheets on the original workbook are copied (if the dialog check box for that sheet was selected) and are then pasted in the new workbook as JPEG files. C. Just prior to this the macro is supose to add a new worksheet in the 'Copy 1' workbook and rename the sheet (the new name for the sheet is supose to be the same name as the sheet where the original was copied from). Thats it...except for a bug I cannot for the life of me figure out what to do. The bug is somewhere in the selecting of the sheets to copy and the nameing of the new worksheets. Any help on this would be appreciated. Thanks Tim Sub Export_Sheets() Dim mypass As String Dim i As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim CB As CheckBox Application.ScreenUpdating = False ' Check for protected workbook If ActiveWorkbook.ProtectStructure Then MsgBox "Workbook is protected.", vbCritical Exit Sub End If ' Add a temporary dialog sheet Set CurrentSheet = ActiveSheet Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 ' Add the checkboxes TopPos = 40 For i = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(i) ' Skip empty sheets sheets If Application.CountA(CurrentSheet.Cells) = 0 Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).text = _ CurrentSheet.Name If Worksheets(i).Visible < xlSheetVisible Then PrintDlg.CheckBoxes(SheetCount).Value = True End If TopPos = TopPos + 13 End If Next i ' Move the OK and Cancel buttons PrintDlg.Buttons.Left = 240 ' Set dialog height, width, and caption With PrintDlg.DialogFrame .Height = Application.Max _ (68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "Select sheets to export" End With ' Change tab order of OK and Cancel buttons ' so the 1st option button will have the focus PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront ' Display the dialog box CurrentSheet.Activate Application.ScreenUpdating = True If SheetCount < 0 Then If PrintDlg.Show Then Workbooks.Add ChDir "C:\Documents and Settings\Em\Desktop" ActiveWorkbook.SaveAs Filename:= _ "C:\Documents and Settings\Em\Desktop\Centara Feasibility Copy 1.xls", _ ReadOnlyRecommended:=False, CreateBackup:=False For Each CB In PrintDlg.CheckBoxes Worksheets(CB.Caption).Activate If CB.Value = xlOn Then Windows("Centara Feasibility Study Tool.xls").Activate Sheets(CB.SheetCount.text).Select Range("A1:X163").Select Range("A1:X163").Copy Windows("Centara Feasibility Copy 1.xls").Activate Sheets.Add Sheets(ActiveSheet).Name = PrintDlg.CheckBoxes(SheetCount).text Range("A1").Select ActiveSheet.Pictures.Paste.Select Selection.ShapeRange.ZOrder msoSendToBack Range("A1").Select Application.CutCopyMode = False Else ActiveSheet.Visible = xlSheetVisible End If Next CB End If Else MsgBox "All worksheets are empty." End If ' Delete temporary dialog sheet (without a warning) Application.DisplayAlerts = False PrintDlg.Delete ' Reactivate original sheet Cover.Activate End Sub |
Export sheets as JPEG files through a dialog box (Problems)
Tim,
Sorry, never knew you could do that. If you look at the help on "Pictures", you'll see it's a hidden collection and Shapes collection is recommended to be used. That not your problem though. I'll see what I can do to help. NickHK "Tim" wrote in message om... Dear NickHK I can do this copy / paste picture manually by: 1. selecting the range 2. selecting EDIT COPY 3. selecting the new WB and range A1 4. holding down the SHIFT key select EDIT Paste Picture I want to do the same in a macro as below but through a dialog box. All on Excel XP Regards Tim NickHK" wrote in message ... Tim, There is no "Pictures" collection in Excel. Hence, your Paste is going to fail. Why do need it in jpeg format if you are pasting a range into a workbook ? NickHK "Tim" wrote in message m... Hello, I have a problem with some code I have and was hoping for some assistance. The code below is supose to do the following: 1. Create a dialog box in the current workbook (Centara Feasibility Study) 2. I select the sheets I would like to export to another (new) workbook in JPEG format by selecting the checkboxes in the dialog box. 3. Once i press OK the following is supose to happen: A. A new workbook is created (Centara Feasibility Copy 1.xls) B. Sheets on the original workbook are copied (if the dialog check box for that sheet was selected) and are then pasted in the new workbook as JPEG files. C. Just prior to this the macro is supose to add a new worksheet in the 'Copy 1' workbook and rename the sheet (the new name for the sheet is supose to be the same name as the sheet where the original was copied from). Thats it...except for a bug I cannot for the life of me figure out what to do. The bug is somewhere in the selecting of the sheets to copy and the nameing of the new worksheets. Any help on this would be appreciated. Thanks Tim Sub Export_Sheets() Dim mypass As String Dim i As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim CB As CheckBox Application.ScreenUpdating = False ' Check for protected workbook If ActiveWorkbook.ProtectStructure Then MsgBox "Workbook is protected.", vbCritical Exit Sub End If ' Add a temporary dialog sheet Set CurrentSheet = ActiveSheet Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 ' Add the checkboxes TopPos = 40 For i = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(i) ' Skip empty sheets sheets If Application.CountA(CurrentSheet.Cells) = 0 Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).text = _ CurrentSheet.Name If Worksheets(i).Visible < xlSheetVisible Then PrintDlg.CheckBoxes(SheetCount).Value = True End If TopPos = TopPos + 13 End If Next i ' Move the OK and Cancel buttons PrintDlg.Buttons.Left = 240 ' Set dialog height, width, and caption With PrintDlg.DialogFrame .Height = Application.Max _ (68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "Select sheets to export" End With ' Change tab order of OK and Cancel buttons ' so the 1st option button will have the focus PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront ' Display the dialog box CurrentSheet.Activate Application.ScreenUpdating = True If SheetCount < 0 Then If PrintDlg.Show Then Workbooks.Add ChDir "C:\Documents and Settings\Em\Desktop" ActiveWorkbook.SaveAs Filename:= _ "C:\Documents and Settings\Em\Desktop\Centara Feasibility Copy 1.xls", _ ReadOnlyRecommended:=False, CreateBackup:=False For Each CB In PrintDlg.CheckBoxes Worksheets(CB.Caption).Activate If CB.Value = xlOn Then Windows("Centara Feasibility Study Tool.xls").Activate Sheets(CB.SheetCount.text).Select Range("A1:X163").Select Range("A1:X163").Copy Windows("Centara Feasibility Copy 1.xls").Activate Sheets.Add Sheets(ActiveSheet).Name = PrintDlg.CheckBoxes(SheetCount).text Range("A1").Select ActiveSheet.Pictures.Paste.Select Selection.ShapeRange.ZOrder msoSendToBack Range("A1").Select Application.CutCopyMode = False Else ActiveSheet.Visible = xlSheetVisible End If Next CB End If Else MsgBox "All worksheets are empty." End If ' Delete temporary dialog sheet (without a warning) Application.DisplayAlerts = False PrintDlg.Delete ' Reactivate original sheet Cover.Activate End Sub |
Export sheets as JPEG files through a dialog box (Problems)
Thanks NickHK,
I look forward to yours, and anyone else that could shead some light on this. I am really stuck on this one. Regards Tim "NickHK" wrote in message ... Tim, Sorry, never knew you could do that. If you look at the help on "Pictures", you'll see it's a hidden collection and Shapes collection is recommended to be used. That not your problem though. I'll see what I can do to help. NickHK "Tim" wrote in message om... Dear NickHK I can do this copy / paste picture manually by: 1. selecting the range 2. selecting EDIT COPY 3. selecting the new WB and range A1 4. holding down the SHIFT key select EDIT Paste Picture I want to do the same in a macro as below but through a dialog box. All on Excel XP Regards Tim NickHK" wrote in message ... Tim, There is no "Pictures" collection in Excel. Hence, your Paste is going to fail. Why do need it in jpeg format if you are pasting a range into a workbook ? NickHK "Tim" wrote in message m... Hello, I have a problem with some code I have and was hoping for some assistance. The code below is supose to do the following: 1. Create a dialog box in the current workbook (Centara Feasibility Study) 2. I select the sheets I would like to export to another (new) workbook in JPEG format by selecting the checkboxes in the dialog box. 3. Once i press OK the following is supose to happen: A. A new workbook is created (Centara Feasibility Copy 1.xls) B. Sheets on the original workbook are copied (if the dialog check box for that sheet was selected) and are then pasted in the new workbook as JPEG files. C. Just prior to this the macro is supose to add a new worksheet in the 'Copy 1' workbook and rename the sheet (the new name for the sheet is supose to be the same name as the sheet where the original was copied from). Thats it...except for a bug I cannot for the life of me figure out what to do. The bug is somewhere in the selecting of the sheets to copy and the nameing of the new worksheets. Any help on this would be appreciated. Thanks Tim Sub Export_Sheets() Dim mypass As String Dim i As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim CB As CheckBox Application.ScreenUpdating = False ' Check for protected workbook If ActiveWorkbook.ProtectStructure Then MsgBox "Workbook is protected.", vbCritical Exit Sub End If ' Add a temporary dialog sheet Set CurrentSheet = ActiveSheet Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 ' Add the checkboxes TopPos = 40 For i = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(i) ' Skip empty sheets sheets If Application.CountA(CurrentSheet.Cells) = 0 Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).text = _ CurrentSheet.Name If Worksheets(i).Visible < xlSheetVisible Then PrintDlg.CheckBoxes(SheetCount).Value = True End If TopPos = TopPos + 13 End If Next i ' Move the OK and Cancel buttons PrintDlg.Buttons.Left = 240 ' Set dialog height, width, and caption With PrintDlg.DialogFrame .Height = Application.Max _ (68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "Select sheets to export" End With ' Change tab order of OK and Cancel buttons ' so the 1st option button will have the focus PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront ' Display the dialog box CurrentSheet.Activate Application.ScreenUpdating = True If SheetCount < 0 Then If PrintDlg.Show Then Workbooks.Add ChDir "C:\Documents and Settings\Em\Desktop" ActiveWorkbook.SaveAs Filename:= _ "C:\Documents and Settings\Em\Desktop\Centara Feasibility Copy 1.xls", _ ReadOnlyRecommended:=False, CreateBackup:=False For Each CB In PrintDlg.CheckBoxes Worksheets(CB.Caption).Activate If CB.Value = xlOn Then Windows("Centara Feasibility Study Tool.xls").Activate Sheets(CB.SheetCount.text).Select Range("A1:X163").Select Range("A1:X163").Copy Windows("Centara Feasibility Copy 1.xls").Activate Sheets.Add Sheets(ActiveSheet).Name = PrintDlg.CheckBoxes(SheetCount).text Range("A1").Select ActiveSheet.Pictures.Paste.Select Selection.ShapeRange.ZOrder msoSendToBack Range("A1").Select Application.CutCopyMode = False Else ActiveSheet.Visible = xlSheetVisible End If Next CB End If Else MsgBox "All worksheets are empty." End If ' Delete temporary dialog sheet (without a warning) Application.DisplayAlerts = False PrintDlg.Delete ' Reactivate original sheet Cover.Activate End Sub |
Export sheets as JPEG files through a dialog box (Problems)
Tim,
This works for me. NickHK Sub Export_Sheets() Dim mypass As String Dim i As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim CB As CheckBox 'Application.ScreenUpdating = False ' Check for protected workbook If ActiveWorkbook.ProtectStructure Then MsgBox "Workbook is protected.", vbCritical Exit Sub End If ' Add a temporary dialog sheet Set CurrentSheet = ActiveSheet Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 ' Add the checkboxes TopPos = 40 For i = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(i) ' Skip empty sheets sheets If Application.CountA(CurrentSheet.Cells) = 0 Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).Text = _ CurrentSheet.Name If Worksheets(i).Visible < xlSheetVisible Then PrintDlg.CheckBoxes(SheetCount).Value = True End If TopPos = TopPos + 13 End If Next i ' Move the OK and Cancel buttons PrintDlg.Buttons.Left = 240 ' Set dialog height, width, and caption With PrintDlg.DialogFrame .Height = Application.Max _ (68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "Select sheets to export" End With ' Change tab order of OK and Cancel buttons ' so the 1st option button will have the focus PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront ' Display the dialog box '''' CurrentSheet.Activate Application.ScreenUpdating = True If SheetCount < 0 Then If PrintDlg.Show Then Workbooks.Add ' ChDir "C:\Documents and Settings\Em\Desktop" ActiveWorkbook.SaveAs Filename:= _ "C:\Documents and Settings\Nick\Desktop\Centara Feasibility Copy 1.xls", _ ReadOnlyRecommended:=False, CreateBackup:=False For Each CB In PrintDlg.CheckBoxes If CB.Value = xlOn Then Workbooks("Book4.xls").Activate Worksheets(CB.Caption).Activate 'Workbooks("Book4.xls").Activate 'Sheets(CB.SheetCount.Text).Select Range("A1:H30").Select Range("A1:H30").Copy Workbooks("Centara Feasibility Copy 1.xls").Activate Sheets.Add ''''' Sheets(ActiveSheet).Name = PrintDlg.CheckBoxes(SheetCount).Text ''''' ActiveSheet.Name = PrintDlg.CheckBoxes(SheetCount).Text ''''' Range("A1").Select ActiveSheet.Pictures.Paste.Select Selection.ShapeRange.ZOrder msoSendToBack Range("A1").Select Application.CutCopyMode = False Else ActiveSheet.Visible = xlSheetVisible End If Next CB End If Else MsgBox "All worksheets are empty." End If ' Delete temporary dialog sheet (without a warning) Application.DisplayAlerts = False Workbooks("Book4.xls").Sheets(PrintDlg.Name).Delet e ' Reactivate original sheet Cover.Activate End Sub |
Export sheets as JPEG files through a dialog box (Problems)
Thanks for all your help Nick.
Regards Tim "NickHK" wrote in message ... Tim, This works for me. NickHK Sub Export_Sheets() Dim mypass As String Dim i As Integer Dim TopPos As Integer Dim SheetCount As Integer Dim PrintDlg As DialogSheet Dim CurrentSheet As Worksheet Dim CB As CheckBox 'Application.ScreenUpdating = False ' Check for protected workbook If ActiveWorkbook.ProtectStructure Then MsgBox "Workbook is protected.", vbCritical Exit Sub End If ' Add a temporary dialog sheet Set CurrentSheet = ActiveSheet Set PrintDlg = ActiveWorkbook.DialogSheets.Add SheetCount = 0 ' Add the checkboxes TopPos = 40 For i = 1 To ActiveWorkbook.Worksheets.Count Set CurrentSheet = ActiveWorkbook.Worksheets(i) ' Skip empty sheets sheets If Application.CountA(CurrentSheet.Cells) = 0 Then SheetCount = SheetCount + 1 PrintDlg.CheckBoxes.Add 78, TopPos, 150, 16.5 PrintDlg.CheckBoxes(SheetCount).Text = _ CurrentSheet.Name If Worksheets(i).Visible < xlSheetVisible Then PrintDlg.CheckBoxes(SheetCount).Value = True End If TopPos = TopPos + 13 End If Next i ' Move the OK and Cancel buttons PrintDlg.Buttons.Left = 240 ' Set dialog height, width, and caption With PrintDlg.DialogFrame .Height = Application.Max _ (68, PrintDlg.DialogFrame.Top + TopPos - 34) .Width = 230 .Caption = "Select sheets to export" End With ' Change tab order of OK and Cancel buttons ' so the 1st option button will have the focus PrintDlg.Buttons("Button 2").BringToFront PrintDlg.Buttons("Button 3").BringToFront ' Display the dialog box '''' CurrentSheet.Activate Application.ScreenUpdating = True If SheetCount < 0 Then If PrintDlg.Show Then Workbooks.Add ' ChDir "C:\Documents and Settings\Em\Desktop" ActiveWorkbook.SaveAs Filename:= _ "C:\Documents and Settings\Nick\Desktop\Centara Feasibility Copy 1.xls", _ ReadOnlyRecommended:=False, CreateBackup:=False For Each CB In PrintDlg.CheckBoxes If CB.Value = xlOn Then Workbooks("Book4.xls").Activate Worksheets(CB.Caption).Activate 'Workbooks("Book4.xls").Activate 'Sheets(CB.SheetCount.Text).Select Range("A1:H30").Select Range("A1:H30").Copy Workbooks("Centara Feasibility Copy 1.xls").Activate Sheets.Add ''''' Sheets(ActiveSheet).Name = PrintDlg.CheckBoxes(SheetCount).Text ''''' ActiveSheet.Name = PrintDlg.CheckBoxes(SheetCount).Text ''''' Range("A1").Select ActiveSheet.Pictures.Paste.Select Selection.ShapeRange.ZOrder msoSendToBack Range("A1").Select Application.CutCopyMode = False Else ActiveSheet.Visible = xlSheetVisible End If Next CB End If Else MsgBox "All worksheets are empty." End If ' Delete temporary dialog sheet (without a warning) Application.DisplayAlerts = False Workbooks("Book4.xls").Sheets(PrintDlg.Name).Delet e ' Reactivate original sheet Cover.Activate End Sub |
| All times are GMT +1. The time now is 06:42 PM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com