ウォーターサーバーとコーヒーマシンが一体化した画期的マシン >>

 VBAでゲームを作ろうとしています。まず、手始めに簡単なスロットを作っています。スロットを回転させて止めるまではできたのですがメッセージを出す段階でメッセージが2回、0とiの値が出ます。次のコードなのですが、なぜできないのか、どうすればできるようになるのか教えてください。よろしくお願いします。

Sub SlotLoop_1()
Dim i As Long
Static Flg As Boolean

Flg = Not Flg 'ボタンを使えるようにする

With [a1] 'A1を選ぶ
Do
If Flg = False Then Exit Do
i = (i + 1) Mod 10 '(i+1)を10で割った余り。
.Value = i
DoEvents
Loop
End With

MsgBox i 'ここが問題

End Sub

このQ&Aに関連する最新のQ&A

A 回答 (1件)

 これって、あるボタンを押したらFlgがTrueになって、スロットがぐるぐる回る。

もう一度同じボタンを押したらFlgがFalseになって、スロットが止まってメッセージを出す、という事でしょう?

 これではちょっと無理やね。フラグの状態によって分岐させんと。

> なぜできないのか
 まず、1個目のButton_Click()がFlgをTrueに変えてループし、ループの途中で他のメッセージを処理します。
 ここで同じボタンを押すと、1個目のButton_Click()がまだ実行途中のまま2個目のButton_Click()が動き始め、FlgをFalseに変えます。そして2個目はFlgがFalseなのでそのまま(=iが0のまま)ループを1回も実行せずに抜けてMsgBoxで「0」を表示して終了します。
 その後、DoEventsで2個目のButton_Click()が実行され終了されるのを待っていた1個目のButton_Click()に制御が戻り、ループしていた回数だけ変化したiの値がMsgBoxによって出てきた訳だ。

 修正方法としては・・・・一番簡単なのは、
----オリジナルソーススタート
Flg = Not Flg 'ボタンを使えるようにする
----オリジナルソースエンド
これを次のように変えましょう。
----修正ソーススタート
Flg = Not Flg 'ボタンを使えるようにする
If Not Flg Then Exit Sub ' ここに来た時にFlgがFalseなら、2個目という事なのでそのまま終了
----修正ソースエンド

今回はDoEventsの気をつけなければいけない使い方の例でした。
    • good
    • 0
この回答へのお礼

 お答えいただきありがとうございました。早速やってみたところ上手くいきました。まさか2つ目のボタンが働いたと思いませんでした。

お礼日時:2005/10/01 15:29

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qスロットゲームのプログラミング

お世話になります。
先日からスロットゲームに関して、質問しているものなのですが、リールが止まる時のタイミングについて質問です。
ボタンをクリックすると、回転し自然に止まるスロットなのですが、絵柄を用意してパラパラ漫画の要領で回転を再現してます。
各リール用にタイマーを設置して、1リール目が止まると、2リールのインターバルを0にして、止める構造に
してあるのですが、1~3リールとも同じタイミングで止まってしまいます。
タイマーウェイト処理も停止絵柄の前で止まり、ウェイト後にカックンと止まる始末。
自然にポン、ポン、ポンと止まるように処理するには
どうしたら用意でしょうか。
またご指導のほどよろしくお願いします。

Aベストアンサー

VB6のタイマーは,はっきり言って使えません。
と言うのは,タイマーイベントはWindows上で動くので,
どうしても他のアプリケーションやタスクの影響を受けるからです。

それでは,どうやって正確な時間を測るかですが,
これにはWindowsAPIのTimeGetTimeを使います。
使い方は,検索エンジンでTimeGetTimeって引けば出てきます。

簡単に紹介すると,TimeGetTimeはシステムが起動してからの
時間を測るためのものです。これを使うには,まず

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

を一番上の欄外でグローバル変数として宣言する必要があります。
つぎに,たとえばある一定の時間待つようなSubルーチンを作るなら,
Private Sub Wait(WaitTime As Long)
Dim TimeStart As Long
StartTime = timeGetTime
Do
DoEvents
Loop While (timeGetTime - StartTime < WaitTime)
End Sub
のようにします。

