EXCEL插图代码

1、Option ExplicitDim WithEvents app As ApplicationDim WithEvents wkb As WorkbookPrivate Sub app_NewWorkbook(ByVal Wb As Workbook) Set wkb = WbEnd SubPrivate Sub app_WorkbookActivate(ByVal Wb As Workbook) Set wkb = WbEnd SubPrivate Sub app_WorkbookOpen(ByVal Wb As Workbook) Set wkb = WbEnd Sub'Priv

2、ate Sub wkb_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)' Application.StatusBar = "你选择的区域:" & Replace(Target.Address, "$", "")'End SubPrivate Sub Workbook_AddinInstall() On Error Resume Next '新建菜单栏 With Application.CommandBars(1).Contr

3、ols.Add(Type:=msoControlPopup) .Caption = "照片检查(&C)" With .Controls.Add(Type:=msoControlButton) .FaceId = 225 .Caption = "维修店照片检查(&T)" .OnAction = "检查维修店照片" 'HVCenter 要调用的程序名称 End With With .Controls.Add(Type:=msoControlButton) .FaceId = 48 .Caption = "

4、人员照片检查(&S)" .OnAction = "检查服务店非技术人员照片" 'HVCenter 要调用的程序名称 End With With .Controls.Add(Type:=msoControlButton) .FaceId = 487 .Caption = "删除照片并回复行高(&D)" .OnAction = "恢复行高并删除照片" 'HVCenter 要调用的程序名称 End With With .Controls.Add(Type:=msoControlButton) .Fa

5、ceId = 225 .Caption = "全自动检查照片(&A)" .OnAction = "全自动检查照片" 'HVCenter 要调用的程序名称 End With '全自动检查照片 ' With .Controls.Add(Type:=msoControlButton) ' .FaceId = 487 ' .Caption = "接机点照片检查(&J)" ' .OnAction = "Guanyu" 'HVCenter 要调用的程序名称

6、 ' End With End With ' '新建工具栏 ' With Application.CommandBars.Add(Name:="myCmdbar") ' .Position = msoBarTop ' With .Controls.Add ' .FaceId = 225 '工具栏图片形状 ' .Caption = "自动生成商检单" 'HVCenter 要调用的程序名称 ' .OnAction = "HVCenter" '

7、End With ' ' ' ' With .Controls.Add ' .FaceId = 48 '工具栏图片形状 ' .Caption = "查看顾客信息" 'HVCenter 要调用的程序名称 ' .OnAction = "Jiemi" ' End With ' ' ' ' .Visible = True ' End WithEnd SubPrivate Sub Workbook_AddinUninstall() On Erro

8、r Resume Next Dim ctl As CommandBarControl '卸载工具栏和菜单 Application.CommandBars("myCmdbar").Delete For Each ctl In Application.CommandBars(1).Controls If ctl.Caption = "照片检查(&C)" Then ctl.Delete 'If ctl.Caption = "商检报告2010(&T)" Then ctl.Delete Next ctl Appl

9、ication.StatusBar = FalseEnd SubPrivate Sub Workbook_Open() '关联到Application Set app = ApplicationEnd SubProperty Let ActiveWkb(ByVal wk As Workbook) Set wkb = wkEnd PropertyOption ExplicitPrivate strActiveWorkbookPath As StringDim C As StringSub 全自动检查照片() Dim strFileName As String Dim strExpName

