国产一级a片免费看高清,亚洲熟女中文字幕在线视频,黄三级高清在线播放,免费黄色视频在线看

Sub importPictures(Target As Range)    Dim picFileName As String    Dim picPath As String    Dim pic As Shape    Dim fileType()    Dim ws As Worksheet    Dim rng As Range, t As Integer, padding As Single    Dim Employee As String    Set ws = ThisWorkbook.Sheets("員工信息表")    fileType = Array(".png", ".gif", ".jpg", ".bmp")    picPath = ThisWorkbook.Path & "\員工照片"    padding = 1.5    '刪除原有圖片    Call deletePic(ws)    With ws        Employee = Target.Value  '//姓名        '//設(shè)置插入的單元格區(qū)域        Set rng = .Range("G2").MergeArea        If Employee <> "" Then            For j = 0 To UBound(fileType)   '//循環(huán)圖片文件類型                '//照片文件名完整路徑                picFileName = picPath & "\" & Employee & fileType(j)                If IsFileExists(picFileName) Then                    '//插入形狀，設(shè)置大小位置,適當(dāng)小于rng                    Set pic = .Shapes.AddShape(msoShapeRectangle, rng.Left + padding, rng.Top + padding, rng.Width - 2 * padding, rng.Height - 2 * padding)                    With pic                        .Line.Visible = msoFalse                        .Fill.Transparency = 1                        .Fill.UserPicture picFileName                        '//再微調(diào)矩形（照片）的位置                        '.Top = rng.Top + (rng.Height - .Height) / 2                        '.Left = rng.Left + (rng.Width - .Width) / 2                        .Top = .Top + (.Top - rng.Top) / 2                        .Left = .Left + (.Left - rng.Left) / 2                    End With                    t = 1                    rng = ""                    Exit For   '//找到文件就不再循環(huán)文件類型                End If            Next            If t = 0 Then                rng = "無照片"            End If        End If    End WithEnd Sub

Sub deletePic(ws As Worksheet)    Dim pic As Shape    With ws        For Each pic In ws.Shapes   '刪除原有圖片            If pic.Type = 1 Then                pic.Delete            End If        Next    End WithEnd Sub

Function Pxy(arr(), FieldName As String, Optional arrType As Integer = 0)    '**********************************    'arrType=0,表示一維數(shù)組    'arrType=1,表示二維數(shù)組，查找第一列    'arrType=2,表示二維數(shù)組，查找第一行    '**********************************    k = 0    t = 0    Select Case arrType    Case Is = 0        For i = LBound(arr) To UBound(arr)            k = k + 1            If arr(i) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 1        For i = LBound(arr, 1) To UBound(arr, 1)            k = k + 1            If arr(i, 1) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 2        For i = LBound(arr, 2) To UBound(arr, 2)            k = k + 1            If arr(1, i) = FieldName Then                t = 1                Exit For            End If        Next    End Select    If t = 1 Then        Pxy = k    Else        Pxy = 0    End IfEnd Function

Function IsFileExists(iFileName)    Dim FSO As Object    Set FSO = CreateObject("Scripting.FileSystemObject")    IsFileExists = FSO.FileExists(iFileName)End Function

Private Sub CmdPrint_Click()    Dim rng As Range    If Application.Dialogs(xlDialogPrinterSetup).Show = False Then        Exit Sub    End If    Set rng = Range("A1:H6")    Call SetPrintArea(Me, rng)    Me.PrintOut copies:=1    MsgBox "Print successfully!"End Sub

Private Sub CmdPrintBatch_Click()    Dim arr()    Dim ws As Worksheet, rng As Range    Set ws = ThisWorkbook.Sheets("?±1¤D??￠?′")    arr = ws.Range("A1").CurrentRegion.Offset(1)    If Application.Dialogs(xlDialogPrinterSetup).Show = False Then        Exit Sub    End If    Set rng = Range("A1:H6")    Call SetPrintArea(Me, rng)    For i = Val(Range("K3").Value) To Val(Range("K4").Value)        Range("K1").Value = arr(i, 2)        Me.PrintOut copies:=1    Next    MsgBox "Print successfully!"End Sub

Private Sub Worksheet_Change(ByVal Target As Range)    Application.ScreenUpdating = False    If Target.Address = "$K$1" Then        Call myQuery(Target)        Call importPictures(Target)    ElseIf Target.Address = "$K$3" Then        If Target > Range("K4") Then            Range("K4") = Target        End If    ElseIf Target.Address = "$K$4" Then        If Target < Range("K3") Then            Range("K3") = Target        End If    End If    Application.ScreenUpdating = TrueEnd Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)    If Target.Address = "$K$1" Or Target.Address = "$K$3" Or Target.Address = "$K$4" Then        Call SetDataValidation(Target)    End IfEnd Sub

PrivaPrivate Sub SetDataValidation(rng As Range)    Dim wsSource As Worksheet    Dim rngStr As String    Set wsSource = ThisWorkbook.Sheets("員工信息源")    If rng.Address = "$K$1" Then        rngStr = wsSource.Name & "!" & wsSource.Range("B2:B" & wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row).Address    ElseIf rng.Address = "$K$3" Or rng.Address = "$K$4" Then        rngStr = wsSource.Name & "!" & wsSource.Range("A2:A" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row).Address    End If    rng.Validation.Delete    With rng.Validation        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _            Operator:=xlBetween, Formula1:="=" & rngStr        .IgnoreBlank = True        .InCellDropdown = True        .ShowInput = True        .ShowError = True    End WithEnd Sub

Private Sub myQuery(Target As Range)    Dim ws As Worksheet, lastRow As Integer, lastCol As Integer    Dim arr()    Set ws = ThisWorkbook.Sheets("員工信息源")    arr = ws.Range("A1:K" & ws.UsedRange.Rows.Count)    Cells(2, "B") = Target    For i = 1 To UBound(arr)        If arr(i, 2) = Target.Value Then            For j = 2 To 4                For k = 1 To 5 Step 2                    Cells(j, k).Offset(0, 1) = arr(i, Pxy(arr, Cells(j, k), 2))                Next            Next            Cells(4, "H") = arr(i, Pxy(arr, Cells(4, "H").Offset(0, -1), 2))        End If    NextEnd Sub

Sub SetPrintArea(ws As Worksheet, rng As Range)    With ws        .PageSetup.PrintArea = rng.Address        .PageSetup.Zoom = False        .PageSetup.FitToPagesWide = 1        .PageSetup.FitToPagesTall = 1    End WithEnd Sub