第4章--Shape(图形)、Chart(图表)对象代码【超实用VBA】

32第4章Shape（图形）、Chart（图表）对象范例47在工作表中添加图形SubAddingGraphics()DimMyShapeAsShapeOnErrorResumeNextSheet1.Shapes(MyShape).DeleteSetMyShape=Sheet1.Shapes.AddShape(msoShapeRectangle,40,120,280,30)WithMyShape.Name=MyShapeWith.TextFrame.Characters.Text=单击将选择Sheet2!With.Font.Size=20.ColorIndex=5EndWithEndWithWith.Line.Weight=1.Style=msoLineSingle.Transparency=0.5.ForeColor.SchemeColor=40.BackColor.RGB=RGB(255,255,255)EndWithWith.Fill.Transparency=0.5.ForeColor.SchemeColor=41.OneColorGradient1,4,0.23EndWith.Placement=3EndWithSheet1.Hyperlinks.AddAnchor:=MyShape,Address:=,_SubAddress:=Sheet2!A1,ScreenTip:=选择Sheet2!SetMyShape=NothingEndSub33范例48导出工作表中的图片SubExportPictures()DimMyShpAsShapeDimFilenameAsStringForEachMyShpInSheet1.ShapesIfMyShp.Type=msoPictureThenFilename=ThisWorkbook.Path&\&MyShp.Name&.gifMyShp.CopyWithSheet1.ChartObjects.Add(0,0,MyShp.Width,MyShp.Height).Chart.Paste.ExportFilename.Parent.DeleteEndWithEndIfNextSetMyShp=NothingEndSub范例49在工作表中添加艺术字SubAddingWordArt()OnErrorResumeNextSheet1.Shapes(MyShape).DeleteSheet1.Shapes.AddTextEffect_(PresetTextEffect:=msoTextEffect16,_Text:=Excel2007,FontName:=宋体,_FontSize:=50,FontBold:=True,_FontItalic:=True,Left:=60,Top:=60).Name=MyShapeEndSub范例50遍历工作表中的形状SubTraversalShapeOne()DimiAsIntegerFori=1To4Sheet1.Shapes(文本框&i).TextFrame.Characters.Text=NextEndSubSubTraversalShapeTwo()34DimMyShapeAsShapeDimMyCountAsIntegerMyCount=1ForEachMyShapeInSheet1.ShapesIfMyShape.Type=msoTextBoxThenMyShape.TextFrame.Characters.Text=第&MyCount&个文本框MyCount=MyCount+1EndIfNextSetMyShape=NothingEndSub范例51移动、旋转图形SubMoveAndRotate()DimiAsLongDimjAsLongWithSheet1.Shapes(1)Fori=1To3000Step5.Top=Sin(i*(3.1415926535/180))*100+100.Left=Cos(i*(3.1415926535/180))*100+100.Fill.ForeColor.RGB=i*100Forj=1To20.IncrementRotation-2DoEventsNextNextEndWithEndSub范例52自动插入图片SubInsertPicture()DimMyShapeAsShapeDimrAsIntegerDimcAsIntegerDimPicPathAsStringDimPicrngAsRangeWithSheet1ForEachMyShapeIn.ShapesIfMyShape.Type=13ThenMyShape.DeleteEndIf35NextForr=2To.Cells(.Rows.Count,1).End(xlUp).RowForc=1To8Step2PicPath=ThisWorkbook.Path&\&.Cells(r,c).Text&.jpgIfDir(PicPath)ThenSetMyShape=.Shapes.AddPicture(PicPath,False,True,6,6,6,6)SetPicrng=.Cells(r,c+1)WithMyShape.LockAspectRatio=msoFalse.Top=Picrng.Top+1.Left=Picrng.Left+1.Width=Picrng.Width-1.5.Height=Picrng.Height-1.5.TopLeftCell=EndWithElse.Cells(r,c+1)=暂无照片EndIfNextNextEndWithSetMyShape=NothingSetPicrng=NothingEndSub范例53固定图片的尺寸和位置SubFixedPicture()DimPicrngAsRangeSetPicrng=Range(B4:E22)WithSheet1.Shapes(1).Rotation=0.Top=Picrng.Top-1.Left=Picrng.Left-1.Width=Picrng.Width+1.Height=Picrng.Height+1EndWithSetPicrng=NothingEndSub36范例54使用VBA自动生成图表SubProductionCharts()DimrAsIntegerDimrngAsRangeDimMyChartAsChartObjectOnErrorResumeNextWithSheet1.ChartObjects(MyChart).Deleter=.Cells(.Rows.Count,1).End(xlUp).RowSetrng=.Range(.Cells(1,1),.Cells(r,2))SetMyChart=.ChartObjects.Add(120,40,400,250)MyChart.Name=MyChartWithMyChart.Chart.ChartType=xl3DColumnClustered.SetSourceDataSource:=rng,PlotBy:=xlColumns.ApplyDataLabelsShowValue:=True.HasTitle=TrueWith.ChartTitle.Text=图表制作示例.Font.Name=宋体.Font.Size=14EndWithEndWithEndWithSetrng=NothingSetMyChart=NothingEndSub范例55批量制作图表SubProductionCharts()DimMyChartAsChartObjectDimiAsIntegerDimrAsIntegerDimmAsIntegerOnErrorResumeNextSheet2.ChartObjects.DeleteWithSheet1r=.Cells(.Rows.Count,1).End(xlUp).Row-1m=Abs(Int(-(r/4)))Fori=1TorSetMyChart=Sheet2.ChartObjects.Add_37(Left:=(((i-1)Modm)+1)*350-340,_Top:=((i-1)\m+1)*220-210,_Width:=300,Height:=200)MyChart.Name=.Range(A2).Offset(i-1)WithMyChart.Chart.ChartType=xl3DColumnStacked.SetSourceDataSource:=Sheet1.Range(B2:M2).Offset(i-1),_PlotBy:=xlRows.HasTitle=True.HasLegend=FalseWith.ChartTitle.Text=Sheet1.Range(A2).Offset(i-1).Font.Name=宋体.Font.Size=12EndWithEndWithNextEndWithSheet2.SelectSetMyChart=NothingEndSub范例56导出工作表中的图表SubExportChart()DimChartPathAsStringChartPath=ThisWorkbook.Path&\&MyChart.jpgOnErrorResumeNextKillChartPathSheet1.ChartObjects(1).Chart.ExportFileName:=ChartPath,Filtername:=JPGMsgBox图表已保存在&ThisWorkbook.Path&文件夹中!EndSub