[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『挿入画像と 所定（セル）位置の図形（四角形）とを コネクター線で結び付けたい 改題 系譜図』（はんにゃ）
挿入して貼り付けた図像と ある特定のセルとの間に矢印をつけたいのですが どんなコードがあるでしょうか？ コメントは文字だけ可能ですが それと同じ様に図像に矢印をつけたいのです。 セル位置と 図像の位置を見出し、その間を図形で”矢印線”描くことになるでしょうか？ 便利な既定の関数的コードがないでしょうか？
まずは全文検索してみましょう。
コメントの背景として画像を指定出来ます。 [[20090310125559]]『コメントに表の作成』（わたりん） [[20080725142030]]『図をコメントみたいに表示』（チータ）
で、コードに関するスレ。 [[20070510130341]]『コメントで写真』（day）
(HANA)
HANAさん ありがとうございます
コメントの中に、Tbl1配列データ（７の備考）から文や図像（ファイル指定）を挿入するコードの前に
文は直接データからセル内に書き込んで（テキストボックスはつかっていません）、 像は貼り付けてみました。 関係矢印線を図とグループ化しても、図を移動すると 関係矢印線は一緒に平行移動して 他端が初めの指定位置から離れます。
心配した印刷も可能なので、 やはり、これから コメントの中に入れるのが目的にあっているようです。
現状を http://www.mediafire.com/download.php?ya2nnh2kmm4 に載せました。助言など頂ければ幸甚です。Withの使い方など。
（はんにゃ
＞現状を http://www.mediafire.com/download.php?ya2nnh2kmm4 ＞に載せました。 どのようなファイルを載せておられるのかわかりませんが 「自分で見に行って、解読して修正してくれ。 今回の質問に直接関係ない部分も含まれているけど どこが関係あって、どこが関係ないのか それもそっちで見分けてアドバイスを下さい。」 ってのはどうかと思います。
ファイルは、こちら（掲示板）で十分に説明をして 補足として使用して頂ければと思います。
まずは現状をわかりやすく訴えること。
そのためには、自分でどこが問題だと思ってるか整理し どのようなサンプルコードがあれば伝わるのか考え、作成する。 最近 その努力を怠っておられるように感じます。
(HANA)
努力や 皆様への誠心が不足しています。 ありがとうございます。 (はんにゃ
Private Sub MojiretuBunri(tbl1, ir, cmnt, imgflnm)
Dim sr As Long
cmnt = tbl1(ir, 7) ' これがデータ表の備考列
imgflnm = ""
sr = InStr(tbl1(ir, 7), "像\") '像\ファイル名.JPGがあれば
If sr > 0 Then
cmnt = Left(tbl1(ir, 7), sr - 1)
imgflnm = Right(tbl1(ir, 7), Len(tbl1(ir, 7)) - sr)
Else
End If
End Sub
'------
Private Sub cmmnTextImage(tbl1, ir, xrb, xcb) 'cmmnTextImage(xrb, xcb, cmnt, imgflnm)
Dim cmnt As String, imgflnm As String
Call MojiretuBunri(tbl1, ir, cmnt, imgflnm) '備考列データより文字列と画像ファイル名
With Sheets("系譜図").Range("D2").Cells(xrb, xcb) 'コメント対象セル
.AddComment
If cmnt <> "" Then
.Comment.Text Text:=cmnt
End If
If imgflnm <> "" Then
.Comment.Shape.Fill.UserPicture ThisWorkbook.Path & imgflnm
If Err.Number <> 0 Then
MsgBox "D:\My Documents2\HomeWorks\家系譜" & imgflnm & " not exicts)"
End If
End If
End With
End Sub
例えば tbl1( 3,7) ="判明する最古の祖先。新町との屋号。像\Nagata-KamonS.JPG" です 挿入機能では移動してしまう矢印線の対象セルへの固定のため 上のコメント機能を使いました。 うまく表示されました。印刷プレビュウでも表示がでます。 しかし Web出力では 画像が出ないです。映像ホルダ^をみると入っているので ブラウザー IE−８とか GoogleCroma2.0 の相性でしょう。 おてあげの様相です。もし なにかコードで不都合がありましたら おしえてください。(はんにゃ
助言者の方々ありがとうございます
現状のコメント表示での問題点として、Web化表示の問題と コメント領域を初期に図像の縦横比に合わせない（現在手動で調整）問題があります。 初期から図形のアスペクト比にあわせるコードはあるでしょうか？
一方 図形挿入で矢印線への対象端点が固定できないと言っていましたが 知識不足でコネクタ線があるのを知りました。 但し これはセルとの結合はしないで あくまで図形同士のようです。 そこで 対象セルとの結合を 透明な四角か円図形をダミーとして当該セル位置に重ねて その二つの間のコネクタ線を描くことにします。 これをコード化してみようと考えました。 備考の文書は テキストボックスを利用しようと思います。
参考意見・助言がありましたら よろしくお願いします。(はんにゃ
コネクターをつかって 当該名前セル（実際にはその位置に配置した四角形）と 挿入画像 ならびに備考文TextBoxを連結させることを試みています。
コードは以下です。 現状は名前セルとTextBoxとの連結線の表示、 そして 画像の所定位置への挿入貼り付けはできましたが、 その画像と名前セルとの連結線の結合ができません。 助言をおねがいします。（はんにゃ）
Private Sub cmmnConector(tbl1, ir) ' in Bikou(tbl1)
Dim cmnt As String, imgflnm As String
Dim snglX As Single, snglY As Single
Dim ic As Range
Call MojiretuBunri(tbl1, ir, cmnt, imgflnm) 'Ir行の備考列データより備考文cmnt と画像ファイル名mgflnm を分離
xrb = tbl1(ir, 13) ' 当該者名前セル行番地
xcb = tbl1(ir, 14) ' 当該者名前セル列番地
Set s = Sheets("系譜図").Shapes 'myDocument.Shapes
snglX = Sheets("系譜図").Range("D2").Cells(xrb, xcb).Left
snglY = Sheets("系譜図").Range("D2").Cells(xrb, xcb).Top + Sheets("系譜図").Range("D2").Cells(xrb, xcb).Height / 2
Set firstRect = s.AddShape(msoShapeRectangle, snglX, snglY, 3, 3) '四角形を名前セル内に配置
If cmnt <> "" Then '名前セル内四角形とTextBoxとの連結線の表示
Set secondRect = s.AddTextbox(msoTextOrientationHorizontal, snglX + 20, snglY + 20, 40, 40)
secondRect.TextFrame.Characters.Text = cmnt '"備考文"
secondRect.Line.DashStyle = msoLineDash
Set C = s.AddConnector(msoConnectorCurve, 0, 0, 100, 100) '
If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), "▼") > 0 Then '男女色分け
C.Line.ForeColor.RGB = RGB(255, 0, 0)
Else
C.Line.ForeColor.RGB = RGB(0, 0, 255)
End If
C.Line.EndArrowheadStyle = msoArrowheadTriangle
C.Line.DashStyle = msoLineDash
C.Line.Weight = 1
With C.ConnectorFormat
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
.EndConnect ConnectedShape:=secondRect, ConnectionSite:=1
C.RerouteConnections
End With
End If
If imgflnm <> "" Then '前出の名前セル内四角形と挿入画像との連結線の表示
Set ic = Sheets("系譜図").Range(Cells(xrb + 4, xcb + 3).Address)
With Sheets("系譜図").Pictures.Insert(ThisWorkbook.Path & imgflnm)
' Set secondimg = .Pictures.Insert(ThisWorkbook.Path & imgflnm)
' 上の替わりにこのコードをつかうと そのときは下の２行はエラになる。取り除くと 貼り付け位置が正しくない。
.Left = ic.Left
.Top = ic.Top
' エラー処理効かない
' If Err.Number <> 0 Then
' MsgBox "Sorry, " & ThisWorkbook.Path & imgflnm & " not exicts"
' End If
End With
Set C = s.AddConnector(msoConnectorCurve, 0, 0, 100, 100)
C.Line.EndArrowheadStyle = msoArrowheadTriangle
C.Line.DashStyle = msoLineDash
C.Line.Weight = 1
If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), "▼") > 0 Then
C.Line.ForeColor.RGB = RGB(255, 0, 0)
Else
C.Line.ForeColor.RGB = RGB(0, 0, 255)
End If
With C.ConnectorFormat
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
' .EndConnect ConnectedShape:=secondimg, ConnectionSite:=1
' 現在これを外して 像や連結線がでることを確認。しかし連結しない。これを入れるとsecondimg Emptyのエラーになる
C.RerouteConnections
End With
End If
End Sub
'------
上のコードで 実際には 例えば ir = 3 tbl1(3,7) = "判明する最古祖先。新町の屋号。像\Na-KamonS.jpg" cmnt= "判明する最古祖先。新町の屋号。" imgflnm = "\Na-KamonS.jpg" xrb = tbl1(3, 13) = 5 xcb = tbl1(3, 14) = 2 と成っています。よろしく おねがいします （はんにゃ）
指定したファイルの画像を挿入するコードは Pictures.Insertの他に
Sheets("系譜図").Shapes.AddPicture ThisWorkbook.Path & imgflnm, True, True, 100, 100, 70, 70
がHelpで見つかりました。手動でコネクタ線との連結はできました。 ただし、.EndConnect 変数用に 戻り値をどう得るかわからず、また 位置の指定が良くわからない。 サイズが固定してしまう。像が不鮮明 などで 上のInsertをつかいたい。
（はんにゃ）
まず、誰でもこの投稿を見た人が はんにゃさんが抱えている問題までにたどり着くまで 操作手順のドキュメントを記述してください。 今のままでは、cmmnConectorを呼び出すプロシジャーの提示もないので、 誰もが問題にたどり着くまでには、かなりの労力を有するでしょ？
新規ブック（Sheet1というシート名を有するブック）にて確認しください。
この新規ブックの標準モジュールに
'========================================================================
Sub main()
Dim tbl1(3 To 3, 1 To 14)
Dim ir As Long
ir = 3
tbl1(3, 7) = "判明する最古祖先。新町の屋号。像\xxxx.jpg"
tbl1(3, 13) = 5
tbl1(3, 14) = 2
Call cmmnConector(tbl1(), ir)
erase tbl1()
End Sub
'========================================================================
Private Sub cmmnConector(tbl1, ir) ' in Bikou(tbl1)
Dim cmnt As String, imgflnm As String
Dim snglX As Single, snglY As Single
Dim ic As Range
Dim secondimg As Object
Dim xrb As Long
Dim xcb As Long
Dim s As Shapes
Dim firstRect As Shape
Dim secondRect As Shape
Dim c As Shape
Call MojiretuBunri(tbl1, ir, cmnt, imgflnm) 'Ir行の備考列データより備考文cmnt と画像ファイル名mgflnm を分離
xrb = tbl1(ir, 13) ' 当該者名前セル行番地
xcb = tbl1(ir, 14) ' 当該者名前セル列番地
Set s = Sheets("sheet1").Shapes 'myDocument.Shapes
snglX = Sheets("sheet1").Range("D2").Cells(xrb, xcb).Left
snglY = Sheets("sheet1").Range("D2").Cells(xrb, xcb).Top + Sheets("sheet1").Range("D2").Cells(xrb, xcb).Height / 2
Set firstRect = s.AddShape(msoShapeRectangle, snglX, snglY, 3, 3) '四角形を名前セル内に配置
If cmnt <> "" Then '名前セル内四角形とTextBoxとの連結線の表示
Set secondRect = s.AddTextbox(msoTextOrientationHorizontal, snglX + 20, snglY + 20, 40, 40)
secondRect.TextFrame.Characters.Text = cmnt '"備考文"
secondRect.Line.DashStyle = msoLineDash
Set c = s.AddConnector(msoConnectorCurve, 0, 0, 100, 100) '
If InStr(Sheets("sheet1").Range("D2").Cells(xrb, xcb), "▼") > 0 Then '男女色分け
c.Line.ForeColor.RGB = RGB(255, 0, 0)
Else
c.Line.ForeColor.RGB = RGB(0, 0, 255)
End If
c.Line.EndArrowheadStyle = msoArrowheadTriangle
c.Line.DashStyle = msoLineDash
c.Line.Weight = 1
With c.ConnectorFormat
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
.EndConnect ConnectedShape:=secondRect, ConnectionSite:=1
c.RerouteConnections
End With
End If
If imgflnm <> "" Then '前出の名前セル内四角形と挿入画像との連結線の表示
Set ic = Sheets("sheet1").Range(Cells(xrb + 4, xcb + 3).Address)
Set secondimg = Sheets("sheet1").Pictures.Insert(ThisWorkbook.Path & imgflnm)
With secondimg
' ↑大きな変更箇所
.Left = ic.Left
.Top = ic.Top
' エラー処理効かない
' If Err.Number <> 0 Then
' MsgBox "Sorry, " & ThisWorkbook.Path & imgflnm & " not exicts"
' End If
End With
Set c = s.AddConnector(msoConnectorCurve, 0, 0, 100, 100)
c.Line.EndArrowheadStyle = msoArrowheadTriangle
c.Line.DashStyle = msoLineDash
c.Line.Weight = 1
If InStr(Sheets("sheet1").Range("D2").Cells(xrb, xcb), "▼") > 0 Then
c.Line.ForeColor.RGB = RGB(255, 0, 0)
Else
c.Line.ForeColor.RGB = RGB(0, 0, 255)
End If
With c.ConnectorFormat
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
.EndConnect ConnectedShape:=secondimg.ShapeRange(1), ConnectionSite:=1
' ↑大きな変更箇所
c.RerouteConnections
End With
End If
Set ic = Nothing
Set secondimg = Nothing
Set s = Nothing
Set firstRect = Nothing
Set secondRect = Nothing
Set c = Nothing
End Sub
'========================================================================
Private Sub MojiretuBunri(tbl1, ir, cmnt, imgflnm)
Dim sr As Long
cmnt = tbl1(ir, 7) ' これがデータ表の備考列
imgflnm = ""
sr = InStr(tbl1(ir, 7), "像\") '像\ファイル名.JPGがあれば
If sr > 0 Then
cmnt = Left(tbl1(ir, 7), sr - 1)
imgflnm = Right(tbl1(ir, 7), Len(tbl1(ir, 7)) - sr)
Else
End If
End Sub
作動方法
これで適当なフォルダに上記のブックを保存してください。 尚、プロシジャーmain内にあるコードの
tbl1(3, 7) = "判明する最古祖先。新町の屋号。像\xxxx.jpg"
ですが、この xxxx.jpg に相当する画像を何でも良いので上記のブックと同じフォルダ上に保存してください。
保存した名前が ichinose.jpgなら、上記のコードも
tbl1(3, 7) = "判明する最古祖先。新町の屋号。像\ichinose.jpg"
と変更してください。
これでmainを実行してください。
Sheet1のセルE6付近に結びになる小さい四角形が作成され、 指定した画像（例 xxxx.jpg）と「判明する最古祖先。新町の屋号。」という文字列を含むテキストボックスを コネクタで結んでいる図形が作成されます。
これで動作はすると思いますが・・・・。 cmmnConectorというプロシジャーのインタフェース（パラメータの種類）にも疑問を感じますが、 今回はこれはよしとします。 (本当は、よくないなあ、まあ、いいか）
ただ、中の変数だけは、事前に宣言するようにしてください。
又、SとかCとかは、変数として使わないようにしてください。 もっと、ユニークな名前にすることですよ！！
ichinose
大変ご苦労をおかけして 読み解き 動作するコードへ直していただき ありがとうございました。 言われたように 操作手順のドキュメントを記述するように心がけます。 すぐに期待通りに描画しました。
これを小生のものに移しこみ エラー表示にしたがい、宣言などを追加して 動作することを確認しました。 withの使い方を まだわかっていないので勉強しないといけない。 secondimg.ShapeRange(1)もポイントでした。
言い訳：変数が一文字は Help実例をこぴーしたままでした。直しました。
Private Sub cmmnConector(tbl1) ' or Bikou(tbl1)
Dim ir As Long
Dim cmnt As String, imgflnm As String
Dim snglX As Single, snglY As Single
Dim ic As Range
Dim shp As Shapes
Dim firstRect As Shape
Dim secondRect As Shape
Dim Cn As Shape
Dim secondimg As Object
For ir = 2 To UBound(tbl1, 1) If tbl1(ir, 7) <> "" Then
Call MojiretuBunri(tbl1, ir, cmnt, imgflnm) '備考列データより文字列と画像ファイル名
xrb = tbl1(ir, 13) ' = tbl1(ir, 8) - nn + 1 生年の行番地 西暦変換済み
xcb = tbl1(ir, 14) '
snglX = Sheets("系譜図").Range("D2").Cells(xrb, xcb).Left
snglY = Sheets("系譜図").Range("D2").Cells(xrb, xcb).Top + Sheets("系譜図").Range("D2").Cells(xrb, xcb).Height / 2
Set shp = Sheets("系譜図").Shapes 'myDocument.Shapes
Set firstRect = shp.AddShape(msoShapeRectangle, snglX, snglY, 3, 3)
If cmnt <> "" Then
Set secondRect = shp.AddTextbox(msoTextOrientationHorizontal, snglX + 20, snglY + 20, 40, 40)
secondRect.TextFrame.Characters.Text = cmnt '"テスト ボックス"
secondRect.Line.DashStyle = msoLineDash
Set Cn = shp.AddConnector(msoConnectorCurve, 0, 0, 100, 100) '
If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), "▼") > 0 Then 'sbs
Cn.Line.ForeColor.RGB = RGB(255, 0, 0)
Else
Cn.Line.ForeColor.RGB = RGB(0, 0, 255)
End If
Cn.Line.EndArrowheadStyle = msoArrowheadTriangle
Cn.Line.DashStyle = msoLineDash
Cn.Line.Weight = 1
With Cn.ConnectorFormat
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
.EndConnect ConnectedShape:=secondRect, ConnectionSite:=1
Cn.RerouteConnections
'.Type = msoConnectorElbow
End With
End If
'
If imgflnm <> "" Then
Set ic = Sheets("系譜図").Range(Sheets("系譜図").Range("D2").Cells(xrb + 2, xcb + 1).Address)
Set secondimg = Sheets("系譜図").Pictures.Insert(ThisWorkbook.Path & imgflnm) '
With secondimg
.Left = ic.Left: .Top = ic.Top
' エラー処理効かない
' If Err.Number <> 0 Then
' MsgBox "Sorry, " & ThisWorkbook.Path & imgflnm & " not exicts"
' End If
End With
Set Cn = shp.AddConnector(msoConnectorCurve, 1, 1, 1, 1) 'コネクタ描画 ※位置は仮決め
Cn.Line.EndArrowheadStyle = msoArrowheadTriangle
Cn.Line.DashStyle = msoLineDash
Cn.Line.Weight = 1
If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), "▼") > 0 Then
Cn.Line.ForeColor.RGB = RGB(255, 0, 0)
Else
Cn.Line.ForeColor.RGB = RGB(0, 0, 255)
End If
With Cn.ConnectorFormat
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
.EndConnect ConnectedShape:=secondimg.ShapeRange(1), ConnectionSite:=1
'.Type = msoConnectorElbow
Cn.RerouteConnections
End With
End If ' If imgflnm
End If 'If tbl1(ir, 7)
Next 'For ir = 2
Set ic = Nothing
Set secondimg = Nothing
Set shp = Nothing
Set firstRect = Nothing
Set secondRect = Nothing
Set Cn = Nothing
End Sub
なおしました。ありがとうございました。
＞cmmnConectorというプロシジャーのインタフェース（パラメータの種類）にも疑問を感じます。 パラメータと言うのは引数のことでしょうか。それとも どのような種類でしょうか？
追加で教えていただければ
Set secondimg = Sheets("系譜図").Pictures.Insert(ThisWorkbook.Path & imgflnm) '
で ファイルがないときなど エラーがでるのですが
そこで
If ？？？？？なにか <> 0 Then
' MsgBox "Sorry, " & ThisWorkbook.Path & imgflnm & " not exicts"
' End If
のようにファイルの注意をすることができないでしょうか？
（はんにゃ
Private Sub cmmnConector(tbl1) ' or Bikou(tbl1)
Dim ir As Long
Dim cmnt As String, imgflnm As String
Dim snglX As Single, snglY As Single
Dim ic As Range
Dim shp As Shapes
Dim firstRect As Shape
Dim secondRect As Shape
Dim Cn As Shape
Dim secondimg As Object
Dim xrb As Long 'この変数の定義が抜けてます
Dim xcb As Long 'これも。まさかモジュールレベルの変数ではないですよね？
On Error Resume Next 'エラートラップを取得する設定
For ir = 2 To UBound(tbl1, 1)
If tbl1(ir, 7) <> "" Then
Call MojiretuBunri(tbl1, ir, cmnt, imgflnm) '備考列データより文字列と画像ファイル名
xrb = tbl1(ir, 13) ' = tbl1(ir, 8) - nn + 1 生年の行番地 西暦変換済み
xcb = tbl1(ir, 14) '
snglX = Sheets("系譜図").Range("D2").Cells(xrb, xcb).Left
snglY = Sheets("系譜図").Range("D2").Cells(xrb, xcb).Top + Sheets("系譜図").Range("D2").Cells(xrb, xcb).Height / 2
Set shp = Sheets("系譜図").Shapes 'myDocument.Shapes
Set firstRect = shp.AddShape(msoShapeRectangle, snglX, snglY, 3, 3)
If cmnt <> "" Then
Set secondRect = shp.AddTextbox(msoTextOrientationHorizontal, snglX + 20, snglY + 20, 40, 40)
secondRect.TextFrame.Characters.Text = cmnt '"テスト ボックス"
secondRect.Line.DashStyle = msoLineDash
Set Cn = shp.AddConnector(msoConnectorCurve, 0, 0, 100, 100) '
If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), "▼") > 0 Then 'sbs
Cn.Line.ForeColor.RGB = RGB(255, 0, 0)
Else
Cn.Line.ForeColor.RGB = RGB(0, 0, 255)
End If
Cn.Line.EndArrowheadStyle = msoArrowheadTriangle
Cn.Line.DashStyle = msoLineDash
Cn.Line.Weight = 1
With Cn.ConnectorFormat
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
.EndConnect ConnectedShape:=secondRect, ConnectionSite:=1
Cn.RerouteConnections
'.Type = msoConnectorElbow
End With
End If
' If imgflnm <> "" Then
Set ic = Sheets("系譜図").Range(Sheets("系譜図").Range("D2").Cells(xrb + 2, xcb + 1).Address)
Err.Clear 'エラークリア
Set secondimg = Sheets("系譜図").Pictures.Insert(ThisWorkbook.Path & imgflnm)
If Err.Number <> 0 Then '画像挿入時に何らかのエラーが発生したら
MsgBox ThisWorkbook.Path & imgflnm & " " & Err.Description
Else
With secondimg
.Left = ic.Left: .Top = ic.Top
End With
Set Cn = shp.AddConnector(msoConnectorCurve, 1, 1, 1, 1) 'コネクタ描画 ※位置は仮決め
Cn.Line.EndArrowheadStyle = msoArrowheadTriangle
Cn.Line.DashStyle = msoLineDash
Cn.Line.Weight = 1
If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), "▼") > 0 Then
Cn.Line.ForeColor.RGB = RGB(255, 0, 0)
Else
Cn.Line.ForeColor.RGB = RGB(0, 0, 255)
End If
With Cn.ConnectorFormat
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
.EndConnect ConnectedShape:=secondimg.ShapeRange(1), ConnectionSite:=1
'.Type = msoConnectorElbow
Cn.RerouteConnections
End With
End If
End If 'If tbl1(ir, 7)
Next 'For ir = 2
Set ic = Nothing
Set secondimg = Nothing
Set shp = Nothing
Set firstRect = Nothing
Set secondRect = Nothing
Set Cn = Nothing
On Error GoTo 0 'エラートラップの取得解除
End Sub
モジュールの先頭に Option Explicitを付けるようにしてください。
ＶＢＥの「ツール」----「オプション」とクリックし、オプションダイアログを表示させます。
「編集」タブにて、変数の宣言を強制するにチェックすれば、自動で記述されます。
こうすれば、宣言漏れを防げます。
ichinose
再三 ありがとうございました おかげでファイル読み込みエラーのとき その原因表示とパスさせて続行させることができました。 これでマクロ操作を知らない人も使えます。
If imgflnm <> "" Then
Set ic = Sheets("系譜図").Range(Sheets("系譜図").Range("D2").Cells(xrb + 2, xcb + 1).Address)
Err.Clear 'エラークリア
Set secondimg = Sheets("系譜図").Pictures.Insert(ThisWorkbook.Path & imgflnm) '
If Err.Number <> 0 Then '画像挿入時に何らかのエラーが発生したら
MsgBox "データ表" & ir & "行の" & ThisWorkbook.Path & imgflnm & " not exist!" & vbLf & Err.Description
Else
With secondimg
.Left = ic.Left: .Top = ic.Top
End With
Set Cn = shp.AddConnector(msoConnectorCurve, 1, 1, 1, 1) 'コネクタ描画 ※位置は仮決め
Cn.Line.EndArrowheadStyle = msoArrowheadTriangle
Cn.Line.DashStyle = msoLineDash
Cn.Line.Weight = 1
If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), "▼") > 0 Then
Cn.Line.ForeColor.RGB = RGB(255, 0, 0)
Else
Cn.Line.ForeColor.RGB = RGB(0, 0, 255)
End If
With Cn.ConnectorFormat
.BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
.EndConnect ConnectedShape:=secondimg.ShapeRange(1), ConnectionSite:=1
'.Type = msoConnectorElbow
Cn.RerouteConnections
End With
End If 'If Err.Number 先生のものに これが抜けていました
End If ' If imgflnm
一応 ここの課題はクリアーしました。 ありがとうございました。
＞ Dim xrb As Long 'この変数の定義が抜けてます ＞ Dim xcb As Long 'これも。まさかモジュールレベルの変数ではないですよね？ 宣言をわすれていました。 なお、xrb 、ｘcb が宣言されていなくても それに数値が入り、一応働いていたようですが なぜでしょう。別のサブルーチンで同じ役割でつかっています。
>Option Explicitをつける＝変数の宣言を強制するにチェックすれば をしたのですが、変わったことがわかりません。
あとすこし別の課題の バグがあり 調査しています。
いくつか説明に不備があったでしょうか？
新規ブックを例に使ってみます。
新規ブックにて、標準モジュール（Module1）を挿入してください。
>変数の宣言を強制するにチェック
オプションにて↑を行なうと、自動的に
Option Explicit
が記述されていますよね？
既に挿入されている標準モジュールには、 >変数の宣言を強制するにチェック を行なっても Option Explicit は、自動的に記述されませんので、面倒でもモジュール１行目に御自分で Option Explicit sub xxxx() ・ ・ と挿入してください。
つまり、モジュールの最初の行に Option Explicit この１行があれば、宣言されていない変数があれば、コンパイルエラーになると言うことです。
例
Option Explicit
Sub test()
xrb = 12
xcb = 15
MsgBox xrb & "------" & xcb
End Sub
↑これは、エラーになりますよね？
>なお、xrb 、ｘcb が宣言されていなくても それに数値が入り、一応働いていたようですが >なぜでしょう。別のサブルーチンで同じ役割でつかっています。
これについて、考えられること
１．単純にOption Explicitが挿入されていない
上記のtestというプロシジャーの１行目のOption Explicitを削除、又は、コメント化してみてください。
'Option Explicit
Sub test()
xrb = 12
xcb = 15
MsgBox xrb & "------" & xcb
End Sub
これでtestを実行すると、今度は変数宣言がなくても正常に作動します。 が、このように変数の宣言なしにいきなり変数を使ってしまうのはバグの原因になりますし、 メンテナンスの面からも保守しにくいコードになりますから、変数の宣言は行なってください。
２．他のモジュールでパブリック変数として、宣言されている
標準モジュール（Module1）の１行目の'Option Explicitを元に戻してください。
Option Explicit
Sub test()
xrb = 12
xcb = 15
MsgBox xrb & "------" & xcb
End Sub
更にもう一つ標準モジュール（Module2）を挿入してください。 このModule2に
Option Explicit Public xrb As Long Public xcb As Long
これでtestを実行すると、今度は、標準モジュール（Module1）に変数宣言がなくても作動します。
が、このPublicと冠した変数を使うのは、要注意です（特に標準モジュールでの使用）。 原則として、使わない方法で考えてください。 乱用すると、これもメンテナンスしにくいコードになってしまいます。 本当に、Public宣言しなくてはならないのか良く検討して下さい。
>それに数値が入り、一応働いていたようですが の理由は、どちらかだと思いますが・・・・。
ichinose
>いくつか説明に不備があったでしょうか？ とんでもない。知識・理解不足です。
>既に挿入されている標準モジュールには、モジュール１行目に御自分で
はい 書きました。
実行すると ありました。たまたま使っていなかったので 支障がなかったのですが、
If ss & se & tngp & bngp & nr = Empty Then
となるべきコードで tngpが tmgpになっていることがわかりました。
これは Private Function sngpse(ss, se, tngp, bngp, nr) '生年、没年 享年
の中の変数でした。
＞Publicと冠した変数を使うのは、要注意です はい これはつかっていませんでした。 多分（１）の単純に たまたま 既定の定義で動作していただけでしょう。 これからは Option Explicitを活かして 定義をします。
ありがとうございました。 (はんにゃ）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.