10、 As String If SheetExists("特约服务中心&单品店") Then Sheets("特约服务中心&单品店").Select Else If SheetExists("伞下店") Then Sheets("伞下店").Select End If If Range("C3") <> "服务店名称" Or Len(Range("C5") = 0 Then MsgBox "请先选中服务店名称"

11、Range("C5").Select Exit Sub End If strExpName = ActiveWorkbook.Name strExpName = Right(strExpName, 5) If strExpName <> ".xlsx" Then strExpName = ".xls" End If strFileName = ActiveWorkbook.Path & "" & Range("C5") & strExpName 'De

12、bug.Print "ActiveWorkbook.Name = " ActiveWorkbook.Name If Not FileFolderExists(ActiveWorkbook.Path & "" & Range("C5") & "") Then MkDir ActiveWorkbook.Path & "" & Range("C5") & "" '就创建一个维修店名称文件夹 End If &

13、#39;将文件夹内的照片全部移动出来 strActiveWorkbookPath = ActiveWorkbook.Path & "维修店照片" If Not FileFolderExists(strActiveWorkbookPath) Then MkDir strActiveWorkbookPath '就创建一个文件夹 Else MoveFilesFromFolder strActiveWorkbookPath, ActiveWorkbook.Path & "" End If strActiveWorkbookPath = A

14、ctiveWorkbook.Path & "人员照片" If Not FileFolderExists(strActiveWorkbookPath) Then MkDir strActiveWorkbookPath '就创建一个文件夹 Else MoveFilesFromFolder strActiveWorkbookPath, ActiveWorkbook.Path & "" '将文件夹中照片移出来 End If '执行文件检查 Sheets("收集照片").Select Call 检查维修店

15、照片 Call 恢复行高并删除照片 ' Sheets("服务店非技术人员登记表（一店一表）").Select Call 检查服务店非技术人员照片 Call 恢复行高并删除照片 ' Sheets("服务店技术人员登记表（一店一表）").Select Call 检查服务店非技术人员照片 Call 恢复行高并删除照片 '隐藏批注 Range("W5:W6").Select Selection.ClearComments '删除批注 Range("B7").Select Sheets(&qu

16、ot;收集照片").Select Range("B2").Select ActiveWorkbook.SaveAs Filename:=strFileName MsgBox "检查完成" & Chr(13) & Chr(13) & Chr(13) & " 设计开发： 西部Team 陈友福 2015 (C) ", 64, "提示"End SubSub 检查维修店照片() Dim i As Long Sheets("收集照片").Select Applica

17、tion.ScreenUpdating = False Rows("2:30").Select Selection.RowHeight = 100 strActiveWorkbookPath = ActiveWorkbook.Path & "维修店照片" If Not FileFolderExists(strActiveWorkbookPath) Then MkDir strActiveWorkbookPath '就创建一个文件夹 End If For i = 1 To 29 '插入29张照片 Call 插入图片 Next 

18、9;调整大小至合适 Dim Pic As Picture ', i& i = A65536.End(xlUp).Row For Each Pic In Sheet1.Pictures If Not Application.Intersect(Pic.TopLeftCell, Range("B1:H" & i) Is Nothing Then Pic.Top = Pic.TopLeftCell.Top Pic.Left = Pic.TopLeftCell.Left Pic.Height = Pic.TopLeftCell.Height Pic.Widt

19、h = Pic.TopLeftCell.Width End If Next Range("B2").Select '恢复显示 Application.ScreenUpdating = TrueEnd SubSub 插入图片() ' On Error Resume Next Dim X As Long Dim Y As Long Dim strPath As String Dim xlApp As Excel.Application ' Dim F As New clsFile Dim FSO As Object 'New FileSystem

20、Object Dim B As String B = "B" Set FSO = CreateObject("Scripting.FileSystemObject") Dim AAA As String Dim sP As String X = ActiveCell.Row Y = ActiveCell.Column ' A65536.End(xlUp).Row sP = Range(B & Selection.Row) & ".JPG" strPath = ActiveWorkbook.Path &

21、"" & sPDebug.Print "strPath = " strPath If FileFolderExists(strPath) Then '如果有照片 Dim FolderSelect, shp As Shape ActiveSheet.Pictures.Insert strPath ' .SelectedItems.Item(1) Set shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count) shp.LockAspectRatio = msoFalse shp.Left

22、= Selection(1).Left shp.Top = Selection(1).Top shp.Width = Selection(1).Width shp.Height = Selection(1).Height '如果照片存在，就删除批注，并恢复白色底色 Range(B & Selection.Row).Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.ClearComments FSO.MoveF

23、ile strPath, strActiveWorkbookPath & sP Else '如果没有照片 '如果原名文件不存在，就检查尾缀为-1的照片是否存在 If FileFolderExists(ActiveWorkbook.Path & "" & Range(B & Selection.Row) & "-1.JPG") Then '如果有照片 ' Dim FolderSelect, shp As Shape ActiveSheet.Pictures.Insert ActiveW

24、orkbook.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.He

25、ight = Selection(1).Height '如果照片存在，就删除批注，并恢复白色底色 Range(B & Selection.Row).Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.ClearComments FSO.MoveFile ActiveWorkbook.Path & "" & Range(B & Selection.Row) &

26、"-1.JPG", strActiveWorkbookPath & Range(B & Selection.Row) & "-1.JPG" Else '先删除批注，并恢复白色底色（否则：如果单元格中已有批注时，就会报错） Range(B & Selection.Row).Select With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Selection.ClearComments

27、 '重新添加批注 With Range(B & Selection.Row) .Select .AddComment .Comment.Visible = False .Comment.Text Text:="无照片" .Comment.Visible = False End With With Selection.Interior '浅蓝底色 .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 15773696 .TintAndShade = 0 .PatternTintAndS

28、hade = 0 End With End IfEnd IfActiveCell.FormulaR1C1 = ""    If FileFolderExists(ActiveWorkbook.Path & "" & Range(B & Selection.Row) & "-1.JPG") Then    &

29、#160; '如果有照片        '        Dim FolderSelect, shp As Shape        ActiveSheet.Pictures.Insert ActiveWorkbook.Path & ""

30、; & Range(B & Selection.Row) & "-1.JPG"    ' .SelectedItems.Item(1)        Set shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)      

31、;  shp.LockAspectRatio = msoFalse        shp.Left = Selection(1).Left        shp.Top = Selection(1).Top        shp.Width = Selecti

32、on(1).Width        shp.Height = Selection(1).Height        FSO.MoveFile ActiveWorkbook.Path & "" & Range(B & Selection.Row) & "-1.JPG&

33、quot;, strActiveWorkbookPath & Range(B & Selection.Row) & "-1.JPG"        '        ActiveCell.FormulaR1C1 = ""    End&#

34、160;If    If FileFolderExists(ActiveWorkbook.Path & "" & Range(B & Selection.Row) & "-2.JPG") Then      '如果有照片        &#

35、39;        Dim FolderSelect, shp As Shape        ActiveSheet.Pictures.Insert ActiveWorkbook.Path & "" & Range(B & Selection.Row) &

36、0;"-2.JPG"    ' .SelectedItems.Item(1)        Set shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)        shp.LockAspectRatio = msoFalse   

37、     shp.Left = Selection(1).Left        shp.Top = Selection(1).Top        shp.Width = Selection(1).Width        shp.Height&#

38、160;= Selection(1).Height        FSO.MoveFile ActiveWorkbook.Path & "" & Range(B & Selection.Row) & "-2.JPG", strActiveWorkbookPath & Range(B &

39、60;Selection.Row) & "-2.JPG"        '        ActiveCell.FormulaR1C1 = ""    End If    If FileFolderExists(ActiveWorkbook.P

40、ath & "" & Range(B & Selection.Row) & "-3.JPG") Then      '如果有照片        '        Dim FolderSelec

