いつかこれで4コマを

 ★ スライドショーと読み上げ ★ 
 ご訪問頂きありがとうございます。アラクリカエシキ(阿良々木)です。
 最近描いたらくがきを使ってスライドショーと読み上げをやってみました。
 いつかはこれで四コマ漫画描いてみたいです。
Private Sub CB1_Click()
Dim bangou, a, n As Long
Dim picst, serifu As String
a = Range("F1").Value '開始番号
n = Range("H1").Value '終了番号
For bangou = a To n
DoEvents
Range("B1").Value = bangou
DoEvents
serifu = CStr(Range("D1"))
Application.Speech.Speak (serifu)
Call AdPic
DoEvents
Application.Wait Now() + TimeValue("00:00:01")
Next bangou
Sheets("code").Select
Application.Wait Now() + TimeValue("00:00:04")
Sheets("End").Select
Application.Speech.Speak ("ご視聴ありがとうございました")
End Sub




Option Explicit
Sub AdPic()
Application.ScreenUpdating = False
Dim i As Long
If Worksheets(1).Shapes.Count = 0 Then
GoTo ADDPIC
Else
GoTo DELSHAP
End If
DELSHAP:
With Worksheets(1)
For i = .Shapes.Count To 1 Step -1
If .Shapes(i).Type = msoPicture Then .Shapes(i).Delete
Next i
End With
ADDPIC:
Dim picst As String
picst = ThisWorkbook.Path & "\PIC\" & _
Right("00" & Range("B1").Value, 2) & ".JPG"
If Dir(picst) = "" Then
MsgBox "ERROR"
Exit Sub
End If
Worksheets(1).Shapes.AddPicture _
Filename:=picst, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=0, _
Top:=32, _
Width:=640, _
Height:=360
Application.ScreenUpdating = True
End Sub
関連記事
スポンサーサイト



コメントの投稿

非公開コメント

更新もお疲れさまです

動画もアップされてましたね

今、アルバイト先なので
家に帰ったら動画拝見しますよー
1Gしか契約してないので
動画は家のパソコンで拝見する事にしましょう♪



アルバイトもお疲れさまです

動画はしょぼいので期待しないでください(;^_^A
以前あげた動画に使ったマクロを組み合わせたものです。
訪問者さま
カレンダー
06 | 2020/07 | 08
- - - 1 2 3 4
5 6 7 8 9 10 11
12 13 14 15 16 17 18
19 20 21 22 23 24 25
26 27 28 29 30 31 -
プロフィール

arakurikaesiki

Author:arakurikaesiki
阿良々木(あらくりかえしき)と申します。趣味はらくがき/ビオトープ/アクアリウム、好きな小説は物語シリーズです。あと、仕事で楽したいためにExcelのVBAをちょくちょくいじってます。
なお、当ブログはリンクフリーです、よろしければリンク貼ってください。
また、ブロともさまも募集中です。コメントとかもらえるとすごく喜びます。

ブロとも様募集中ですm(_)m

この人とブロともになる

最新コメント
リンク(敬称略)
らくがき
新着記事
また雨(あつ森) Jul 09, 2020
やっと雨やんだ Jul 08, 2020
今日も大雨 Jul 07, 2020
ザー---------ァ Jul 06, 2020
Re:エリザベス Jul 04, 2020
七つの大罪 Jul 03, 2020
何を描くかは… Jul 02, 2020
致命的? Jun 30, 2020
64bit版(;^_^A Jun 29, 2020
しゃくれちゃった Jun 28, 2020
カテゴリ
アクセスランキング
[ジャンルランキング]
ブログ
1401位
アクセスランキングを見る>>

[サブジャンルランキング]
イラストブログ
44位
アクセスランキングを見る>>
にほんブログ村(ビオトープ)
月別アーカイブ
人気ブログランキング
更新通知登録ボタン

更新通知で新しい記事をいち早くお届けします

検索フォーム