これを応用して,リールの止まる際にランダムでウェイト時間を
足して行けば,ゆっくり回転するようになります。
もちろん,ランダムで数字を加えますので,
同時に止まることはありません。
解りにくい場合は,また補足します。

VB6のタイマーは,はっきり言って使えません。
と言うのは,タイマーイベントはWindows上で動くので,
どうしても他のアプリケーションやタスクの影響を受けるからです。

それでは,どうやって正確な時間を測るかですが,
これにはWindowsAPIのTimeGetTimeを使います。
使い方は,検索エンジンでTimeGetTimeって引けば出てきます。

簡単に紹介すると,TimeGetTimeはシステムが起動してからの
時間を測るためのものです。これを使うには,まず

Private Declare Function timeGetTime Lib "winmm.dll"...続きを読む

QVB上で実行中の無限ループの止め方

今まで、CUIベースのBASICでのプログラムの経験はあるのですが
Visual系のBASICは初心者です。
原因はわかっているのでプログラムの修正はできるのですが
VB上でコンパイルして実行したときに無限ループに陥ってしまって
どうにもプログラムをとめられなくなります。
そんなことがないように、実行前に全てのプロジェクトを保存して
いますので、そんなに実害はないのですが、どうすればとめられるのでしょう・・
今現在は、タスクマネージャーから強制終了させています。

Aベストアンサー

無限ループの一番内側に
DoEvents
を入れておくと、ウィンドウ切替え->デバッガ終了操作が出来ますよ

危なそうなとこにも入れておくと、何かと安心です。

QDoEvents関数って何?

こんにちは。

VBAやプログラミングに詳しい皆様に
教えていただきたい質問があります。

cells(1,1)からcells(5000,1)までの値を消去するときに
処理の進行状況を表示するためにuserform上にプログレスバーを表示したいと思います。

そこで下記のようなコードを入力しました。

userform1.show
for i =1 to 5000
cells(i,1)=""
userform1.progressbar1.value=i/5000*100
next i
unload userform1

しかしこれだとuserformの背景が真っ白になってしまい
ラベルの文字も消えてしまいます。
そこで「EXCEL VBA パーフェクトマスター」という本を見たら

for i =1 to 5000
cells(i,1)=""
userform1.progressbar1.value=i/5000*100
DoEvents
next i
unload userform1
と入力すれば解決することがわかりました。

しかし「DoEvents」についてあまり詳しく書いていなかったのでDoEvents関数をヘルプで見ると、
「発生したイベントがオペレーティング システムによって処理されるように、プログラムで占有していた制御をオペレーティング システムに渡すフロー制御関数です。」

と書いてあるのですが正直、書いてあることがよくわかりません。

どなたかDoEvents関数について、
もう少しわかりやすく教えていただけませんか。
それから、最初に書いたコードで実行すると
ユーザーフォームの背景が真っ白になってしまう原因も
教えていただけませんか?

よろしくお願いいたします。

こんにちは。

VBAやプログラミングに詳しい皆様に
教えていただきたい質問があります。

cells(1,1)からcells(5000,1)までの値を消去するときに
処理の進行状況を表示するためにuserform上にプログレスバーを表示したいと思います。

そこで下記のようなコードを入力しました。

userform1.show
for i =1 to 5000
cells(i,1)=""
userform1.progressbar1.value=i/5000*100
next i
unload userform1

しかしこれだとuserformの背景が真っ白になってしまい
ラベルの文字も消えてしまいます。
そ...続きを読む

Aベストアンサー

簡単に言うと、
OS に制御を渡すってことです。(ヘルプそのまんま)
時間が掛かるループ処理などの場合、ループが終わるまで制御は独占されてしまいます。
ですのでループ中は OS や Excel そのものにも再描画をさせる暇さえ与えません。
途中に DoEvents を入れると制御が OS に渡るので、OS は溜まっていた処理をそこで行うことができます。
結果、フォームの再描画などが行われることになります。

注意点ですが、
Private Sub CommandButton1_Click()
  Dim i As Long

  For i = 1 To 50000
    DoEvents
    Cells(i,1) = ""
  Next i