41、t, shp As Shape        ActiveSheet.Pictures.Insert ActiveWorkbook.Path & "" & Range(B & Selection.Row) & "-3.JPG"    ' .SelectedItems.I

42、tem(1)        Set shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)        shp.LockAspectRatio = msoFalse        shp.Left = Selection(1).Left

43、60;       shp.Top = Selection(1).Top        shp.Width = Selection(1).Width        shp.Height = Selection(1).Height       

44、; FSO.MoveFile ActiveWorkbook.Path & "" & Range(B & Selection.Row) & "-3.JPG", strActiveWorkbookPath & Range(B & Selection.Row) & "-3.JPG"   &

45、#160;    '        ActiveCell.FormulaR1C1 = ""    End If    If FileFolderExists(ActiveWorkbook.Path & "" & Range(B &

46、0;Selection.Row) & "-4.JPG") Then      '如果有照片        '        Dim FolderSelect, shp As Shape       

47、; ActiveSheet.Pictures.Insert ActiveWorkbook.Path & "" & Range(B & Selection.Row) & "-4.JPG"    ' .SelectedItems.Item(1)        Set shp 

48、;= ActiveSheet.Shapes(ActiveSheet.Shapes.Count)        shp.LockAspectRatio = msoFalse        shp.Left = Selection(1).Left        shp.Top = Select

