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
升级会员 