End Sub

Private Sub CommandButton2_Click()
  MsgBox "hoge"
End Sub

っていうフォームのコードがあった場合、
DoEvents を入れることによって、ループ中にユーザーがCommandButton2 を押すことによって CommandButton2 のクリック イベントも動いちゃいます。
CommandButton1 のクリック イベントではループの前に
CommandButton1.Enabled = False
CommandButton2.Enabled = False
を書いてフォーム上の CommandButton を無効にしておき、ループが終わったら
CommandButton1.Enabled = True
CommandButton2.Enabled = True
と書いて CommandButton を有効に戻してください。

これを工夫すれば、CommandButton2 で CommandButton1 のループを途中キャンセルする処理もすることができます。

Private Canceled As Boolean

Private Sub CommandButton1_Click()

  CommandButton2.Enabled = False

  Dim i As Long
  For i = 1 To 50000
    DoEvents

    If Canceled = True Then
      MsgBox "キャンセルしました"
      Exit Sub
    End If

    Cells(i, 1).Value = ""
  Next i
End Sub

Private CommandButton2_Click()
  Canceled = True
End Sub



コードの行頭にあるスペースは見易さのために全角スペースで作成していますので、これをこのままコピペするとエラーになるかもしれません。
コピペするなら行頭の全角スペースを半角スペースに直してください。

簡単に言うと、
OS に制御を渡すってことです。(ヘルプそのまんま)
時間が掛かるループ処理などの場合、ループが終わるまで制御は独占されてしまいます。
ですのでループ中は OS や Excel そのものにも再描画をさせる暇さえ与えません。
途中に DoEvents を入れると制御が OS に渡るので、OS は溜まっていた処理をそこで行うことができます。
結果、フォームの再描画などが行われることになります。

注意点ですが、
Private Sub CommandButton1_Click()
  Dim i As Long

  For i = 1 To 50000
...続きを読む

QVBAで画像を表示する方法

VBA初心者です。ExcelのVBAでプログラミングの練習をしています。
早速ですが質問させてください。
ユーザーフォーム上にコマンドボタンをクリックすることにより画像を表示させることはできるのですが、これをユーザーフォームを開いた瞬間に自動的に表示させる方法はないのでしょうか?

ちなみに現在は以下のようにしています。
Private Sub CommandButton1_Click()
Image1.Picture = LoadPicture(" ")
End Sub

インターネットで調べてみても見つからないので質問させてもらいました。分かりにくい説明でしたらすみません。

Aベストアンサー

UserFormのinitializeイベントかActivateイベントを使ってください。

Private Sub UserForm_Initialize()
 Image1.Picture = LoadPicture("C:\aaa.jpg")
End Sub

または、

Private Sub UserForm_Activate()
 Image1.Picture = LoadPicture("c:\aaa.jpg")
End Sub

QExcel VBA じゃんけん

じゃんけんのプログラミングを作っているのですが、今できているじゃんけんの
プログラムの追加機能として得点式のゲームにしたいと思っています。
ルールとしては、10回じゃんけんをしてポイントを0から
勝ったら 得点+1
引き分けたら 得点 +0
負けたら 得点 -1
というふうにして
最終的に合計点数が0より大きければ勝ち0より小さければ負け
というようなものにしたのですが
どうすればよいですか?
ついでに完成したじゃんけんプログラムは下のような感じです。





Private Sub CommandButton1_Click()

Cells(1, 1) = Int(Rnd * 3)

If Cells(1, 1) = 0 Then
Label1.Caption = "私もグー。だから引き分けです。"
End If

If Cells(1, 1) = 1 Then
Label1.Caption = "私はチョキ。だからあなたの勝ちです。"
End If

If Cells(1, 1) = 2 Then
Label1.Caption = "私はパー。だからあなたの負けです。"
End If

End Sub

じゃんけんのプログラミングを作っているのですが、今できているじゃんけんの
プログラムの追加機能として得点式のゲームにしたいと思っています。
ルールとしては、10回じゃんけんをしてポイントを0から
勝ったら 得点+1
引き分けたら 得点 +0
負けたら 得点 -1
というふうにして
最終的に合計点数が0より大きければ勝ち0より小さければ負け
というようなものにしたのですが
どうすればよいですか?
ついでに完成したじゃんけんプログラムは下のような感じです。





