EXCEL插图代码.docx
- 文档编号:7946518
- 上传时间:2023-01-27
- 格式:DOCX
- 页数:16
- 大小:19.84KB
EXCEL插图代码.docx
《EXCEL插图代码.docx》由会员分享,可在线阅读,更多相关《EXCEL插图代码.docx(16页珍藏版)》请在冰豆网上搜索。
EXCEL插图代码
OptionExplicit
DimWithEventsappAsApplication
DimWithEventswkbAsWorkbook
PrivateSubapp_NewWorkbook(ByValWbAsWorkbook)
Setwkb=Wb
EndSub
PrivateSubapp_WorkbookActivate(ByValWbAsWorkbook)
Setwkb=Wb
EndSub
PrivateSubapp_WorkbookOpen(ByValWbAsWorkbook)
Setwkb=Wb
EndSub
'PrivateSubwkb_SheetSelectionChange(ByValShAsObject,ByValTargetAsRange)
'Application.StatusBar="你选择的区域:
"&Replace(Target.Address,"$","")
'EndSub
PrivateSubWorkbook_AddinInstall()
OnErrorResumeNext
'新建菜单栏
WithApplication.CommandBars
(1).Controls.Add(Type:
=msoControlPopup)
.Caption="照片检查(&C)"
With.Controls.Add(Type:
=msoControlButton)
.FaceId=225
.Caption="维修店照片检查(&T)"
.OnAction="检查维修店照片"'HVCenter要调用的程序名称
EndWith
With.Controls.Add(Type:
=msoControlButton)
.FaceId=48
.Caption="人员照片检查(&S)"
.OnAction="检查服务店非技术人员照片"'HVCenter要调用的程序名称
EndWith
With.Controls.Add(Type:
=msoControlButton)
.FaceId=487
.Caption="删除照片并回复行高(&D)"
.OnAction="恢复行高并删除照片"'HVCenter要调用的程序名称
EndWith
With.Controls.Add(Type:
=msoControlButton)
.FaceId=225
.Caption="全自动检查照片(&A)"
.OnAction="全自动检查照片"'HVCenter要调用的程序名称
EndWith
'全自动检查照片
'With.Controls.Add(Type:
=msoControlButton)
'.FaceId=487
'.Caption="接机点照片检查(&J)"
'.OnAction="Guanyu"'HVCenter要调用的程序名称
'EndWith
EndWith
''新建工具栏
'WithApplication.CommandBars.Add(Name:
="myCmdbar")
'.Position=msoBarTop
'With.Controls.Add
'.FaceId=225'工具栏图片形状
'.Caption="自动生成商检单"'HVCenter要调用的程序名称
'.OnAction="HVCenter"
'EndWith
'
'
'
'With.Controls.Add
'.FaceId=48'工具栏图片形状
'.Caption="查看顾客信息"'HVCenter要调用的程序名称
'.OnAction="Jiemi"
'EndWith
'
'
'
'.Visible=True
'EndWith
EndSub
PrivateSubWorkbook_AddinUninstall()
OnErrorResumeNext
DimctlAsCommandBarControl
'卸载工具栏和菜单
Application.CommandBars("myCmdbar").Delete
ForEachctlInApplication.CommandBars
(1).Controls
Ifctl.Caption="照片检查(&C)"Thenctl.Delete
'Ifctl.Caption="商检报告2010(&T)"Thenctl.Delete
Nextctl
Application.StatusBar=False
EndSub
PrivateSubWorkbook_Open()
'关联到Application
Setapp=Application
EndSub
PropertyLetActiveWkb(ByValwkAsWorkbook)
Setwkb=wk
EndProperty
OptionExplicit
PrivatestrActiveWorkbookPathAsString
DimCAsString
Sub全自动检查照片()
DimstrFileNameAsString
DimstrExpNameAsString
IfSheetExists("特约服务中心&单品店")Then
Sheets("特约服务中心&单品店").Select
Else
IfSheetExists("伞下店")ThenSheets("伞下店").Select
EndIf
IfRange("C3")<>"服务店名称"OrLen(Range("C5"))=0Then
MsgBox"请先选中服务店名称"
Range("C5").Select
ExitSub
EndIf
strExpName=ActiveWorkbook.Name
strExpName=Right(strExpName,5)
IfstrExpName<>".xlsx"Then
strExpName=".xls"
EndIf
strFileName=ActiveWorkbook.Path&"\"&Range("C5")&strExpName
'Debug.Print"ActiveWorkbook.Name=";ActiveWorkbook.Name
IfNotFileFolderExists(ActiveWorkbook.Path&"\"&Range("C5")&"\")Then
MkDirActiveWorkbook.Path&"\"&Range("C5")&"\"'就创建一个维修店名称文件夹
EndIf
'将文件夹内的照片全部移动出来
strActiveWorkbookPath=ActiveWorkbook.Path&"\维修店照片\"
IfNotFileFolderExists(strActiveWorkbookPath)Then
MkDirstrActiveWorkbookPath'就创建一个文件夹
Else
MoveFilesFromFolderstrActiveWorkbookPath,ActiveWorkbook.Path&"\"
EndIf
strActiveWorkbookPath=ActiveWorkbook.Path&"\人员照片\"
IfNotFileFolderExists(strActiveWorkbookPath)Then
MkDirstrActiveWorkbookPath'就创建一个文件夹
Else
MoveFilesFromFolderstrActiveWorkbookPath,ActiveWorkbook.Path&"\"'将文件夹中照片移出来
EndIf
'执行文件检查
Sheets("收集照片").Select
Call检查维修店照片
Call恢复行高并删除照片
'
Sheets("服务店非技术人员登记表(一店一表)").Select
Call检查服务店非技术人员照片
Call恢复行高并删除照片
'
Sheets("服务店技术人员登记表(一店一表)").Select
Call检查服务店非技术人员照片
Call恢复行高并删除照片
'隐藏批注
Range("W5:
W6").Select
Selection.ClearComments'删除批注
Range("B7").Select
Sheets("收集照片").Select
Range("B2").Select
ActiveWorkbook.SaveAsFilename:
=strFileName
MsgBox"检查完成"&Chr(13)&Chr(13)&Chr(13)&"设计开发:
西部Team陈友福2015(C)",64,"提示"
EndSub
Sub检查维修店照片()
DimiAsLong
Sheets("收集照片").Select
Application.ScreenUpdating=False
Rows("2:
30").Select
Selection.RowHeight=100
strActiveWorkbookPath=ActiveWorkbook.Path&"\维修店照片\"
IfNotFileFolderExists(strActiveWorkbookPath)Then
MkDirstrActiveWorkbookPath'就创建一个文件夹
EndIf
Fori=1To29'插入29张照片
Call插入图片
Next
'调整大小至合适
DimPicAsPicture',i&
i=[A65536].End(xlUp).Row
ForEachPicInSheet1.Pictures
IfNotApplication.Intersect(Pic.TopLeftCell,Range("B1:
H"&i))IsNothingThen
Pic.Top=Pic.TopLeftCell.Top
Pic.Left=Pic.TopLeftCell.Left
Pic.Height=Pic.TopLeftCell.Height
Pic.Width=Pic.TopLeftCell.Width
EndIf
Next
Range("B2").Select
'恢复显示
Application.ScreenUpdating=True
EndSub
Sub插入图片()
'OnErrorResumeNext
DimXAsLong
DimYAsLong
DimstrPathAsString
DimxlAppAsExcel.Application
'DimFAsNewclsFile
DimFSOAsObject'NewFileSystemObject
DimBAsString
B="B"
SetFSO=CreateObject("Scripting.FileSystemObject")
DimAAAAsString
DimsPAsString
X=ActiveCell.Row
Y=ActiveCell.Column'[A65536].End(xlUp).Row
sP=Range(B&Selection.Row)&".JPG"
strPath=ActiveWorkbook.Path&"\"&sP
Debug.Print"strPath=";strPath
IfFileFolderExists(strPath)Then'如果有照片
DimFolderSelect,shpAsShape
ActiveSheet.Pictures.InsertstrPath'.SelectedItems.Item
(1)
Setshp=ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
shp.LockAspectRatio=msoFalse
shp.Left=Selection
(1).Left
shp.Top=Selection
(1).Top
shp.Width=Selection
(1).Width
shp.Height=Selection
(1).Height
'如果照片存在,就删除批注,并恢复白色底色
Range(B&Selection.Row).Select
WithSelection.Interior
.Pattern=xlNone
.TintAndShade=0
.PatternTintAndShade=0
EndWith
Selection.ClearComments
FSO.MoveFilestrPath,strActiveWorkbookPath&sP
Else'如果没有照片
'如果原名文件不存在,就检查尾缀为-1的照片是否存在
IfFileFolderExists(ActiveWorkbook.Path&"\"&Range(B&Selection.Row)&"-1.JPG")Then'如果有照片
'DimFolderSelect,shpAsShape
ActiveSheet.Pictures.InsertActiveWorkbook.Path&"\"&Range(B&Selection.Row)&"-1.JPG"'.SelectedItems.Item
(1)
Setshp=ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
shp.LockAspectRatio=msoFalse
shp.Left=Selection
(1).Left
shp.Top=Selection
(1).Top
shp.Width=Selection
(1).Width
shp.Height=Selection
(1).Height
'如果照片存在,就删除批注,并恢复白色底色
Range(B&Selection.Row).Select
WithSelection.Interior
.Pattern=xlNone
.TintAndShade=0
.PatternTintAndShade=0
EndWith
Selection.ClearComments
FSO.MoveFileActiveWorkbook.Path&"\"&Range(B&Selection.Row)&"-1.JPG",strActiveWorkbookPath&Range(B&Selection.Row)&"-1.JPG"
Else
'先删除批注,并恢复白色底色(否则:
如果单元格中已有批注时,就会报错)
Range(B&Selection.Row).Select
WithSelection.Interior
.Pattern=xlNone
.TintAndShade=0
.PatternTintAndShade=0
EndWith
Selection.ClearComments
'重新添加批注
WithRange(B&Selection.Row)
.Select
.AddComment
.Comment.Visible=False
.Comment.TextText:
="无照片"
.Comment.Visible=False
EndWith
WithSelection.Interior
'浅蓝底色
.Pattern=xlSolid
.PatternColorIndex=xlAutomatic
.Color=15773696
.TintAndShade=0
.PatternTintAndShade=0
EndWith
EndIf
EndIf
ActiveCell.FormulaR1C1 = ""
If FileFolderExists(ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-1.JPG") Then '如果有照片
' Dim FolderSelect, shp As Shape
ActiveSheet.Pictures.Insert ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-1.JPG" ' .SelectedItems.Item
(1)
Set shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
shp.LockAspectRatio = msoFalse
shp.Left = Selection
(1).Left
shp.Top = Selection
(1).Top
shp.Width = Selection
(1).Width
shp.Height = Selection
(1).Height
FSO.MoveFile ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-1.JPG", strActiveWorkbookPath & Range(B & Selection.Row) & "-1.JPG"
' ActiveCell.FormulaR1C1 = ""
End If
If FileFolderExists(ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-2.JPG") Then '如果有照片
' Dim FolderSelect, shp As Shape
ActiveSheet.Pictures.Insert ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-2.JPG" ' .SelectedItems.Item
(1)
Set shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
shp.LockAspectRatio = msoFalse
shp.Left = Selection
(1).Left
shp.Top = Selection
(1).Top
shp.Width = Selection
(1).Width
shp.Height = Selection
(1).Height
FSO.MoveFile ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-2.JPG", strActiveWorkbookPath & Range(B & Selection.Row) & "-2.JPG"
' ActiveCell.FormulaR1C1 = ""
End If
If FileFolderExists(ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-3.JPG") Then '如果有照片
' Dim FolderSelect, shp As Shape
ActiveSheet.Pictures.Insert ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-3.JPG" ' .SelectedItems.Item
(1)
Set shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
shp.LockAspectRatio = msoFalse
shp.Left = Selection
(1).Left
shp.Top = Selection
(1).Top
shp.Width = Selection
(1).Width
shp.Height = Selection
(1).Height
FSO.MoveFile ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-3.JPG", strActiveWorkbookPath & Range(B & Selection.Row) & "-3.JPG"
' ActiveCell.FormulaR1C1 = ""
End If
If FileFolderExists(ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-4.JPG") Then '如果有照片
' Dim FolderSelect, shp As Shape
ActiveSheet.Pictures.Insert ActiveWorkbook.Path & "\" & Range(B & Selection.Row) & "-4.JPG" ' .SelectedItems.Item
(1)
Set shp = Acti
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- EXCEL 插图 代码