Top > OOoMacrobbs

*OOoBaic マクロ掲示板 [#p2864da0]

マクロ投稿用。

#contents

#article
**シートのコピー [#ff6c9742]
>reverse (2012-02-27 (月) 17:51:12)~
~
OpenOffice3.3を使用しています。以下の様なコードで別ファイルにシートをコピーした場合に、貼り付けてある図形(Bitmap)がコピーされません。マクロではなく、通常の操作ではコピーされるのですが・・・。関係ないコードを削除した部分を以下に記載させて頂きます。どなたか分かる方がおられましたら、回答よろしくお願いします。~
~
  document = StarDesktop.loadComponentFromURL("private:factory/scalc", "_blank", 0, Array() )
  dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
		
  oNSheets = document.getSheets()
  oNSheet = oNSheets.getByIndex(0)
 
  oNSheet.link("C:\Users\ura\Desktop/管理表.ods",  sheet_nm,  "",  "", com.sun.star.sheet.SheetLinkMode.NORMAL )
 	
  oNSheet.setLinkMode(com.sun.star.sheet.SheetLinkMode.NONE )
~
  Fname = ConvertToUrl("C:\Users\ura\Desktop/" &  st_nm & ".ods")
  document.storeAsURL(Fname,Dummy())

//
- すいません。場所を間違えました -- reverse &new{2012-02-27 (月) 17:57:40};

#comment

**Xorshift [#xdeabbfc]
>もりお (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

//

#comment

**Base64エンコード・デコード/Base32エンコード・デコード [#m9bd64ab]
>もりお (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

//

#comment
**ビットシフト [#mb86cc44]
>もりお (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

//

#comment

**動的配列 [#vcef7d16]
>もりお (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

//

#comment

**マージソート [#d6fa2453]
>もりお (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
**株価取得マクロ [#y1b19e39]
>new_OOo3 (2009-04-23 (木) 11:42:07)~
~
下記URLにて、会社毎の株価を簡単に取得できるマクロを組みました。~
皆様、一度試して、コメントを頂けます様お願いします。~
~
URL : http://openoffice3.web.fc2.com/~

//

#comment

**文字に色をつけるマクロ [#nb8ba216]
>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~

//

#comment

**マルチバイト文字列のエスケープ [#vd550883]
>[[はにゃ?]] (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
 
 ' & &amp;, < &lt;, > &gt; " &quot; ' &apos;
 Function EscapeString( sString ) As String
   sTxt = sString
   sSearch = Array("&","<",">","'","""")
   sReplace = Array("&amp;","&lt;","&gt;","&apos;","&quot;")
   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

//

#comment
**Writer ハイパーリンクの削除 [#f1b16f32]
>[[はにゃ?]] (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
--http://qa.openoffice.org/issues/show_bug.cgi?id=7311

また、Ctrl + Shift + Space で書式をデフォルトに戻すとハイパーリンクが消えるそうです。
-- [[はにゃ?]] &new{2007-11-12 (月) 01:09:23};

#comment
**配列クイックソート 文字列用 [#h0020c1b]
>[[はにゃ?]] (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

//

#comment
**配列クイックソート 数値用 [#j5d7dd00]
>[[はにゃ?]] (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

//

#comment
**コマンド実行用 [#ja775d2e]
>[[はにゃ?]] (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

//

#comment
**パス置換用 [#bfa8e9b8]
>[[はにゃ?]] (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

//

#comment

**パス設定取得用 [#q3372a02]
>[[はにゃ?]] (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

//

#comment

**Point struct 用 [#s1d43abc]
>[[はにゃ?]] (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

//

#comment

**Size struct 用 [#o465b9b5]
>[[はにゃ?]] (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

//

#comment

**長いテキスト表示用ダイアログ コピーボタン付き [#qaf4e2d3]
>[[はにゃ?]] (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

//

#comment
**長いテキスト表示用ダイアログ [#ne7a0a21]
>[[はにゃ?]] (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

//

#comment
**UnoControl 作成 2 [#wd287480]
>[[はにゃ?]] (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

//

#comment

**UnoControl 作成 [#o73a887d]
>[[はにゃ?]] (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

//

#comment

**Rectangle struct 用 [#k42689a7]
>[[はにゃ?]] (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

//

#comment

**配列の最後に要素を追加 [#m0ace82d]
>[[はにゃ?]] (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

//

#comment

**ファイルを開くダイアログを開いて、選択されたファイル URL を取得 [#d47c7bda]
>[[はにゃ?]] (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

//

#comment

Reload   New Lower page making Edit Freeze Diff Upload Copy Rename   Front page List of pages Search Recent changes Backup   Help   RSS of recent changes