Private S...続きを読む

Aベストアンサー

お疲れさまです

入力がないので、こちらが出すのはグーときめているのでしょうか?

一応、10回勝負を考えてみました。

Private Sub CommandButton1_Click()

Dim i As Integer
Dim ft As Integer

ft = 0



For i = 1 To 10

MsgBox i & "回目"
Cells(1, 1) = Int(Rnd * 3)

If Cells(1, 1) = 0 Then
Label1.Caption = "私もグー。だから引き分けです。"
ft = ft
End If

If Cells(1, 1) = 1 Then
Label1.Caption = "私はチョキ。だからあなたの勝ちです。"
ft = ft + 1
End If

If Cells(1, 1) = 2 Then
Label1.Caption = "私はパー。だからあなたの負けです。"
ft = ft - 1
End If

Next i

If ft > 0 Then
Label1.Caption = "10回勝負結果=あなたの勝ちです"
Else
Label1.Caption = "10回勝負結果=あなたの負けです"
End If

End Sub

お疲れさまです

入力がないので、こちらが出すのはグーときめているのでしょうか?

一応、10回勝負を考えてみました。

Private Sub CommandButton1_Click()

Dim i As Integer
Dim ft As Integer

ft = 0



For i = 1 To 10

MsgBox i & "回目"
Cells(1, 1) = Int(Rnd * 3)

If Cells(1, 1) = 0 Then
Label1.Caption = "私もグー。だから引き分けです。"
ft = ft
End If

If Cells(1, 1) = 1 Then
Label1.Caption = "私はチョキ。だからあなたの勝ちです。"
ft = ft + 1
End If

If ...続きを読む

Q画像処理について。(移動)

今、スロットのアプリケーションを作成中なのですが、
いまいちリールの回転が滑らかじゃありません。
試してみたのが、ピクチャーを12345と作り、
1番目の画像を2番目へ.....と一つずつずらしていく方法
(画像をずらす)
もう一つ
12345とピクチャーを作り、
ピクチャーボックスの位置を動かしていく方法
(1が2の位置へ2が...5が1の位置へ)
この二つの方法ではいまいち滑らかにリールが回転するようには、見えません。(timeの関数を使ってあります)
よい方法が有りましたらぜひ教えてください。

画像の変数(リール配列は21個あります。)
画像の種類は7種類

Aベストアンサー

サンプルです。

フォーム1[Form1]
├コマンドボタン1[Command1]

├コマンドボタン2[Command2]

├ピクチャボックス1[Pictur1]
││
│└ピクチャボックス2[Pictur2]

└ピクチャボックス3[Pictur3]

となるように画面に各コントロールを貼り付けてください。
ピクチャボックス2はピクチャボックス1の中に入れてください。
lngPicW/lngPicHでピクチャの1つの領域範囲を設定してます。
lngMoveVectでピクチャの移動量を設定してます。これはlngPicHを割り切れる数字に設定した方が、スムーズに動きます。

Option Explicit

Private Const lngPicW  As Long = 100  'ピクチャの幅
Private Const lngPicH  As Long = 100  'ピクチャの高さ

Private Const lngMoveVect  As Long = 5   'ピクチャの移動量(高さを割り切れる数字が好ましい)

'スクロールを行うピクチャの高さ
Private lngScrollPicH  As Long

