[[20100601150306]]　『2007のバージョンでうまくいかない』（もこ）　ページの最後に飛ぶ

『2007のバージョンでうまくいかない』（もこ）

 2000では正常に動いていたものが2007になったら変になります。
 画像を挿入したら縦29セル・横10セルの真中に画像が配置され、
 「("画像設定マクロ用").Cells(3, 2)」に入力された分だけ余白ができます。
 2007で実行すると貼り付け位置がずれてしまいます。
 おそらく大きさはあっているようです。
 VBA初心者なので用語なども勉強中です。
 至らぬ点がありましたら合わせて教えていただけたら幸いです。
 もしお分かりになったら教えて下さい。
 宜しくお願い致します。

 Sub 画像貼付マクロ()
 '------アクティブセルに、選択した
 '　　　　画像ファイルをサイズ調整して貼付ける
 '　　　　ショートカット割り当て　 Keyboard Shortcut: Ctrl+a
     Dim File_path As String
     Dim File_dir As String
     Dim File_file As String
     Dim lngRet As Long
     Dim tempPath As String
     tempPath = Worksheets("画像設定マクロ用").Cells(2, 2).Value

     JPGファイル選択 lngRet, File_path, File_dir, File_file, tempPath

    If lngRet = 0 Then
    Else
 '--------結合後のセル数入力
    exH = 29    'exW:横方向セル数
    exW = 10    'exH:縦方向セル数
 '--------縦方向のセル数
    XcellH# = ActiveCell.Height

    For exHx = 1 To exH

    If exHx = exH Then
    Exit For
    End If

    XcellH# = XcellH# + Cells(ActiveCell.Row + exHx, ActiveCell.Column).Height

    Next exHx
 '--------横方向のセル数
    XcellW# = ActiveCell.Width

    For exWx = 1 To exW
    If exWx = exW Then
    Exit For
    End If

    XcellW# = XcellW# + Cells(ActiveCell.Row, ActiveCell.Column + exWx).Width

    Next exWx                              
 '-----------余白
    Xdelta# = Worksheets("画像設定マクロ用").Cells(3, 2).Value
    XcellH# = XcellH# - Xdelta# * 2
    XcellW# = XcellW# - Xdelta# * 2

    ActiveSheet.Pictures.Insert(File_path).Select
    Selection.ShapeRange.LockAspectRatio = msoTrue

    XshapeN$ = Selection.Name
    XshapeH# = Selection.ShapeRange.Height
    XshapeW# = Selection.ShapeRange.Width

    Worksheets("画像設定マクロ用").Cells(2, 2).Value = File_dir

    Worksheets("画像設定マクロ用").Cells(5, 2).Value = XcellH#
    Worksheets("画像設定マクロ用").Cells(6, 2).Value = XcellW#
    Worksheets("画像設定マクロ用").Cells(7, 2).Value = XshapeN$
    Worksheets("画像設定マクロ用").Cells(8, 2).Value = XshapeH#
    Worksheets("画像設定マクロ用").Cells(9, 2).Value = XshapeW#

    '===============================================画像の挿入開始
    ActiveSheet.Shapes(XshapeN$).Select
    '------セルのサイズを設定枠のサイズに設定
    XwakuH# = XcellH#
    XwakuW# = XcellW#
    '------倍率計算、サイズ調整、位置移動
    RatioH# = XwakuH# / XshapeH#
    RatioW# = XwakuW# / XshapeW#
    If RatioH# > RatioW# Then
        Selection.ShapeRange.Width = XwakuW#
        Selection.ShapeRange.IncrementTop ((XwakuH# - XshapeH# * RatioW#) / 2 + Xdelta#)
        Selection.ShapeRange.IncrementLeft Xdelta#
    Else
        Selection.ShapeRange.Height = XwakuH#
        Selection.ShapeRange.IncrementTop Xdelta#
        Selection.ShapeRange.IncrementLeft ((XwakuW# - XshapeW# * RatioH#) / 2 + Xdelta#)
    End If
    '==================================
    End If            '上部　戻り値による条件の終了
    '
    End
 End Sub

 前任者が作って残したマクロなのでしょうか？

 Excel2007 上で互換モードで動かして隙間ができるということでしょうか？

 肝心の 「JPGファイル選択」の部分が記載されていませんが...

 （kazu）

2003のバージョンを使用していた時代に作成したようで、作成者は居るのですが本人も「2007で使用したら位置がずれる」という事で解決できず・・・

互換モードとゆうのは特別な作業が必要なものでしょうか？

JPGファイル選択部分を忘れていました。すみません！

Public Sub JPGファイル選択(lngRet As Long, F_path As String, F_dir As String, F_file As String, tempPath As String)

'------------------------tempPath：注意

    Dim GetFileName As OPENFILENAME
    Dim strFilBuff As String
    Dim strBuff As String
'''''    Dim lngRet As Long
'
'
    Dim Selectkey As Integer

    'フィルタ文字列の設定
    strFilBuff = "JPG (*.jpg)" & vbNullChar & "*.jpg" & vbNullChar & _
                    "全てのﾌｧｲﾙ (*.*)" & vbNullChar & "*.*"

    'バッファのイニシャルクリア
    strBuff = String(MAX_PATH, 0)

    'コモンダイアログを呼び出す
    With GetFileName
        '構造体の長さ
        .lStructSize = Len(GetFileName)
        '呼び出し元ウインドウハンドル
'        .hwndOwner = Me.hwnd
        'モジュールのインスタンスハンドル
        'Accessの場合、 .hInstance = 0
'        .hInstance = App.hInstance
        'フィルタ文字列
        .lpstrFilter = strFilBuff
        'lpstrCustomFilterのバッファサイズ
        .nMaxCustrFilter = 0&
        'フィルタコンボボックスの初期インデックス値
        .nFilterIndex = 0
        '選択されたファイル名のフルパス
        .lpstrFile = strBuff
        'lpstrFileのバッファサイズ
        .nMaxFile = MAX_PATH
        '選択されたファイル名のタイトル
        .lpstrFileTitle = String$(MAX_PATH, 0)
        'lpstrFileTitleのバッファサイズ
        .nMaxFileTitle = MAX_PATH + 1
        '初期フォルダ名
        '.lpstrInitialDir = "c:\"
        .lpstrInitialDir = tempPath                '追加：フォルダ
        'ダイアログボックスのタイトル名
        .lpstrTitle = "ファイルを選択して下さい。"
        'Flagsの値
        .flags = OFN_HIDEREADONLY
        'ファイル名の入力時、拡張子が省略された時の拡張子
        .lpstrDefExt = "jpg"
    End With

    'ＡＰＩコール
api:
    lngRet = GetOpenFileName(GetFileName)

    '戻り値のチェック
    If lngRet = 0 Then
        Selectkey = MsgBox("キャンセルされました。よろしいですか？", vbYesNo, "ファイル選択終了確認")
'                vbYesNo, "ファイル選択終了確認")
        Select Case Selectkey
            Case vbYes
                End  '終了
            Case vbNo
                GoTo api
        End Select
    Else
        'ドライブ＆フォルダ＆ファイル名（フルパス）
        F_path = Mid(GetFileName.lpstrFile, 1, _
                     InStr(GetFileName.lpstrFile, vbNullChar) - 1)
        'ドライブ＆フォルダ
        F_dir = StrConv(LeftB$(StrConv(GetFileName.lpstrFile, vbFromUnicode), _
                     GetFileName.nFileOffset), vbUnicode)
        'ファイル名
        F_file = Mid(GetFileName.lpstrFileTitle, 1, _
                     InStr(GetFileName.lpstrFileTitle, vbNullChar) - 1)
    End If
End Sub

（もこ）

 incrementTop やincrementLeft のtop left 初期値がセットされていないのが原因と思われます。

 下のコードを追加してみてください。 （kazu）

 (1)
    '--------結合後のセル数入力
    exH = 29    'exW:横方向セル数
    exW = 10    'exH:縦方向セル数

    Top1 = ActiveCell.Top   ' ←←追加
    left1 = ActiveCell.Left ' ←←追加

 (2)
    '------倍率計算、サイズ調整、位置移動
     RatioH# = XwakuH# / XshapeH#
     RatioW# = XwakuW# / XshapeW#

     Selection.ShapeRange.Top = Top1     ' ←←追加
     Selection.ShapeRange.Left = left1   ' ←←追加

     If RatioH# > RatioW# Then
        Selection.ShapeRange.Width = XwakuW#

        Selection.ShapeRange.IncrementTop ((XwakuH# - XshapeH# * RatioW#) / 2 + Xdelta#)
        Selection.ShapeRange.IncrementLeft Xdelta#
    Else
        Selection.ShapeRange.Height = XwakuH#

        Selection.ShapeRange.IncrementTop Xdelta#
        Selection.ShapeRange.IncrementLeft ((XwakuW# - XshapeW# * RatioH#) / 2 + Xdelta#)
    End If

やってみましたが上手くできません。。。
でも貼り付け位置が指定セル上にくるようになりました。
ありがとうございます＊
（もこ）

コメント返信：

[ 一覧(最新更新順) ]

[[20100601150306]] 『2007のバージョンでうまくいかない』（もこ） ページの最後に飛ぶ

[[20100601150306]]　『2007のバージョンでうまくいかない』（もこ）　ページの最後に飛ぶ