| 2012/04/01〜 | |
| K.I | |
| 接尾辞 | 型宣言 | 名称 | サイズ | 値の範囲 |
|---|---|---|---|---|
| $ | String | 文字型 | 2/文字 | 文字列の長さは 0〜32K |
| なし | Byte | バイト型 | 1 | 0〜255 |
| % | Integer | 整数型 | 2 | ‐32,768〜32,767 |
| & | Long | 長整数型 | 4 | ‐2,147,483,648〜2,147,483,647 |
| @ | Currency | 通貨型 | 8 | ‐922,337,203,685,477.5807〜922,337,203,685,477.5807 |
| ! | Single | 単精度浮動小数点数型 | 4 | ‐3.402823E＋38〜3.402823E＋38 |
| # | Double | 倍精度浮動小数点数型 | 8 | ‐1.7976931348623158＋308〜1.7976931348623158＋308 |
| なし | Boolean | 論理型 | 2 | True(‐1), False(0) |
Select Case data
Case Is < 50
:
Case 50 to 100
:
Case Else
:
End Select
Dim result As Variant
result = Split(str_data," ")
show_result(result)
Sub show_result(result As Variant)
Dim i As Integer
Dim x As Integer, y As Integer
x = 3
y = 10
For i = 1 To UBound(result)
With Worksheets("Result")
.Cells(y, x) = Val("&h" & result(i))
End With
y = y + 1
Next i
End Sub
Private Sub Workbook_open()
'起動時の処理
End Sub
Private Sub UserForm_Initialize()
'起動時の処理
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'終了時の処理
Cancel = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'終了処理
Cancel=False
End Sub
| 定数 値 | 意味 |
|---|---|
| vbFormControlMenu | 0 クローズボタン（×ボタン）が押された |
| vbFormCode 1 | コードによるUnload命令 |
| vbAppWindows 2 | Windowsの終了 |
| vbAppTaskManager | 3 TaskManagerによる終了 |
| vbFormMDIForm 4 | MDIFormの上位が終了 |
Private Sub Workbook_Open()
UserForm.Show vbModeless
End Sub
Private Sub MyList_Initialize()
With MyList
.Style = fmStyleDropDownCombo
.Clear
.AddItem ("ABC")
.AddItem ("DEF")
.AddItem ("GHI")
.AddItem ("JKL")
.ListIndex = 1
End With
End Sub
Private Sub UserForm_Initialize()
MyList_Initialize
End Sub
StatusBar1.Panels.Item(1).Text = "ABC"
txt.value = Replace(Replace(txt.value, vbCr, ""), vbLf, "")
Sub ShowColorPalette()
Dim x As Long
Dim y As Long
For x = 1 To 8
For y = 1 To 7
With Cells(y, x)
.Interior.ColorIndex = (y - 1) * 8 + x
.Value = (y - 1) * 8 + x
End With
Next
Next
End Sub
Cells(y,x).Interior.Color = RGB(r, g, b)
ActiveWorkbook.Colors(56) = RGB(r, g, b)
ActiveWorkbook.ResetColors
Public Drg As Boolean 'Drag flag
Public DrX As Single, DrY As Single 'Drag location
Private Sub Button1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Drg = False Then
Drg = True
DrX = X: DrY = Y
Button1.ZOrder 0
End If
End Sub
Private Sub Button1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim XX As Single, YY As Single
If Drg Then
XX = Button1.Left + X - DrX
YY = Button1.Top + Y - DrY
Button1.Move XX, YY
End If
End Sub
Private Sub Button1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Drg = False
End Sub
Private Sub Label1_Click()
CreateObject("wscript.shell").Run "http://bluefish.orz.hm/sdoc/vba_memo"
End Sub
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Dim file As String file = ThisWorkbook.Path & "\test.html" ShellExecute 0, "open", file, vbNullString, vbNullString, SW_SHOWNORMAL
Private Sub Workbook_Open()
Load UserForm
UserForm.Show vbModeless
Application.Visible = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Me.Hide
Unload Me
Application.Quit
End Sub
Private Sub Workbook_Open()
Dim bookName as String
Load UserForm1
UserForm1.Show vbModeless
On Error Resume Next
bookName = ActiveWorkbook.Name
If bookName = "" Then Application.Visible = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Dim bookName As String
Me.Hide
Unload Me
On Error Resume Next
bookName = ActiveWorkbook.Name
If bookName = "" Then
Application.Quit
Else
ThisWorkbook.Close
End If
End Sub
ActiveWindow.Visible = False
Windows("filename.xls").Visible = True
Public Function csv(ParamArray args() As Variant)
Dim argcsv As String
For Each arg In args
If argcsv <> "" Then
argcsv = argcsv & ","
End If
If IsNumeric(arg) = False Then
argcsv = argcsv & """" & arg & """"
Else
argcsv = argcsv & arg
End If
Next
csv = argcsv
End Function
Sub ChangeCurPath()
CreateObject("WScript.Shell").CurrentDirectory = ThisWorkbook.Path
End Sub
Private Function CreateDataBook(filename As String) As String
ChangeCurPath 'カレントパスを戻す（念のため）
Workbooks.Add "data_templete.xlt" 'データ出力用WorkBookをコピーして新規作成
ActiveWorkbook.SaveAs filename 'ファイル名設定して保存
CreateDataBook = ActiveWorkbook.Name 'データ出力用WorkBook名を返す
End Function
Application.OnTime TimeValue("12:34:56"), "ProcName"
Application.OnTime Now + TimeValue("00:05:00"), "ProcName"
Me.Repaint
DoEvents
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Declare Function DrawMenuBar Lib "user32" _
(ByVal hWnd As Long) As Long
Public Const GWL_STYLE = (-16) 'ウィンドウスタイルを取得
Public Const WS_MINIMIZEBOX = &H20000 '最小化ボタン
Public Const WS_MAXIMIZEBOX = &H10000 '最大化ボタン
Dim fRet As Long
Dim hWnd As Long
Dim fStyle As Long
Load UserForm1
UserForm1.Show vbModeless 'ユーザーフォーム表示
hWnd = FindWindow("ThunderDFrame", UserForm1.Caption) 'ハンドルを取得
fStyle = GetWindowLong(hWnd, GWL_STYLE) 'ウィンドウ情報を取得
fStyle = fStyle Or WS_MINIMIZEBOX '最小化ボタン追加
fRet = SetWindowLong(hWnd, GWL_STYLE, fStyle) '追加したボタンを設定
fRet = DrawMenuBar(hWnd) 'メニューバーを再描画
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Dim hWnd1 As Long, hWnd2 As Long, hWnd3 As Long
Private Sub UserForm_Initialize()
'ユーザーフォームのハンドルを取得する（注)第二引数はユーザーフォームのCaption
hWnd1 = FindWindow("ThunderDFrame", UserForm1.Caption)
hWnd2 = FindWindow("ThunderDFrame", UserForm2.Caption)
hWnd3 = FindWindow("ThunderDFrame", UserForm3.Caption)
End Sub
Private Sub CommandButton1_Click()
SetForegroundWindow hWnd1
End Sub
Private Sub CommandButton2_Click()
SetForegroundWindow hWnd2
End Sub
Private Sub CommandButton3_Click()
SetForegroundWindow hWnd3
End Sub
for i=0 to 9
Me.Controls("Btn" & i).caption = i
Next i
Private WithEvents Btn As MSForms.CommandButton Private Index As Integer Public Sub NewClass( ByVal c As MSForms.CommandButton, ByVal i As Integer) Set Btn = c Index = i End Sub Private Sub Btn_Click() UserForm1.TextBox1.Text = Index End Sub
Private NumBtn(0 To 9) As New BtnClass
Private Sub UserForm_Initialize()
Dim i As Integer
For i=0 To 9
NumBtn(i).NewClass Controls("Btn" & i), i
Next
End Sub
メモしただけで未確認なので、後で確認してみよう。。
Function SendCmd(ByVal port As Long, ByVal cmd As String) As String
ec.COMn = port ' ポート設定
ec.Setting = "9600,n,8,1" ' 通信条件設定
ec.HandShaking = ec.HANDSHAKEs.No ' ハンドシェークなし．
ec.Delimiter = ec.DELIMs.CrLf ' デリミタ設定
ec.AsciiLine = cmd ' コマンド実行
SendCmd = ec.AsciiLine
ec.COMn = -1 ' ポートを閉じる
End Function
Function SendCmd2(ByVal port As Long, ByVal cmd As String) As String
On Error GoTo ErrHandle
ec.Xerror = 1
ec.COMn = port ' ポート設定
ec.Setting = "9600,n,8,1" ' 通信条件設定
ec.HandShaking = ec.HANDSHAKEs.No ' ハンドシェークなし．
ec.Delimiter = ec.DELIMs.CrLf ' デリミタ設定
ec.AsciiLine = cmd ' コマンド実行
SendCmd2 = ec.AsciiLine
ec.COMn = -1 ' ポートを閉じる
Exit Function
ErrHandle:
MsgBox "Com" & port & " が使用できません。" & vbCrLf & "COMポート番号、或は接続を確認して下さい。"
End Function
ec.InBuffer = 20& * 1024& ' receive buffer
ec.AsciiLineTimeOut = 1000 ' timeout 1sec
Public Function SendCmdB(ByVal port As Long, rate As Variant, ByVal cmd As String) As String
Dim StartTime As Date ' 処理開始時刻
Dim bindata() As Byte ' データ列
ec.COMn = port ' ポート設定
ec.Setting = rate & ",n,8,1" ' 通信条件設定
ec.HandShaking = ec.HANDSHAKEs.No ' ハンドシェークなし．
ec.Delimiter = ec.DELIMs.CR ' デリミタ設定
ec.InBufferClear ' 受信バッファクリア
ec.AsciiLine = cmd ' コマンド実行
StartTime = Now ' 開始時刻の記憶
ec.BinaryBytes = 4 ' 受信バッファから4バイトを取得
Do
If Now > StartTime + TimeSerial(0, 0, 1) Then Exit Function ' タイムアウト 1sec
DoEvents
If ec.InBuffer >= 4 Then ' 4バイト以上受信
DoEvents
bindata() = ec.Binary ' 取得
Exit Do
End If
Loop
SendCmdB = Str(bindata(0) * 256& + bindata(1)) & "," & Str(bindata(2) * 256& + bindata(3))
ec.COMn = -1 ' ポートを閉じる
End Function
Private Sub BtnRun_Click()
Dim bin() As Byte
Dim data As String
Dim result As Variant
If RunFlag Then ' Stopボタン処理
RunFlag = False
BtnRun.Caption = "Start"
Else ' Startボタン処理
ec.COMn = 10 ' COMポート番号
ec.Setting = "9600,n,8,1" ' 通信条件設定
ec.HandShaking = ec.HANDSHAKEs.No ' ハンドシェークなし．
ec.BinaryBytes = 1 ' 取得バイト数を設定
RunFlag = True
BtnRun.Caption = "Stop"
Do While RunFlag ' Stopされるまで繰返す
data = ""
Do While RunFlag
DoEvents ' これが無いと他の処理が出来ない
If ec.InBuffer > 0 Then
bin() = ec.Binary
If bin(0) = &HD Then ' CRが来るまで続けて読む
Exit Do
Else
data = data & Chr(bin(0))
End If
End If
Loop
result = Split(data, " ") ' 空白区切りで配列に変換
show_result result ' データを処理
Loop
ec.COMn = -1 ' ポートを閉じる
End If
End Sub
Function GetUseComNo() As String
Dim Serial As Object
Dim SerialSet As Object
Dim objWMIService As Object
Dim strComputer As String
Dim intCnt As Integer '要素数
Dim strComName As String '取得したデバイス名
strComputer = "."
'WMIを呼び出す
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
'PnPで登録されているもの（デバイスマネージャで見えるもの）から
'シリアルポートのクラスでかつ名前に「(COMxx)」と付いているものを抽出
Set SerialSet = objWMIService.ExecQuery("Select * from Win32_PNPEntity Where " & _
"(ClassGuid = '{4D36E978-E325-11CE-BFC1-08002BE10318}') and " & _
"(Name like '%(COM%)')")
'全ポートの数(取得できた項目数)
intCnt = SerialSet.Count
'情報の取得
strComName = ""
For Each Serial In SerialSet
'デバイス名を取得 「"通信ポート (COM1)"」
If strComName <> "" Then
strComName = strComName & vbCrLf
End If
strComName = strComName & Serial.Name
Next
'戻り値セット
GetUseComNo = strComName
End Function
'プロパティ名の定義
Private m_name As String
'書込み時の定義
Public Property Let name(ByVal data)
m_name = data
End Property
'読出し時の定義
Public Property Get name() As String
name = m_name
End Property
Public Sub Clear()
m_name = ""
End Sub
Dim Name1 As TestClass
Dim Name2 As TestClass
Set Name1 = New TestClass
Set Name2 = New TestClass
Name1.name = "ABC"
Name2.name = "DEF"
Print Name1.name
Print Name2.name
Call Name1.Clear
Call Name2.Clear
Function replace(data As Variant, fromstr As Variant, tostr As Variant) As Variant
replace = Application.Substitute(data, fromstr, tostr)
End Function
Function split(line As Variant, sepa As Variant) As Variant
Dim list() As Variant
Dim spos, epos As Integer
Dim n As Integer
n = 0
spos = 1
While (spos <= Len(line))
epos = InStr(spos, line, sepa)
If (epos = 0) Then epos = Len(line) + 1
spos = epos + 1
n = n + 1
Wend
spos = 1
ReDim list(n)
n = 0
While (spos <= Len(line))
epos = InStr(spos, line, sepa)
If (epos = 0) Then epos = Len(line) + 1
list(n) = (Mid(line, spos, epos - spos))
spos = epos + 1
n = n + 1
Wend
split = list
End Function
実行時エラー'9': インデックスが有効範囲にありません