Private Sub Command1_Click()
  Dim wkAry  As Variant
  Dim i    As Long
  Dim lngCntPic  As Long
  
  '絵の情報
  wkAry = Array( _
        "C:\WINNT\しゃくなげ.bmp" _
       , "C:\WINNT\グリーン ストーン.bmp" _
       , "C:\WINNT\サポテック織り.bmp" _
       , "C:\WINNT\サンタフェ.bmp" _
       , "C:\WINNT\シャボン.bmp" _
       )
  
  'ピクチャの数
  lngCntPic = UBound(wkAry) + 1
  
  'スクロールピクチャの高さ取得
  lngScrollPicH = (lngCntPic + 1) * lngPicH

  With Me
    .Command1.Enabled = False
    .Command2.Enabled = True
  
    With .Picture1
      .Visible = True
    End With
    
    With .Picture2
      .Visible = True
      
      .Width = lngPicW
      .Height = lngScrollPicH
      .Left = 0
      .Top = lngPicH - lngScrollPicH
    End With
    
    For i = 0 To lngCntPic - 1
      .Picture3.Picture = LoadPicture(wkAry(i))
      Call .Picture2.PaintPicture(.Picture3.Picture, 0, (lngCntPic - i) * lngPicH, lngPicW, lngPicH, 0, 0, .Picture3.ScaleWidth, .Picture3.ScaleHeight, vbSrcCopy)
      If i = 0 Then
        Call .Picture2.PaintPicture(.Picture3.Picture, 0, 0, lngPicW, lngPicH, 0, 0, .Picture3.ScaleWidth, .Picture3.ScaleHeight, vbSrcCopy)
      End If
    Next i
    
  End With
  
End Sub

Private Sub Command2_Click()
  Dim blnWork As Boolean
  With Me
    blnWork = Not .Timer1.Enabled
    
    If blnWork Then
      .Command2.Caption = "停止"
    Else
      .Command2.Caption = "回転"
    End If
    .Timer1.Enabled = blnWork
    
  End With
End Sub

Private Sub Form_Load()
  '各初期設定です
  'あらかじめデザイン時にここのForm_Loadイベントでしていることを設定しておくと、Form_Loadのイベントは省略できます

  With Me
    With .Command1
      .Caption = "初期設定"
      .Enabled = True
    End With
    
    With .Command2
      .Caption = "回転"
      .Enabled = False
    End With
  
    With Timer1
      .Enabled = False
      .Interval = 1
    End With
  
  
    .ScaleMode = vbPixels
    
    With .Picture1
      .ScaleMode = vbPixels
      .AutoSize = False
      .Visible = False
      .Appearance = 0
      .BorderStyle = 0
      .AutoRedraw = True
      .Enabled = False
      .Cls
      
      .Width = lngPicW
      .Height = lngPicH
    End With
    
    With .Picture2
      .ScaleMode = vbPixels
      .AutoSize = False
      .Visible = False
      .Appearance = 0
      .BorderStyle = 0
      .AutoRedraw = True
      .Enabled = False
      .Cls
    End With
    
    With .Picture3
      .ScaleMode = vbPixels
      .AutoSize = True
      .Visible = False
      .Appearance = 0
      .BorderStyle = 0
      .AutoRedraw = True
      .Enabled = False
      .Cls
    End With
    
  End With
  
End Sub

Private Sub Timer1_Timer()
  Dim lngTop  As Long
  With Me
    'TOP位置を計算
    lngTop = .Picture2.Top + lngMoveVect
    If lngTop >= 0 Then
      lngTop = lngPicH - lngScrollPicH
    End If
    .Picture2.Top = lngTop
  End With
End Sub

サンプルです。

フォーム1[Form1]
├コマンドボタン1[Command1]

├コマンドボタン2[Command2]

├ピクチャボックス1[Pictur1]
││
│└ピクチャボックス2[Pictur2]

└ピクチャボックス3[Pictur3]

となるように画面に各コントロールを貼り付けてください。
ピクチャボックス2はピクチャボックス1の中に入れてください。
lngPicW/lngPicHでピクチャの1つの領域範囲を設定してます。
lngMoveVectでピクチャの移動量を設定してます。これはlngPicHを割り切れる数字に設定した方が、スムーズ...続きを読む

QVBで簡単なゲームをつくるサイト

お世話になります。
VBでのゲームづくりを少し勉強してみたいとおもっているのですが、比較的簡単なコードで、パズルゲームとかシューティングゲームとかもぐら叩きとか、クラシックなゲームの作り方を教えてくれるサイトがあれば紹介して下さい。

Aベストアンサー

質問の趣旨に合わないかもしれませんが・・

