プログラムチップ集

 パイオニアノートを開発するにあたり、用いられたプログラムをご紹介しましょう。
■ 音楽を流す方法

■ 画像を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

上記の4プログラムで作成した実行ファイル