四月 « 2006 « chijanzen 雜貨舖

Archive for 四月, 2006

Filed under: Excel VBA 範例, shape 將儲存格範圍另存為圖片 by chijanzen on 四月 2nd, 2006

索引	H0064
主題	將儲存格範圍另存為圖片
版本	>= 10.0(Office 2002)
說明	有網友問我如何將儲存格中選取的範圍另存為圖片，這才讓我想起我曾經寫過這樣一個小程式，我將它重新整理了一下重新發表。本範例可以選擇複製到剪貼簿或另存圖片檔，總共有三個選項可以選擇: 格線:是否顯示儲存格的格線同時印出列和欄標題:是否顯示列和欄標題黑白複製:是忽略儲存格的顏色
參考

Code

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.CommandBars(3).Controls("RngToPic").Delete
End Sub

Private Sub Workbook_Open()
Dim rngBtn As CommandBarControl
On Error Resume Next

    Application.CommandBars(3).Controls("RngToPic").Delete
    Set rngBtn = Application.CommandBars(3).Controls.Add
    With rngBtn
        .FaceId = 246
        .OnAction = "show"
        .Caption = "RngToPic"
        .TooltipText = "儲存格轉換為圖片"
        .Enabled = True
    End With
    Err = 0
End Sub

Code

Sub show()
CtoPForm.show
End Sub

Sub SavePic()
    Dim msg As String
    Dim rChart As Chart
    msg = "圖片另存檔案"
    fileSaveName = Application.GetSaveAsFilename(InitialFileName:="pic1", _
            fileFilter:="Gif Files (*.jpg), *.jpg", Title:=msg)
    If fileSaveName <> False Then
        Set rChart = ActiveSheet.ChartObjects.Add(0, 0, Range(CtoPForm.RefEdit1). _
                Width, Range(CtoPForm.RefEdit1).Height).Chart
        With rChart
            '去除圖表外框線
            '如果把這行刪除，圖片會多外框
            .ChartArea.Border.LineStyle = 0
            On Error Resume Next
            .Paste
&nbs
p;           '圖形格式匯出
            .Export fileSaveName, "JPG"
            Application.DisplayAlerts = False
            '刪除圖表
            .Parent.Delete
            Application.DisplayAlerts = True
        End With
    End If
End Sub

Code

Dim Print_Headings As Boolean
Dim Print_Gridlines As Boolean

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub RangeCopy_Click()
    Application.ScreenUpdating = False
    If Me.RefEdit1.Text = "" Then MsgBox _
            "請先選取儲存格範圍後,再按 ""Copy"" 鈕": Exit Sub

    If Range(Me.RefEdit1.Text).Areas.Count > 1 Then
        MsgBox "本操作介面不允許使用者多重選取範圍,請重新選取範圍"
        RefEdit1.Text = ""
        Exit Sub
    End If
    Me.Hide
    Me.MousePointer = fmMousePointerHourGlass   '將游標設成漏斗狀
    With ActiveSheet.PageSetup
        '儲存工作表的PrintHeadings
        Print_Headings = .PrintHeadings
        '儲存工作表的PrintGridlines
        Print_Gridlines = .PrintGridlines
        Print_BAndW = .BlackAndWhite
        .PrintHeadings = chkHeadings
        .PrintGridlines = chkGridlines
        .BlackAndWhite = chkcolor
        '將螢幕影像複製到剪貼簿
        Range(RefEdit1.Text).CopyPicture Appearance:=xlPrinter, _
                Format:=xlPicture
        '還原工作表的PrintHeadings
        .PrintHeadings = Print_Headings
        '還原工作表的PrintGridlines
        .PrintGridlines = Print_Gridlines
        .BlackAndWhite = Print_BAndW
    End With
    If Me.OptionButton1 = True Then
        Call SavePic
        Unload Me
        Application.ScreenUpdating = True
        Exit Sub
    End If
    Me.MousePointer = fmMousePointerDefault     '還原預設值
    MsgBox "圖片已複製至剪貼簿. 請使用編輯-貼上貼上圖片" _
            & vbCrLf & "可應用於其它Office軟體,及其它繪圖軟體"
    Beep
    Unload Me
    Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Initialize()
    chkGridlines = True
    chkHeadings = True
    chkcolor = False
End Sub

Help

Code

本範例不允許多重選取範圍

DownLoad

Code

Popularity: 7%