http://www.realdigital.co.jp/densi2/index.html
http://www2u.biglobe.ne.jp/~i-you/build.htm
http://www.sala.or.jp/~itagaki/vb/kouza.htm
http://www.asahi-net.or.jp/~wv5t-tkmn/
http://dir.biglobe.ne.jp/dir/182186/178503/177310/197270/index3.html

<書籍では・・>
http://www.shoeisha.com/book/Detail.asp?bid=668
http://www.grand-master.net/works/works.htm
http://www.villagecenter.co.jp/book/vb3.html

QVBAで作れるかな?

エクセルVBAで、
スタートボタンを押すと値の入ってるセルを自動的に移動していって、ストップボタンを押すと止まる。
そんなルーレットみたいなものって作れますか???

Aベストアンサー

ストップボタンはないけれど、こんなの作ってみました。
まっさらなワークシートで試してみてください。

Sub ルーレット()
Range("B3:K9").Select
With Selection
.Font.Name = "Arial Black"
.Font.Size = 20
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
ActiveWorkbook.Names.Add Name:="table", RefersTo:=Selection
n = 0
For Each c In Range("table")
n = n + 1
c.Value = n
Next
For i = 1 To 2
For Each c In Range("table")
c.Select
For m = 20 To 3 Step -1
Selection.Interior.ColorIndex = m
Next m
Range("table").Interior.ColorIndex = 0
Next c
Next i
Randomize
x = Int(Rnd * 70) + 1
For Each c In Range("table")
c.Select
For m = 20 To 3 Step -1
Selection.Interior.ColorIndex = m
Next m
Range("table").Interior.ColorIndex = 0
If c.Value = x Then
Selection.Interior.ColorIndex = 3
Exit Sub
End If
Next c
End Sub

ストップボタンはないけれど、こんなの作ってみました。
まっさらなワークシートで試してみてください。

Sub ルーレット()
Range("B3:K9").Select
With Selection
.Font.Name = "Arial Black"
.Font.Size = 20
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
With .Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.HorizontalAlignme...続きを読む

QExcel VBAで「プログラム実行」ボタンと「プログラム停止」ボタンをつけたい

ExcelでVBAを使いアプリをつくっています。
プログラムを実行させるボタンはもちろんつくれるのですが、
プログラムを停止させるボタンをつくるにはどうしたら良いのかと悩んでいます。

ボタンに登録できるのはひとつのプロシージャですよね。
とすると「他のプロシージャを止める」プロシージャをつくらねばならないのでしょうか。とするとどうやって・・・?

Aベストアンサー

s_husky です。

状況が判明したので再回答!

Public StopNow As Boolean

Public Sub Test()
  Do Until StopNow
    Sheets(1).Cells(1, 1) = Sheets(1).Cells(1, 1) + 1
    Pause 10
  Loop
  If StopNow Then
    MsgBox "Test の実行をストップしました。"
  End If
End Sub

Public Sub Pause(ByVal PauseTime As Single)
  Dim Finish As Single
  
  Finish = Timer + PauseTime
  Do
    DoEvents
  Loop Until Timer > Finish
End Sub

Private Sub CommandButton2_Click()
  StopNow = True
End Sub

Private Sub CommandButton1_Click()
  Test
End Sub

起動したプロシージャを止める必要があるということはループ処理と理解。
ならば、ループの条件を操作すれば宜しいかと。
CommandButton1 で起動した Test は CommandButton1 で止めれます。

Application.OnTime TimeValue("16:30:00"), "Test"

で起動しようと同じ理屈。

Application.OnTime は、一種の起動ツール。
当然に停止機能もあるが、停止を制御するには上記のような仕掛けが必要と思います。

s_husky です。

状況が判明したので再回答!

Public StopNow As Boolean

Public Sub Test()
  Do Until StopNow
    Sheets(1).Cells(1, 1) = Sheets(1).Cells(1, 1) + 1
    Pause 10
  Loop
  If StopNow Then
    MsgBox "Test の実行をストップしました。"
  End If
End Sub

Public Sub Pause(ByVal PauseTime As Single)
  Dim Finish As Single
  
  Finish = Timer + PauseTime
  Do
    DoEvents
  Loop Until Timer > Finish
End Sub

