도형의 차원 할당 오류

Question

기존 모양 "그림 1"(확장 메타 파일)의 크기와 위치를 인식하는 매크로를 만들고 그 도형을 삭제하고 다른 그림에서 차트 "차트 3"을 복사하려고합니다. 통합 문서를 확장 메타 파일로 원래 통합 문서로 복사하고 크기/원본 셰이프의 크기/위치와 동일하게 복사본을 이동합니다.

대상 워크 시트를 "wkst"로 지정하고 원본 워크 시트를 "원본"으로 선언했습니다. 그것은 한 가지를 제외하고는 모두 완벽하게 작동합니다. 복사 된 모양의 첫 번째 치수는 내가 처음 설정 한 치수와 상관없이 항상 원래 모양과 약간 떨어져 있습니다. 아래 코드의 경우 모양의 높이가 약간 변경됩니다.

메시지 상자를 추가하여 값이 일치하는지 확인했지만 MsgBox CurrentH (원래 모양의 높이)은 MsgBox wkst.Shapes("Picture 1").Height (복사 된 모양의 높이)과 동일한 값을 표시하지 않습니다. 조금씩 바뀝니다. 즉, 594에서 572로 변경됩니다.

어떤 도움을 주셔서 감사합니다.

Dim CurrentW As Double 
Dim CurrentH As Double 
Dim CurrentT As Double 
Dim CurrentL As Double 

    CurrentH = wkst.Shapes("Picture 1").Height 
    CurrentW = wkst.Shapes("Picture 1").Width 
    CurrentT = wkst.Shapes("Picture 1").Top 
    CurrentL = wkst.Shapes("Picture 1").Left 

    MsgBox CurrentH 
    MsgBox CurrentW 
    MsgBox CurrentT 
    MsgBox CurrentL 

    Source.ChartObjects("Chart 3").Copy 
    wkst.Shapes("Picture 1").Delete 
    wkst.Activate 
    wkst.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False 
    With ActiveWindow.Selection 
      .Name = "Picture 1" 
      .Height = CurrentH 
      .Width = CurrentW 
      .Left = CurrentL 
      .Top = CurrentT 
    End With 

    MsgBox wkst.Shapes("Picture 1").Height 
    MsgBox wkst.Shapes("Picture 1").Width 
    MsgBox wkst.Shapes("Picture 1").Top 
    MsgBox wkst.Shapes("Picture 1").Left 

Answer 1

이 경우에는 복사 한 모양의 치수를 설정하는 매개 변수를 더 추가해야합니다. 따라서 대신 코드의이 부분의 :

With wkst.Shapes(wkst.Shapes.Count) '<-- the code set parameters of Shape therefore _ 
            this line need to be changed, too 
     .Name = "Picture 1" 
     .Left = CurrentL 
     .Top = CurrentT 
'new part --> 
     .LockAspectRatio = msoFalse 
    Dim Ratio As Double 
     Ratio = CurrentH/CurrentW 
     .ScaleHeight Ratio, msoFalse, msoScaleFromTopLeft 
'<--new part 
     .Width = CurrentW 
     .Height = CurrentH 
End With 

매개 변수의 순서가 중요하다

With ActiveWindow.Selection 
     .Name = "Picture 1" 
     .Height = CurrentH 
     .Width = CurrentW 
     .Left = CurrentL 
     .Top = CurrentT 
End With 

이 하나 추가해야합니다. 코드 시도하고 테스트하고 잘 작동하고있어.