49、ion(1).Top        shp.Width = Selection(1).Width        shp.Height = Selection(1).Height        FSO.MoveFile ActiveWorkbook.Path & "&quo

50、t; & Range(B & Selection.Row) & "-4.JPG", strActiveWorkbookPath & Range(B & Selection.Row) & "-4.JPG"        '      &

51、#160; ActiveCell.FormulaR1C1 = ""    End If    If FileFolderExists(ActiveWorkbook.Path & "" & Range(B & Selection.Row) & "-5.JPG") Then 

52、60;    '如果有照片        '        Dim FolderSelect, shp As Shape        ActiveSheet.Pictures.Insert ActiveWorkbook.Path &&

53、#160;"" & Range(B & Selection.Row) & "-5.JPG"    ' .SelectedItems.Item(1)        Set shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)   &

54、#160;    shp.LockAspectRatio = msoFalse        shp.Left = Selection(1).Left        shp.Top = Selection(1).Top        shp.Width

55、0;= Selection(1).Width        shp.Height = Selection(1).Height        FSO.MoveFile ActiveWorkbook.Path & "" & Range(B & Selection.Row) &

56、60;"-5.JPG", strActiveWorkbookPath & Range(B & Selection.Row) & "-5.JPG"        '        ActiveCell.FormulaR1C1 = ""  &

57、#160; End IfRange(B & X + 1).Select    Set FSO = NothingEnd SubPublic Sub 恢复行高并删除照片()    '恢复行高    Application.ScreenUpdating = False    Rows(&

58、quot;2:39").Select    Selection.RowHeight = 15.75    '删除所有照片    Dim N      As Long    Dim cnt    As Long    cnt

59、 = ActiveSheet.Shapes.Count    For N = cnt To 1 Step -1        If Left(ActiveSheet.Shapes(N).Name, 7) = "Picture" Then       

60、     ActiveSheet.Shapes(N).Delete        End If    Next N    Range("H31:H32").Select    Selection.ClearContents    Application.ScreenUp

61、dating = TrueEnd Sub'判断文件夹是否存在：Public Function FileFolderExists(strFullPath As String) As Boolean    On Error GoTo EarlyExit    If Not Dir(strFullPath, vbDirectory) = vbNu

62、llString Then FileFolderExists = TrueEarlyExit:    On Error GoTo 0End FunctionSub 检查服务店非技术人员照片() C = "B" ' ' 照片检查 宏 ' ' 快捷键: Ctrl+Shift+K ' Dim i As Long ' Sheets("服务店非技术人员登记表（一店一表）").Select Appli

63、cation.ScreenUpdating = False ' Selection.ColumnWidth = 20 Rows("7:37").Select Selection.RowHeight = 100 Range("B7").Select strActiveWorkbookPath = ActiveWorkbook.Path & "人员照片" If Not FileFolderExists(strActiveWorkbookPath) Then MkDir strActiveWorkbookPath '

64、就创建一个文件夹 End If ' MoveFilesFromFolder strActiveWorkbookPath, ActiveWorkbook.Path & "" '将文件夹中照片移出来 For i = 1 To 29 '插入29张照片 Call 插入检查服务店非技术人员照片 ' 插入检查服务店非技术人员照片 Next '调整大小至合适 Dim Pic As Picture ', i& i = A65536.End(xlUp).Row For Each Pic In Sheet1.Pictures If

65、 Not Application.Intersect(Pic.TopLeftCell, Range("H1:H" & i) Is Nothing Then Pic.Top = Pic.TopLeftCell.Top Pic.Left = Pic.TopLeftCell.Left Pic.Height = Pic.TopLeftCell.Height Pic.Width = Pic.TopLeftCell.Width End If Next '恢复显示 Application.ScreenUpdating = TrueEnd SubSub 插入检查服务店非技术人员照片() On Error Resume Next Dim X As Long Dim Y As Long Dim strPath As String Dim xlApp As Excel.Application Dim FSO As Object 'New FileSystemObject Set FSO = CreateObject("Scripting.FileSystemObject") Dim AAA As String Dim sP As String 'AAA = X 'Selection.Row X = ActiveCe