P...続きを読む

Q任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるようにしようとすると、かなり難易度が高くお手上げ状態です。
このプログラムをどのように改修すれば可能になるかお教えください。

Sub 図11()

Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture

' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可)", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)

' 貼り付け開始セルを選択
Range("B6").Select

' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))

'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置:アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置:アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = ActiveCell.MergeArea.Height
End With

' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
ActiveCell.Offset(5).Select

Set PIC = Nothing
Next i

' 終了
Application.ScreenUpdating = True

End Sub

よろしくおねがいします。
※マクロはほぼ初心者です。大体がネットからコピペをして使っている程度のレベルです。

ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。

実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。

1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるよう...続きを読む

Aベストアンサー

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトしてください。また、DoEvents も入れておきました。
④は、何も手を付けていません。
コメント・アウトした部分で不要なら削除してください。

'//
Sub 図11R()
 'No. 9024507
 Dim strFilter As String
 Dim Filenames() As Variant
 Dim fName As Variant, ext As String
 Dim PIC As Picture
 Dim k As Long, m As Long
 Dim i As Long, j As Long
 Dim cnt As Long
 Dim FirstRng As Range
 Dim r As Range
 Dim Sel_Folder As Object, Sel_Path As String
 cnt = 0 'カウントの初期値
 '貼り付け最初のセル
 Set FirstRng = Range("A2")
 
  Set Sel_Folder = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "フォルダを選択してください", 5)

  If Not Sel_Folder Is Nothing Then
    Sel_Path = Sel_Folder.Self.Path
  Else
   Exit Sub
  End If
 
 ' 「ファイルを開く」ダイアログでファイル名を取得
 ChDir Sel_Path
' strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
' Filenames = Application.GetOpenFilename( _
' FileFilter:=strFilter, _
' Title:="図の挿入(複数選択可)", _
' MultiSelect:=True)
 fName = Dir("*.*", vbNormal)
 Do While fName <> ""
  If fName <> "." And fName <> ".." Then
   ext = Mid(fName, InStrRev(fName, ".") + 1)
   If InStr(1, "jpg,jpeg,gif,bmp,png", ext, 1) > 0 And Not fName Like "#*" Then
    cnt = cnt + 1
    DoEvents
    ReDim Preserve Filenames(1 To cnt)
    Filenames(cnt) = fName
    ''安全のため(上限を設定)
    If cnt > 100 Then Exit Do
   End If
  End If
  fName = Dir()
 Loop
 If cnt = 0 Then Exit Sub
 
 ' ファイル名をソート
 Call BubbleSort_Str(Filenames, True, vbTextCompare)
 
 '' 貼り付け開始セルを選択
 'Range("B6").Select
 
 ' マクロ実行中の画面描写を停止
 Application.ScreenUpdating = False
 ' 順番に画像を挿入
 k = LBound(Filenames)
 m = UBound(Filenames)
 
 For j = 1 To Int(m / 4) + Abs(m Mod 4 > 0)
  For i = 1 To 4
   Set PIC = ActiveSheet.Pictures.Insert(Filenames(k))
   Set r = FirstRng.Cells(1 + (j - 1) * 2, i)
   
   '-------------------------------------------------------------
   ' 画像の各種プロパティ変更
   '-------------------------------------------------------------
   With PIC
    .Top = r.Top ' 位置:アクティブセルの上側に重ねる
    .Left = r.Left ' 位置:アクティブセルの左側に重ねる
    .Placement = xlMove ' 移動するがサイズ変更しない
    .PrintObject = True ' 印刷する
   End With
   With PIC.ShapeRange
    .LockAspectRatio = msoTrue ' 縦横比維持
    ' 画像の高さをアクティブセルにあわせる
    ' 結合セルの場合でも対応
    .Height = r.MergeArea.Height
   End With
   
   ' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
   ' ActiveCell.Offset(5).Select
   
   Set PIC = Nothing
   k = k + 1
   If k >= m Then Exit For
  Next i
 Next j
 Application.ScreenUpdating = True
 ChDir ThisWorkbook.Path
End Sub

>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される

①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトし...続きを読む


人気Q&Aランキング