プログラムチップ集
パイオニアノートを開発するにあたり、用いられたプログラムをご紹介しましょう。
■ 音楽を流す方法
■ 画像をPDFライクに動かす方法
■ カレンダーの表示方法
■ グラデーションの描写
□ 音楽を流す方法
あるVBチップ集を参考にしました。
'□ 音楽を流す処理
'音楽ファイルがないとエラーになるので、まずファイルの有無を確信した上で開く。
'音楽が流れているときに再び音楽を流そうとするとエラーになるので、
'音楽がとまっているときにのみ流す処理をする。
'同じフォルダーにあるpio.midを流す処理です。
'Form1の上にCommand1とCommand2を配置します。
Dim b101 As Boolean '音楽が流されているか確認のための変数
'音楽を流す設定
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
'Declare Function GetShortPathName Lib "kernel32" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
'上記のままだとエラーになるのでエイリアス名をつける
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Sub Form_Load()
Form1.Caption = "音楽を流す"
Command1.Caption = "再生"
Command2.Caption = "停止"
End Sub
Private Sub Form_Unload(Cancel As Integer)
音楽 (1)
End Sub
Private Sub Command1_Click()
'音楽を流す
音楽 (0)
End Sub
Private Sub Command2_Click()
'音楽を止める
音楽 (1)
End Sub
Private Sub 音楽(A As Integer)
'ファイルの有無を確認
'同じフォルダーの中にpio.midがあるか確認
fname$ = App.Path & "\" & "pio.mid"
If Right(App.Path, 1) = "\" Then fname$ = App.Path & "pio.mid"
Ffee = (Dir(fname$) <> "")
If fname$ = "" Then Ffee = False
'ファイルがある場合にのみ処理する
If Ffee = True Then
If A = 0 And b101 = False Then
sname$ = get_ShortName(fname$) '標準モジュールのプロシージャを使って長いファイル名を短いファイル名に変える
rtn = mci_string("open " & sname$ & " alias mcifile ", rtnstr$) 'ファイル名を指定を指定して
If rtn <> 0 Then MsgBox rtnstr$, 16: Exit Sub 'デバイスを開く
rtn = mci_string("play mcifile notify", dummy$)
b101 = True
ElseIf A = 1 And b101 = True Then
'音楽を閉じる
rtn = mci_string("close mcifile", dummy$)
b101 = False
End If
End If
End Sub
'音楽を流す
Function get_ShortName(longName As String) As String '長いファイル名を短いファイル名に変えるプロシージャ
Dim shortName As String * 256 '第2パラメータは固定長でないと受け付けない
dummy = GetShortPathName(longName, shortName, 256) '短いファイル名に変換
get_ShortName = Left$(shortName, InStr(shortName, Chr(0)) - 1) 'ファイル名の長さに合わせてもどす
End Function
Function mci_string(sndstring As String, rtnstring As String) As Long
Dim rtnstr As String * 256 '第2パラメータは固定長でないと受け付けない
rtn = mciSendString(sndstring, rtnstr, 256, 0)
If rtn <> 0 Then 'エラーの場合はその内容を調査する
Beep
dummy = mciGetErrorString(rtn, rtnstr, 256)
End If
If InStr(rtnstr, Chr(0)) > 0 Then '問い合わせたときの戻り値やエラーがある場合は
rtnstring = Left$(rtnstr, InStr(rtnstr, Chr(0)) - 1) '256文字を実際の文字数に合わせてもどす
End If
mci_string = rtn '戻り値の設定( 0:成功 0以外:失敗)
End Function
□ 画像をPDFライクに動かす方法
これはなかなか難しく、苦労した点です。ピクチャーボックスの上でのマウスの動きをスクロールバーに反映させて、スクロールバーの動きによってピクチャーボックスが動くようにして実現しました。
'画面をPDFライクに動かす方法
'フォーム上にPicture1、HScroll1、VScroll1を配置
'
Dim x2 As Integer 'Picture1の横の座標
Dim y2 As Integer 'Picture1の縦の座標
Dim b102 As Boolean 'Picture1が押されているかを知る
Private Sub Form_Load()
'Picture1に適当に線を引く
Picture1.Top = 0
Picture1.Left = 0
Picture1.Width = 10000
Picture1.Height = 10000
Picture1.AutoRedraw = True
Picture1.ForeColor = &H565656
Picture1.Line (0, 0)-(10000, 10000)
Picture1.Line (500, 3000)-(4000, 5000), , BF
End Sub
Private Sub スクロールバー()
'スクローバーを配置する
HScroll1.Left = 0
VScroll1.Top = 0
If Picture1.Width > Me.Width Then
HScroll1.Top = Me.ScaleHeight - HScroll1.Height
Else
HScroll1.Top = Me.ScaleHeight
End If
If Picture1.Height > HScroll1.Top Then
VScroll1.Left = Me.ScaleWidth - VScroll1.Width
If Picture1.Width > VScroll1.Left Then
HScroll1.Top = Me.ScaleHeight - HScroll1.Height
End If
Else
VScroll1.Left = Me.ScaleWidth
End If
HScroll1.Width = Me.ScaleWidth
If HScroll1.Top > 0 Then VScroll1.Height = HScroll1.Top
'スクロールバーの範囲を設定
HScroll1.Max = Picture1.Width - VScroll1.Left
VScroll1.Max = Picture1.Height - HScroll1.Top
HScroll1.SmallChange = Abs(HScroll1.Max \ 16) + 1
HScroll1.LargeChange = Abs(HScroll1.Max \ 4) + 1
VScroll1.SmallChange = Abs(VScroll1.Max \ 16) + 1
VScroll1.LargeChange = Abs(VScroll1.Max \ 4) + 1
HScroll1.ZOrder 0
VScroll1.ZOrder 0
b102 = False
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'クリックしたところの座標を格納して、クリックしていることを示すためにb102をTrueにする
If Button = 1 Then
x2 = X
y2 = Y
b102 = True
End If
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'クリックしていないことを示すためにb102をFalseにする
b102 = False
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Picture1をクリックしたままであるときにのみ動かす。
If b102 = True Then
'有効範囲内のときにのみスクロールバーを動かす
'横のスクロールバー
If HScroll1.Value - (Val(X) - x2) > HScroll1.Max Or HScroll1.Value - (Val(X) - x2) < 1 Then
Else
Me.HScroll1.Value = HScroll1.Value - (Val(X) - x2)
End If
'縦のスクロールバー
If VScroll1.Value - (Val(Y) - y2) > VScroll1.Max Or VScroll1.Value - (Val(Y) - y2) < 1 Then
Else
Me.VScroll1.Value = VScroll1.Value - (Val(Y) - y2)
End If
Else
End If
End Sub
Private Sub VScroll1_Change()
'縦スクロールバーにあわせてPicture1を上下に動かす
Picture1.Top = -VScroll1.Value
End Sub
Private Sub HScroll1_Change()
'横スクロールバーにあわせてPicture1を左右に動かす
Picture1.Left = -HScroll1.Value
End Sub
Private Sub Form_Resize()
'フォームの大きさに合わせてスクロールバーをセットする
スクロールバー
End Sub
□ カレンダーの表示方法
これもあるチップ集を参考にしました。
Form1の上にPicture1、Label1、Command1、Command2、を配置し、Picture1の上にShape1を配置します。
Dim Today As String 'マーク中の日付
Dim FirstDayWeek As Integer '第1日目の曜日
Dim LastDay As Integer '今月の最大値
Dim nDay As Integer '今月のn日
Dim Wd As Single 'カレンダー文字の間隔
Dim Hi As Single 'カレンダー文字の高さ
Dim St As Single '左マージン
Dim Ba As Single '上マージン
Private Sub gprint(X, Y, src)
Picture1.CurrentX = X
Picture1.CurrentY = Y
Picture1.Print src
End Sub
Public Sub Calender(yr As Integer, mo As Integer)
' カレンダーを表示する
Dim ofst As Integer
Dim yobi As String
Dim i As Integer
Wd = Picture1.Width / 8 '7日 + 1
Hi = Picture1.Height / 8 '6行 + 2
St = Wd / 2 '左のマージン
Ba = Hi / 2 '上のマージン
If mo = 13 Then
yr = yr + 1: mo = 1
ElseIf mo = 0 Then
yr = yr - 1: mo = 12
End If
Label1 = Format(yr, "##年") & Format(mo, "##月")
'曜日を書く
yobi = "日月火水木金土"
Picture1.Cls
For i = 0 To 6 ' 曜日のタイトル
Select Case i
Case 0: Picture1.ForeColor = vbRed
Case 6: Picture1.ForeColor = vbBlue
Case Else: Picture1.ForeColor = vbBlack
End Select
gprint i * Wd + St, Ba, Mid$(yobi, i + 1, 1)
Next
'第1日目の曜日と月の最大値を得る
FirstDayWeek = GetFirstDay(yr, mo)
LastDay = GetLastDay(yr, mo)
'カレンダーを書く
For i = 1 To LastDay ' カレンダー
ofst = FirstDayWeek + i - 2
Select Case (ofst Mod 7)
Case 0: Picture1.ForeColor = vbRed
Case 6: Picture1.ForeColor = vbBlue
Case Else: Picture1.ForeColor = vbBlack
End Select
gprint (ofst Mod 7) * Wd + St, ((ofst \ 7) + 1) * Hi + Ba, Format(i, "@@")
Next
End Sub
Public Function GetDay(Mx, My) As Integer
' マウスの位置の日付を返す
Dim days As Integer
' days = Int((Mx - St + Wd / 2) / Wd) + Int((My - Ba - Hi - Hi / 2) / Hi) * 7 - FirstDayWeek + 2
days = Int((Mx - St + Wd * 0.2) / Wd) + Int((My - Ba - Hi + Hi * 0.1) / Hi) * 7 - FirstDayWeek + 2
If 0 < days And days <= LastDay Then
MarkToday days
End If
End Function
Public Sub MarkToday(n As Integer)
' n日を赤枠でマークする
Dim X As Single
Dim Y As Single
Dim w As Single
Dim h As Single
w = TextWidth("222")
h = TextHeight("H") * 1.1
If 1 <= n And n <= LastDay Then
X = ((FirstDayWeek + n - 2) Mod 7) * Wd + St - TextWidth("1") / 3
Y = (((FirstDayWeek + n - 2) \ 7) + 1) * Hi + Ba
Shape1.Move X, Y, w, h
Shape1.Visible = True
End If
End Sub
Private Function GetFirstDay(yr As Integer, mo As Integer) As Integer
'年と月を指定して最初の曜日を得る
Dim s As String
Dim week As String
s = DateSerial(yr, mo, 1)
GetFirstDay = WeekDay(s)
End Function
Private Function GetLastDay(yr As Integer, mo As Integer) As Integer
'年と月を指定して月の最大値を得る
Dim n1 As Long
Dim n2 As Long
'12月の場合は31日
If mo = 12 Then
GetLastDay = 31
Exit Function
End If
'その他の月は翌月1日から今月1日を引く
n1 = DateSerial(yr, mo, 1)
n2 = DateSerial(yr, mo + 1, 1)
GetLastDay = n2 - n1
End Function
Private Sub Form_Load()
Picture1.AutoRedraw = True
Picture1.BackColor = &HFFFFFF
Command1.Caption = "−"
Command2.Caption = "+"
Label1.Alignment = 2
End Sub
Private Sub Form_Paint()
Calender 2004, 9
MarkToday Day(Date)
End Sub
Private Sub Command1_Click()
'前月へ
ChangeMonth -1
End Sub
Private Sub Command2_Click()
'次月へ
ChangeMonth 1
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
nDay = GetDay(X, Y) - 1
End Sub
Sub ChangeMonth(n As Integer)
Dim p As Integer
Dim yr As Integer
Dim mo As Integer
p = InStr(Label1, "年")
yr = Val(Left(Label1, p))
mo = Val(Mid(Label1, p + 1))
Call Calender(yr, mo + n)
If n > 0 Then
Today = DateSerial(yr, mo + n, 1)
Else
Today = DateSerial(yr, mo + n, GetLastDay(yr, mo - 1))
End If
MarkToday Day(Today)
End Sub
□ グラデーションの描写
これはネット上で検索して見つけたチップを参考に作りました。フォームの上にピクチャー1を配置しています。
'グラデーションの作成
Private Type TRIVERTEX
x As Long '頂点のX座標
y As Long '同、Y座標
Red As Integer '同座標位置のカラー値(R値)
Green As Integer '同、G値
Blue As Integer '同、B値
Alpha As Integer 'アルファ値(0可)
End Type
Private Type GRADIENT_TRIANGLE
Vertex1 As Long '頂点座標のうち、三角形の頂点の
'一つを形成する頂点のインデックス
'(GradientFill()関数のpVertexに指定する配列のインデックス)
Vertex2 As Long '同上
Vertex3 As Long '同上
End Type
Private Type GRADIENT_RECT
UpperLeft As Long 'GradientFill()関数のpVertexに定義した頂点座標のうち
'矩形の左上の頂点となるインデックス
LowerLight As Long '同、右下の頂点のインデックス
End Type
'矩形、または三角形の内部をグラデーションで塗りつぶす
Private Declare Function GradientFill Lib "msimg32.dll" _
(ByVal hdc As Long, pVertex As Any, ByVal dwNumVertex As Long, _
pMesh As Any, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long
'dwModeの定数
Const GRADIENT_FILL_RECT_H = &H0 '水平方向にグラデーション
Const GRADIENT_FILL_RECT_V = &H1 '垂直方向にグラデーション
Const GRADIENT_FILL_TRAIANGLE = &H2 '三角形グラデーション
Private Sub Form_Load()
Picture1.ScaleMode = 3
Picture1.AutoRedraw = True
グラデーション
End Sub
Private Sub グラデーション()
Dim pVertex(3) As TRIVERTEX
Dim pMesh As GRADIENT_RECT
Dim CON As Control
Set CON = Picture1 'ピクチャー1にグラデーションを描く
With pVertex(0) '左上の座標と左側の色を指定
.x = 0
.y = 0
.Red = &HC300
.Green = &H7800
.Blue = &HFF00
.Alpha = 0
End With
With pVertex(1) '右下の座標と右側の色を指定
.x = CON.ScaleWidth
.y = CON.ScaleHeight
.Red = &H2F00
.Green = &H8600
.Blue = &H4500
.Alpha = &HF400
End With
With pMesh
.LowerLight = 0
.UpperLeft = 1
End With
'GradienrtFill()というAPI関数を使ってグラデーションを作成
Call GradientFill(CON.hdc, pVertex(0), 2, pMesh, 1, GRADIENT_FILL_RECT_H)
End Sub