EXCEL插图代码Word格式文档下载.docx
《EXCEL插图代码Word格式文档下载.docx》由会员分享，可在线阅读，更多相关《EXCEL插图代码Word格式文档下载.docx（16页珍藏版）》请在冰豆网上搜索。
=msoControlButton）
.FaceId=225
维修店照片检查（&
T）"
.OnAction="
检查维修店照片"
HVCenter要调用的程序名称
EndWith
.FaceId=48
人员照片检查（&
S）"
检查服务店非技术人员照片"
.FaceId=487
删除照片并回复行高（&
D）"
恢复行高并删除照片"
全自动检查照片（&
A）"
全自动检查照片"
全自动检查照片
接机点照片检查（&
J）"
Guanyu"
新建工具栏
WithApplication.CommandBars.Add（Name:
="
myCmdbar"
.Position=msoBarTop
With.Controls.Add
.FaceId=225'
工具栏图片形状
自动生成商检单"
HVCenter"
.FaceId=48'
查看顾客信息"
Jiemi"
.Visible=True
PrivateSubWorkbook_AddinUninstall（）
DimctlAsCommandBarControl
卸载工具栏和菜单
Application.CommandBars（"
）.Delete
ForEachctlInApplication.CommandBars
（1）.Controls
Ifctl.Caption="
Thenctl.Delete
Ifctl.Caption="
商检报告2010（&
Nextctl
Application.StatusBar=False
PrivateSubWorkbook_Open（）
关联到Application
Setapp=Application
PropertyLetActiveWkb（ByValwkAsWorkbook）
Setwkb=wk
EndProperty
PrivatestrActiveWorkbookPathAsString
DimCAsString
Sub全自动检查照片（）
DimstrFileNameAsString
DimstrExpNameAsString
IfSheetExists（"
特约服务中心&
单品店"
）Then
Sheets（"
）.Select
Else
伞下店"
）ThenSheets（"
EndIf
IfRange（"
C3"
）<
>
"
服务店名称"
OrLen（Range（"
C5"
））=0Then
MsgBox"
请先选中服务店名称"
Range（"
ExitSub
strExpName=ActiveWorkbook.Name
strExpName=Right（strExpName,5）
IfstrExpName<
.xlsx"
Then
strExpName="
.xls"
strFileName=ActiveWorkbook.Path&
\"
）&
strExpName
Debug.Print"
ActiveWorkbook.Name="
;
ActiveWorkbook.Name
IfNotFileFolderExists（ActiveWorkbook.Path&
MkDirActiveWorkbook.Path&
就创建一个维修店名称文件夹
将文件夹内的照片全部移动出来
strActiveWorkbookPath=ActiveWorkbook.Path&
\维修店照片\"
IfNotFileFolderExists（strActiveWorkbookPath）Then
MkDirstrActiveWorkbookPath'
就创建一个文件夹
MoveFilesFromFolderstrActiveWorkbookPath,ActiveWorkbook.Path&
\人员照片\"
将文件夹中照片移出来
执行文件检查
收集照片"
Call检查维修店照片
Call恢复行高并删除照片
服务店非技术人员登记表（一店一表）"
Call检查服务店非技术人员照片
服务店技术人员登记表（一店一表）"
隐藏批注
W5:
W6"
Selection.ClearComments'
删除批注
B7"
B2"
ActiveWorkbook.SaveAsFilename:
=strFileName
检查完成"
Chr（13）&
设计开发：
西部Team陈友福2015（C）"
64,"
提示"
Sub检查维修店照片（）
DimiAsLong
Application.ScreenUpdating=False
Rows（"
2:
30"
Selection.RowHeight=100
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
恢复显示
Application.ScreenUpdating=True
Sub插入图片（）
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
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
Selection.ClearComments
FSO.MoveFilestrPath,strActiveWorkbookPath&
Else'
如果没有照片
如果原名文件不存在，就检查尾缀为-1的照片是否存在
IfFileFolderExists（ActiveWorkbook.Path&
-1.JPG"
）Then'
ActiveSheet.Pictures.InsertActiveWorkbook.Path&
FSO.MoveFileActiveWorkbook.Path&
strActiveWorkbookPath&
先删除批注，并恢复白色底色（否则：
如果单元格中已有批注时，就会报错）
重新添加批注
WithRange（B&
Selection.Row）
.Select
.AddComment
.Comment.Visible=False
.Comment.TextText:
无照片"
浅蓝底色
.Pattern=xlSolid
.PatternColorIndex=xlAutomatic
.Color=15773696
EndIf
ActiveCell.FormulaR1C1
=
If
FileFolderExists（ActiveWorkbook.Path
&
Range（B
Selection.Row）
）
Then
Dim
FolderSelect,
shp
As
Shape
ActiveSheet.Pictures.Insert
ActiveWorkbook.Path
.SelectedItems.Item
（1）
Set
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
strActiveWorkbookPath
End
If
-2.JPG"
-3.JPG"
-4.JPG"
Acti
升级会员 