OOoBaic マクロ掲示板 
マクロ投稿用。
Xorshift
もりお (2011-10-22 (Sat) 05:48:44)
ビットシフトを使っています。
Sub Main ()
x = CreateXorshift ()
MsgBox(XorshiftNext(x, 0, 100))
End Sub
Type Xorshift
X&
Y&
Z&
W&
End Type
Function CreateXorshift ()
ins = New Xorshift
ins.X = 123456789
ins.Y = 362436069
ins.Z = 521288629
ins.W = 88675123
CreateXorshift = ins
End Function
Function XorshiftGenerate(ins)
t& = ins.X Xor ShiftLeft(ins.X, 11)
ins.X = ins.Y
ins.Y = ins.Z
ins.Z = ins.W
ins.W = (ins.W Xor ShiftRight(ins.W, 19)) Xor (t Xor ShiftRight(t, 8))
XorshiftGenerate = ShiftRight(ins.W, 0)
End Function
Function XorshiftNext&(ins, min, max)
m# = 2 ^ 32
dif# = max - min
lim# = m - Mod2(m, dif)
n# = 0
Do
n = XorshiftGenerate(ins)
Loop While n >= lim
XorshiftNext = Mod2(n, dif) + min
End Function
Function Mod2(a, b)
Mod2 = a - (Fix(a / b) * b)
End Function
Base64エンコード・デコード／Base32エンコード・デコード
もりお (2011-10-22 (Sat) 05:43:11)
動的配列を使っています。
2011/12/04 15:27:06.99
BaseAddPad関数で呼んでいるCreateString関数を記載するのを忘れていましたので補いました。
Const Base64MapChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Const Base32MapChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"
Sub Main
a = Base64Encode("foobar")
MsgBox(a)
a = Base64Decode(a)
MsgBox(a)
a = Base32Encode(a)
MsgBox(a)
a = Base32Decode(a)
MsgBox(a)
End Sub
Function CreateString(c, num)
s = ""
p = c
n = num
Do While (n > 0)
If ((n And 1) = 1) Then
s = s & p
End If
p = p & p
n = n \ 2
Loop
CreateString = s
End Function
Function StringToBytes(s)
list = CreateList()
For i = 1 To Len(s)
b = Asc(Mid (s, i, 1))
ListAdd(list, b \ &H100)
ListAdd(list, b And &HFF)
Next
StringToBytes = ListToArray(list)
End Function
Function BytesToString(bytes)
list = CreateList()
For i = 0 To UBound(bytes) - 1 Step 2
ListAdd(list, Chr((bytes(i) * &H100) + bytes(i + 1)))
Next
BytesToString = Join(ListToArray(list), "")
End Function
Function Base64Encode(str)
Base64Encode = BaseEncode(str, 8, 6, 4, Base64MapChars)
End Function
Function Base64Decode(str)
Base64Decode = BaseDecode(str, 6, 8, Base64MapChars)
End Function
Function Base32Encode(str)
Base32Encode = BaseEncode(str, 8, 5, 8, Base32MapChars)
End Function
Function Base32Decode(str)
Base32Decode = BaseDecode(str, 5, 8, Base32MapChars)
End Function
Function BaseEncode(str, srcBit, dstBit, padLen, mapChars)
BaseEncode = BaseAddPad(BaseBytesToString(BaseBytesConvert(srcBit, dstBit, StringToBytes(str)), mapChars), padLen)
End Function
Function BaseDecode(str, srcBit, dstBit, mapChars)
BaseDecode = BytesToString(BaseBytesConvert(srcBit, dstBit, BaseStringToBytes(BaseDelPad(str), mapChars)))
End Function
Function BaseAddPad(str, num)
l = Len(str) Mod num
If l > 0 Then
BaseAddPad = str & CreateString("=", num - l)
Else
BaseAddPad = str
End If
End Function
Function BaseDelPad(str)
BaseDelPad = Replace(str, "=", "")
End Function
Function BaseBytesToString (bytes, mapChars)
Dim map(Len(mapChars) - 1)
For i = 0 To Len(mapChars) - 1
map(i) = Mid(mapChars, i + 1, 1)
Next
Dim a(UBound(bytes))
For i = 0 To UBound(bytes)
a(i) = map(bytes(i))
Next
BaseBytesToString = Join(a, "")
End Function
Function BaseStringToBytes (str, mapChars)
Dim map(126)
For i = 0 To UBound(map)
map(i) = -1
Next
For i = 0 To Len(mapChars) - 1
map(Asc(Mid(mapChars, i + 1, 1))) = i
Next
Dim a(Len(str) - 1)
For i = 0 To Len(str) - 1
a(i) = map(Asc(Mid(str, i + 1, 1)))
Next
BaseStringToBytes = a
End Function
Function BaseBytesConvert(srcBit, dstBit, bytes)
list = CreateList()
mask = (2 ^ dstBit) - 1
buf = 0
move = 0
For i = 0 To UBound(bytes)
buf = ((buf And ((2 ^ move) - 1)) * (2 ^ srcBit)) + bytes(i)
move = move + srcBit
Do While move >= dstBit
move = move - dstBit
ListAdd(list, (buf \ (2 ^ move)) And mask)
Loop
Next
If srcBit > dstBit Then
If move > 0 Then
ListAdd(list, (buf * (2 ^ (dstBit - move))) And mask)
End If
End If
BaseBytesConvert = ListToArray(list)
End Function
ビットシフト
もりお (2011-10-22 (Sat) 05:35:57)
Function ShiftRight#(value&, number%)
n% = number Mod 32
If n = 0 Then
If (value And &H80000000) <> 0 Then
ShiftRight = (2 ^ 32) + value
Else
ShiftRight = value
End If
Exit Function
End If
v& = 0
If n < 31 Then
v = (value And (Not &H80000000)) \ (2 ^ n)
End If
If (value And &H80000000) <> 0 Then
v = v Or (2 ^ (31 - n))
End If
ShiftRight = v
End Function
Function ShiftLeft&(value&, number%)
n% = number Mod 32
If n = 0 Then
ShiftLeft = value
Exit Function
End If
mask& = (2 ^ (31 - n)) - 1
v& = (value And mask) * (2 ^ n)
If (value And (2 ^ (31 - n))) <> 0 Then
v = v Or &H80000000
End If
ShiftLeft = v
End Function
動的配列
もりお (2011-10-22 (Sat) 05:23:42)
Sub Main ()
list = CreateList()
For i = 1 To 10
ListAdd(list, i)
Next
For i = 1 To 5
ListDel(list, 0)
Next
MsgBox(Join(ListToArray(list), " "))
End Sub
Type ArrayList
Data
Count
Size
End Type
Function CreateList(Optional size)
If IsMissing(size) Then size = 10
ins = New ArrayList
ins.Count = 0
ins.Size = size
Dim data(size - 1)
ins.Data = data
CreateList = ins
End Function
Sub ListAdd(ins, elm)
If ins.Size <= ins.Count Then
ins.Size = ins.Size * 2
data = ins.Data
ReDim Preserve data(ins.Size - 1)
ins.Data = data
End If
ins.Data(ins.Count) = elm
ins.Count = ins.Count + 1
End Sub
Sub ListDel(ins, idx)
If idx >= ins.Count Then Exit Sub
For i = idx To ins.Count - 2
ins.Data(i) = ins.Data(i + 1)
Next
ins.Data(ins.Count - 1) = Empty
ins.Count = ins.Count - 1
If ins.Count < (ins.Size \ 2) Then
ins.Size = ins.Size \ 2
data = ins.Data
ReDim Preserve data(ins.Size - 1)
ins.Data = data
End If
End Sub
Function ListToArray(ins)
If ins.Count = 0 Then
ListToArray = Array()
Exit Function
End If
data = ins.Data
ReDim Preserve data(ins.Count - 1)
ListToArray = data
End Function
マージソート
もりお (2011-10-18 (Tue) 07:16:31)
2011/11/03
関数を分割して、挿入ソートを行うようにしました。
Sub Main()
a = Array(3, 2, 1)
Mergesort(a, "Number")
MsgBox(Join(a, ","))
End Sub
Function Comp(a, b, compType)
If (compType = "Number") Then
Comp = NumberComp(a, b)
End If
End Function
Function NumberComp(a, b)
If (a < b) Then
NumberComp = -1
ElseIf (a > b) Then
NumberComp = 1
Else
NumberComp = 0
End If
End Function
Sub Mergesort(a, compType)
Dim i, u, j, i2, r
i = 6
u = UBound(a)
For j = 0 To u - 1 Step i
r = j + i - 1
If (r > u) Then
r = u
End If
Insertionsort(a, j, r, compType)
Next
Dim b(u)
Do While (i <= u)
i2 = i + i
For j = 0 To u - i Step i2
r = j + i2 - 1
If (r > u) Then
r = u
End If
Merge(a, b, j, j + i - 1, j + i, r, compType)
Next
i = i2
Loop
End Sub
Sub Insertionsort(a, l, r, compType)
Dim i, j, e
For i = l + 1 To r
j = i
e = a(j)
For j = i To l + 1 Step -1
If (Comp(a(j - 1), e, compType) <= 0) Then
Exit For
End If
a(j) = a(j - 1)
Next
a(j) = e
Next
End Sub
Sub Merge(a, b, ll, lr, rl, rr, compType)
If (Comp(a(lr), a(rl), compType) <= 0) Then
Exit Sub
End If
Dim l, r, n
For l = ll To lr
b(l) = a(l)
Next
l = ll
r = rl
For n = ll To rr
If (l > lr) Then
Exit Sub
End If
If (r > rr) Then
Exit For
End If
If (Comp(a(r), b(l), compType) < 0) Then
a(n) = a(r)
r = r + 1
Else
a(n) = b(l)
l = l + 1
End If
Next
For l = l To lr
a(n) = b(l)
n = n + 1
Next
End Sub
株価取得マクロ
new_OOo3 (2009-04-23 (木) 11:42:07)
下記URLにて、会社毎の株価を簡単に取得できるマクロを組みました。
皆様、一度試して、コメントを頂けます様お願いします。
URL ： http://openoffice3.web.fc2.com/
文字に色をつけるマクロ
new_OOo3 (2009-03-25 (水) 09:52:29)
sub Main
dim document as object
dim dispatcher as object
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = "ToPoint"
args1(0).Value = "$A$1"
dispatcher.executeDispatch(document, ".uno:GoToCell", "", 0, args1())
dim args2(0) as new com.sun.star.beans.PropertyValue
args2(0).Name = "Color"
args2(0).Value = RGB(0,255,0) ’←赤：(255,0,0) 青：(0,0,255)
dispatcher.executeDispatch(document, ".uno:Color", "", 0, args2())
end sub
マルチバイト文字列のエスケープ
はにゃ?? (2007-11-16 (金) 21:49:28)
設定ファイルにマルチバイト文字をエスケープして入力したいときの文字列変換用。
Sub LabelConvert
sLabel = "マルチバイト文字列"
sLabel = EscapeString(sLabel)
For i = 1 To Len(sLabel)
sChar = Mid(sLabel,i,1)
If Asc(sChar) < 127 Then
sConverted = sConverted & sChar
Else
sConverted = sConverted & "&#x" & Hex(Asc(sChar)) & ";"
End If
Next i
InputBox ,,sConverted
End Sub
' & &, < <, > > " " ' '
Function EscapeString( sString ) As String
sTxt = sString
sSearch = Array("&","<",">","'","""")
sReplace = Array("&","<",">","'",""")
For i = 0 To 4
sSearchString = sSearch(i)
nPos = InStr(sTxt,sSearchString)
nSearchLen = Len(sSearchString)
sReplaceString = sReplace(i)
nReplaceLen = Len(sReplaceString)
While nPos <> 0
sTxt = Mid(sTxt,1,nPos -1) & sReplaceString & Mid(sTxt,nPos +nSearchLen)
nPos = InStr(nPos +nReplaceLen,sTxt,sSearchString)
WEnd
Next i
EscapeString = sTxt
End Function
Writer ハイパーリンクの削除
はにゃ?? (2007-11-08 (木) 18:48:57)
Writer でリンクを設定したあとで文章をつなげて書くとずっとリンクが付いてくる。リンクの部分削除がうまくできないのでマクロで行う。
Sub removeHyperLink
oDoc = ThisComponent
oSelection = oDoc.getCurrentSelection()
If oSelection.supportsService("com.sun.star.text.TextRanges") Then
oRange = oSelection.getByIndex(0)
With oRange
.HyperLinkURL = ""
.HyperLinkTarget = ""
.HyperLinkName = ""
End With
End If
End Sub
- hyperlink can not be removed by hyperlink dialogue
また、Ctrl + Shift + Space で書式をデフォルトに戻すとハイパーリンクが消えるそうです。
配列クイックソート 文字列用
はにゃ?? (2007-09-21 (金) 01:57:10)
Function strqsort( a, i, j )
If NOT ( i = j ) AND ( i >= 0 AND j >= 0 ) Then
p = strpivot( a, i, j )
If ( p <> -1 ) Then
k = strpartition( a, i, j, a(p) )
strqsort( a, i, k -1 )
strqsort( a, k, j )
End If
End If
End Function
Function strpartition( a, i, j, x )
l = i
r = j
y = x
Do While ( l <= r )
Do While ( l <= j ) AND ( StrComp( a(l), y ) = -1 )'a(l) < y )
l = l + 1
Loop
Do While ( r >= i ) AND ( StrComp( a(r), y ) >= 0 )'a(r) >= y )
r = r - 1
Loop
If ( l > r ) Then Exit Do
t = a(l)
a(l) = a(r)
a(r) = t
l = l + 1
r = r - 1
Loop
strpartition = l
End Function
Function strpivot( a, i, j )
k = i + 1
Do while ( k <= j ) AND ( StrComp( a(i), a(k) ) = 0 )'a(i) = a(k) )
k = k + 1
If k > j Then Exit Do
Loop
If ( k > j ) Then
k = -1
Else
If ( StrComp( a(i), a(k) ) >= 0 ) Then'a(i) >= a(k) ) Then
k = i
End If
End If
strpivot = k
End Function
配列クイックソート 数値用
はにゃ?? (2007-09-21 (金) 01:56:07)
Function qsort( a, i, j )
If NOT ( i = j ) Then
p = pivot( a, i, j )
If ( p <> -1 ) Then
k = partition( a, i, j, a(p) )
qsort( a, i, k -1 )
qsort( a, k, j )
End If
End If
End Function
Function partition( a, i, j, x )
l = i
r = j
y = x
Do While ( l <= r )
Do While ( l <= j ) AND ( a(l) < y )
l = l + 1
Loop
Do While ( r >= i ) AND ( a(r) >= y )
r = r - 1
Loop
If ( l > r ) Then Exit Do
t = a(l)
a(l) = a(r)
a(r) = t
l = l + 1
r = r - 1
Loop
partition = l
End Function
Function pivot( a, i, j )
k = i + 1
Do while ( k <= j ) AND ( a(i) = a(k) )
k = k + 1
If k > j Then Exit Do
Loop
If ( k > j ) Then
k = -1
Else
If ( a(i) >= a(k) ) Then
k = i
End If
End If
pivot = k
End Function
コマンド実行用
はにゃ?? (2007-06-13 (水) 21:00:55)
sub Dispatch( sCommand As String, oLocFrame As Object)
dim dispatcher as object
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
dispatcher.executeDispatch(oLocFrame, sCommand, "", 0, Array())
end sub
パス置換用
はにゃ?? (2006-11-14 (火) 03:01:32)
Function GetSubstitutedPath( sPath As String )
GetSubstitutedPath() = CreateUnoService( _
"com.sun.star.util.PathSubstitution").substituteVariables( sPath,true )
End Function
sPath = GetSubstitutedPath( "$(inst)/program" )
など結構利用できる。
http://api.openoffice.org/docs/common/ref/com/sun/star/util/PathSubstitution.html
パス設定取得用
はにゃ?? (2006-11-14 (火) 02:40:56)
Function GetPath( sPathName As String ) As String
GetPath() = CreateUnoService( _
"com.sun.star.util.PathSettings").getPropertyValue( sPathName )
End Function
取得したいパス名は下記参照
http://api.openoffice.org/docs/common/ref/com/sun/star/util/PathSettings.html
Point struct 用
はにゃ?? (2006-11-12 (日) 22:17:46)
Function MakePoint( nX As Long, nY As Long ) As com.sun.star.awt.Point
Dim aPoint As New com.sun.star.awt.Point
aPoint.X = nX
aPoint.Y = nY
MakePoint() = aPoint
End Function
Size struct 用
はにゃ?? (2006-11-12 (日) 22:16:43)
Function MakeSize( nWidth As Long, nHeight As Long ) As com.sun.star.awt.Size
Dim aSize As New com.sun.star.awt.Size
aSize.Width = nWidth
aSize.Height = nHeight
MakeSize() = aSize
End Function
長いテキスト表示用ダイアログ コピーボタン付き
はにゃ?? (2006-11-12 (日) 02:12:34)
コピーボタンを付けた長いテキスト表示用ダイアログ
OpenOffice.org を終了すると貼り付けできなくなるはず
Global sTxtCString As String
Sub Txtc( Optional sShowText As String )
Dim oDialogModel As Object, oDialog As Object
Dim oManager As Object
Dim oTextModel As Object, oClose As Object, oCopy As Object
Dim oButtonListener As Object
oManager = GetProcessServiceManager()
oDialogModel = oManager.createInstance("com.sun.star.awt.UnoControlDialogModel")
With oDialogModel
.setPropertyValue("Name","Dialog")
.setPropertyValue( "PositionX", 100 )
.setPropertyValue( "PositionY", 60 )
.setPropertyValue( "Height", 175 )
.setPropertyValue( "Width", 157 )
.setPropertyValue( "Title", "Menu" )
End With
oTextModel = oDialogModel.createInstance("com.sun.star.awt.UnoControlEditModel")
With oTextModel
.setPropertyValue( "Name", "Contents" )
.setPropertyValue( "PositionX", 4 )
.setPropertyValue( "PositionY", 21 )
.setPropertyValue( "Width", 149 )
.setPropertyValue( "Height", 150 )
.setPropertyValue("MultiLine",true)
.setPropertyValue("VScroll",true)
.setPropertyValue("HardLineBreaks",false)
.setPropertyValue("Border",2)
End With
oClose = oDialogModel.createInstance("com.sun.star.awt.UnoControlButtonModel")
With oClose
.setPropertyValue( "Name", "Close" )
.setPropertyValue( "PositionX", 123 )
.setPropertyValue( "PositionY", 3 )
.setPropertyValue( "Width", 30 )
.setPropertyValue( "Height", 14 )
.setPropertyValue("Label","Close")
.setPropertyValue("PushButtonType",2)
End With
oButtonListener = CreateUnoListener( "ButtonAction_", "com.sun.star.awt.XActionListener" )
oCopy = oDialogModel.createInstance("com.sun.star.awt.UnoControlButtonModel")
With oCopy
.setPropertyValue( "Name", "Copy" )
.setPropertyValue( "PositionX", 88 )
.setPropertyValue( "PositionY", 3 )
.setPropertyValue( "Width", 30 )
.setPropertyValue( "Height", 14 )
.setPropertyValue("Label","~Copy")
End With
With oDialogModel
.insertByName("Contents",oTextModel)
.insertByName("Close",oClose)
.insertByName("Copy",oCopy)
End With
oDialog = oManager.createInstance("com.sun.star.awt.UnoControlDialog")
oDialog.setModel(oDialogModel)
With oDialog.getControl("Copy")
.ActionCommand = "COPY"
.addActionListener(oButtonListener)
End With
oDialogModel.Contents.Text = sShowText
oDialog.setTitle( "TxtDialog" )
oDialog.setVisible(true)
oDialog.execute()
oDialog.dispose()
End Sub
Sub ButtonAction_actionPerformed( e )
On Error Goto ErrorHandler
c = e.ActionCommand
Select Case c
Case "COPY"
CopyToClipboard()
End Select
Exit Sub
ErrorHandler:
End Sub
Sub ButtonAction_disposing()
End Sub
Sub CopyToClipBoard()
Dim null As Object
oClip = CreateUnoService("com.sun.star.datatransfer.clipboard.SystemClipboard")
oTR = createUnoListener("Tr_", "com.sun.star.datatransfer.XTransferable")
oClip.setContents(oTR,null)
sTxtCString = oDialogModel.Contents.Text
End Sub
Function Tr_getTransferData(aFlavor as com.sun.star.datatransfer.DataFlavor)
If (aFlavor.MimeType = "text/plain;charset=utf-16") Then
Tr_getTransferData() = sTxtCString
End If
End Function
Function Tr_getTransferDataFlavors()
Dim aFlavor As new com.sun.star.datatransfer.DataFlavor
aFlavor.MimeType = "text/plain;charset=utf-16"
aFlavor.HumanPresentableName = "Unicode-Text"
Tr_getTransferDataFlavors() = array(aFlavor)
End Function
Function Tr_isDataFlavorSupported(aFlavor as com.sun.star.datatransfer.DataFlavor) as Boolean
If aFlavor.MimeType = "text/plain;charset=utf-16" Then
Tr_isDataFlavorSupported = true
Else
Tr_isDataFlavorSupported = false
End If
End Function
長いテキスト表示用ダイアログ
はにゃ?? (2006-11-12 (日) 00:25:27)
改行を含む長いテキストを表示するときに
Sub Txt( Optional sShowText As String )
Dim oDialogModel As Object, oDialog As Object
Dim oManager As Object
Dim oTextModel As Object, oClose As Object
oManager = GetProcessServiceManager()
oDialogModel = oManager.createInstance("com.sun.star.awt.UnoControlDialogModel")
With oDialogModel
.setPropertyValue("Name","Dialog")
.setPropertyValue( "PositionX", 100 )
.setPropertyValue( "PositionY", 60 )
.setPropertyValue( "Height", 175 )
.setPropertyValue( "Width", 157 )
.setPropertyValue( "Title", "Menu" )
End With
oTextModel = oDialogModel.createInstance("com.sun.star.awt.UnoControlEditModel"
With oTextModel
.setPropertyValue( "Name", "Contents" )
.setPropertyValue( "PositionX", 4 )
.setPropertyValue( "PositionY", 21 )
.setPropertyValue( "Width", 149 )
.setPropertyValue( "Height", 150 )
.setPropertyValue("MultiLine",true)
.setPropertyValue("VScroll",true)
.setPropertyValue("HardLineBreaks",false)
.setPropertyValue("Border",2)
End With
oClose = oDialogModel.createInstance("com.sun.star.awt.UnoControlButtonModel")
With oClose
.setPropertyValue( "Name", "Close" )
.setPropertyValue( "PositionX", 123 )
.setPropertyValue( "PositionY", 3 )
.setPropertyValue( "Width", 30 )
.setPropertyValue( "Height", 14 )
.setPropertyValue("Label","Close")
.setPropertyValue("PushButtonType",2)
End With
With oDialogModel
.insertByName("Contents",oTextModel)
.insertByName("Close",oClose)
End With
oDialog = oManager.createInstance("com.sun.star.awt.UnoControlDialog")
oDialog.setModel(oDialogModel)
oDialogModel.Contents.Text = sShowText
oDialog.setTitle( "TxtDialog" )
oDialog.setVisible(true)
oDialog.execute()
oDialog.dispose()
End Sub
UnoControl 作成 ２
はにゃ?? (2006-11-11 (土) 23:48:44)
ランタイムでコントロールを作成するときに、モデルオブジェクトの
プロパティを設定する必要があるとき用
Function CreateCtrWithProp( CtrType, oToolkit, oWindow, aPosSize, aPropNames, aPropValues )
Dim oCtr As Object, oCtrModel As Object
oCtr = createUnoService("com.sun.star.awt.UnoControl" & CtrType )
oCtrModel = createUnoService("com.sun.star.awt.UnoControl" & CtrType & "Model" )
oCtrModel.setPropertyValues( aPropNames, aPropValues )
With oCtr
.setModel(oCtrModel)
.createPeer( oToolkit, oWindow )
.setPosSize( aPosSize.X, aPosSize.Y, aPosSize.Width, aPosSize.Height, _
com.sun.star.awt.PosSize.POSSIZE )
End With
CreateCtrWithProp() = oCtr 'model can be got from returned value
End Function
UnoControl 作成
はにゃ?? (2006-11-11 (土) 23:47:43)
ランタイムでコントロールを作成するときに
Function CreateCtr( CtrType, oToolkit, oWindow, aPosSize )
Dim oCtr As Object, oCtrModel As Object
oCtr = createUnoService("com.sun.star.awt.UnoControl" & CtrType )
oCtrModel = createUnoService("com.sun.star.awt.UnoControl" & CtrType & "Model" )
With oCtr
.setModel(oCtrModel)
.createPeer( oToolkit, oWindow )
.setPosSize( aPosSize.X, aPosSize.Y, aPosSize.Width, aPosSize.Height, _
com.sun.star.awt.PosSize.POSSIZE )
End With
CreateCtr() = oCtr 'model can be got from returned value
End Function
Rectangle struct 用
はにゃ?? (2006-11-11 (土) 23:46:18)
Function MakeRect( nX, nY, nWidth, nHeight ) As com.sun.star.awt.Rectangle
oRect = createUnoStruct("com.sun.star.awt.Rectangle")
With oRect
.X = nX
.Y = nY
.Width = nWidth
.Height = nHeight
End With
MakeRect() = oRect
End Function
配列の最後に要素を追加
はにゃ?? (2006-11-08 (水) 02:44:35)
Variant 型もしくは単一の型の配列でしか使えません。
Function array_push( sourceArray, Item )
nU = UBound(sourceArray)
ReDim Preserve sourceArray(nU+1)
sourceArray(nU+1) = Item
End Function
ファイルを開くダイアログを開いて、選択されたファイル URL を取得
はにゃ?? (2006-11-08 (水) 02:37:17)
用途に応じてフィルタを追加して使用してください。
Function FileSelection() As String
Dim oFilePicker As Object
Dim sFileURL As String
Dim sFiles As Variant
Dim nAccept As Integer
Dim nAny(0) As Long
nAny(0) = _
com.sun.star.ui.dialogs.TemplateDescription.FILEOPEN_SIMPLE
oFilePicker = _
createUnoService("com.sun.star.ui.dialogs.FilePicker")
With oFilePicker
.Initialize( nAny() )
.AppendFilter( "All Files (*.*)", "*.*" )
.setCurrentFilter ( "All Files (*.*)" )
End With
nAccept = oFilePicker.execute()
If nAccept = 1 Then ' changed = 1
sFiles = oFilePicker.getFiles()
sFileURL = sFiles(0)
FileSelection() = sFileURL
End If
End Function
