FAQ 【Shape 物件】｛建立中｝

Emily

FAQ 【Shape 物件】｛建立中｝

只删除指定区域的贴图

请参考【只删除指定区域的贴图】

如何快速删除工作表中的图片

请参考【如何快速删除工作表中的图片 Chijanzen】

运用Excel VBA宏来操控Office小帮手

请参考 台湾洪士吉先生的 【运用Excel VBA宏来操控Office小帮手】 ------

[此贴子已经被作者于2005-3-9 21:35:03编辑过]

Emily

在新板本的 Excel 有拍照这个工能，以下编码可将打印范围拍照储存成 Gif 档。它的方法亦很特别

Sub ScreenShot()
Dim wks As Worksheet
Dim cht As Chart
Dim intCounter As Integer
Application.ScreenUpdating = False
   Set wks = ActiveSheet
   wks.Range(wks.PageSetup.PrintArea).CopyPicture Appearance:=xlScreen, _
   format:=xlPicture
   Set cht = Charts.Add
   With cht
       On Error Resume Next
       .Paste
       On Error GoTo 0
   End With
   cht.Export "c:\temp\" & wks.Name & ".gif"
   Application.DisplayAlerts = False
   cht.Delete
   Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Excel 转换图像到 WorkSheet

请参考【Excel 轉換圖像】

一个可以将 Excel 选取范围转成 JPG 格式的 Add-in ,[Emily 分享] 3/F

[此贴子已经被作者于2006-9-23 9:46:33编辑过]

Emily

Set CmdBar = Application.CommandBars(1)
Set CmdBarMenu = CmdBar.Controls(5)
Set CheckBackGnd = CmdBarMenu.Controls(4).Controls(4)
If CheckBackGnd.Caption = 删除背景(&D)" Then
     MsgBox "已有背景图"
Else
     MsgBox "没有背景图"
End If

[此贴子已经被作者于2006-9-23 9:46:01编辑过]

Emily

如何在设定批注的文本框的宽度的情况下使高度自动调整以适应其中所包含的文字

Sub Comments_AutoSize()
  Dim MyComments As Comment
  Dim lArea As Long
  For Each MyComments In ActiveSheet.Comments
    With MyComments
      .Shape.TextFrame.AutoSize = True
      If .Shape.Width <> 200 Then
        lArea = .Shape.Width * .Shape.Height
        .Shape.Width = 200
        .Shape.Height = (lArea / 200)
      End If
    End With
  Next
End Sub

[此贴子已经被作者于2006-9-23 9:45:29编辑过]

Emily

Scaled-in-cell-charting

Usage: =linechart(A3:E3,203,$A$3:$E$8) ' A3:E8 numeric data, 203 is RGB value
 

Function LineChart(Points As Range, Color As Long, Optional VerticalScale As Range) As String
   
    Dim rCaller As Range
    Dim avNames() As Variant
    Dim i As Long, j As Long, k As Long
    Dim dMin As Double, dMax As Double, dScaleMin As Double, dScaleMax As Double
    Dim shp As Shape
    Dim rScale As Range
    Dim dEffWidth As Double, dEffHeight As Double, dEffBottom As Double, dEffLeft As Double
   
    Const lMARGIN As Long = 2
    Set rCaller = Application.Caller
    ShapeDelete rCaller
    'If VerticalScale Is Nothing Then
    '    Set rScale = Points
    'Else
    '    Set rScale = VerticalScale
    'End If
    If VerticalScale Is Nothing Then
        Set rScale = Points
    Else
        If Not Application.Intersect(Points, VerticalScale) Is Nothing Then
            If Application.Intersect(Points, VerticalScale).Address = _
                Points.Address Then
                Set rScale = VerticalScale
            Else
                Set rScale = Application.Union(Points, VerticalScale)
            End If
        Else
            Set rScale = Application.Union(Points, VerticalScale)
        End If
    End If

    With Application.WorksheetFunction
        dMin = .Min(Points)
        dMax = .Max(Points)
        dScaleMin = .Min(rScale)
        dScaleMax = .Max(rScale)
    End With
   
    dEffWidth = rCaller.Width - (lMARGIN * 2)
    dEffHeight = rCaller.Height - (lMARGIN * 2)
    dEffBottom = rCaller.Top + lMARGIN + dEffHeight
    dEffLeft = rCaller.Left + lMARGIN
   
    With rCaller.Worksheet.Shapes
        For i = 0 To Points.Count - 2
           Set shp = .AddLine( _
                dEffLeft + (i * (dEffWidth) / (Points.Count - 1)), _
                dEffBottom - (dEffHeight * (Points(, i + 1) - dScaleMin + 1) / (dScaleMax - dScaleMin + 1)), _
                dEffLeft + ((i + 1) * (dEffWidth) / (Points.Count - 1)), _
                dEffBottom - (dEffHeight * (Points(, i + 2) - dScaleMin + 1) / (dScaleMax - dScaleMin + 1)))

            On Error Resume Next
                j = 0
                j = UBound(avNames) + 1
            On Error GoTo 0
            ReDim Preserve avNames(j)
            avNames(j) = shp.Name
        Next
        With rCaller.Worksheet.Shapes.Range(avNames)
            .Group
            .Line.ForeColor.RGB = Abs(Color)
        End With
    End With
    LineChart = ""
   
End Function

Sub ShapeDelete(rngSelect As Range)
    Dim rng As Range, shp As Shape, blnDelete As Boolean

    For Each shp In rngSelect.Worksheet.Shapes
        blnDelete = False
        Set rng = Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rngSelect)
        If Not rng Is Nothing Then
            If rng.Address = Range(shp.TopLeftCell, shp.BottomRightCell).Address Then blnDelete = True
        End If
        If blnDelete Then shp.Delete
    Next
End Sub

下载

Orginal Source:  http://www.dailydoseofexcel.com/archives/2006/09/13/scaled-in-cell-charting/

[此贴子已经被作者于2006-9-23 9:42:50编辑过]