テキストばらし 

JavaScript for Adobe Illustrator 10 - CS ( Win / Mac )

■■テキストばらし■■
複数行のテキストを改行で別オブジェクトに分割しま

var itemsToSplit = new Array() ;	//各テキストを格納
var splitTexts = new Array() ;	//各分割テキストの配列を格納
var HorV ;
var txPos ;
var lineHeight ;

var aiVersion = version.slice(0,2);

var crCode = String.fromCharCode(13);		//改行コードを指定
var enterCode = String.fromCharCode( 3 ) ;

selectedObj = activeDocument.selection ;
if( selectedObj.length == 0 )
{
	alert("まず、改行で分割したいテキストを選択してください。  ( Select texts first. )");
}
else
{
	for( i=0; i<selectedObj.length; i++ )
	{
		if( aiVersion == "10" )
		{
			if( selectedObj[i] instanceof TextArtItem )
			itemsToSplit.push(selectedObj[i]) ;
		}
		else
		{
		if( selectedObj[i] instanceof TextFrame )
			// レガシーテキストへの対応
			if( selectedObj[i].converted == false )
			{
				selectedObj[i] = selectedObj[i].convertToNative() ;
				ct = selectedObj[i].textFrames[0] ;
				ct.move( selectedObj[i] , ElementPlacement.PLACEBEFORE ) ;
				itemsToSplit.push( ct ) ;
			}
			else { itemsToSplit.push(selectedObj[i]) }
			// レガシーテキストでない場合（ undefinedが返る ）
		}
	}
}
if( itemsToSplit.length == 0 )
{
	alert("まず、改行で分割したいテキストを選択してください。  ( Select texts first. )");
}
else
{
	for( i=0; i<itemsToSplit.length; i++ )
	{
		if( aiVersion == "10" )
		{
			lineHeight = itemsToSplit[i].textRange( 0 , 0 ).leading ;
			if( lineHeight == 0 )
				lineHeight = ( Math.round( itemsToSplit[i].textRange( 0 , 0 ).size*2.4 ) ) / 2 ;
				// バージョン10では行送りが自動のときに数値が文字サイズの120％から0.5ポイント単位で丸められる
			HorV = ( itemsToSplit[i].textPaths[0].orientation == TextOrientation.HORIZONTAL ) ;
		}
		else
		{
			lineHeight = itemsToSplit[i].textRange.characterAttributes.leading ;
			if( lineHeight == 0 )
				lineHeight = Math.round( itemsToSplit[i].textRange.characterAttributes.size*1.2 ) ;
			HorV = ( itemsToSplit[i].orientation == TextOrientation.HORIZONTAL ) ;
		}
		txPos = itemsToSplit[i].position ;
		//エンターキーの改行をリターンキーに置き換えてから分割
		txArray = itemsToSplit[i].contents.split( enterCode ).join( crCode ).split( crCode ) ;

		splitTexts[i] = new Array() ;
		for( j=0; j<txArray.length; j++ )
		{
			if( txArray[j] != "" )
			{
				splitTexts[i][j] = itemsToSplit[i].duplicate();
				splitTexts[i][j].contents = txArray[j] ;

				if( HorV )
				{
					splitTexts[i][j].position = [ txPos[0] , txPos[1]-(lineHeight*j) ] ;
					
					if( splitTexts[i][j].kind == TextType.AREATEXT )
					{
						if( aiVersion == "10" )
						{ splitTexts[i][j].textPaths[0].textPathObject.height
						 = lineHeight * splitTexts[i][j].textRange().textLines.length }
						else
						{ splitTexts[i][j].textPath.height
						 = lineHeight * splitTexts[i][j].lines.length }
						
						if( j > 0 )
						{ splitTexts[i][j].top
						 = splitTexts[i][j-1].top - splitTexts[i][j-1].height }
					}
				}
				else
				{
					// 縦書きのエリアテキストの場合は、先に幅を決める
					if( splitTexts[i][j].kind == TextType.AREATEXT )
					{
						if( aiVersion == "10" )
						{ splitTexts[i][j].textPaths[0].textPathObject.width
						 = lineHeight * splitTexts[i][j].textRange().textLines.length }
						else
						{ splitTexts[i][j].textPath.width
						 = lineHeight * splitTexts[i][j].lines.length }
					}
					
					splitTexts[i][j].position
					// = [ txPos[0]+(lineHeight*((txArray.length-1)-j)) , txPos[1] ] ;
					 = [ txPos[0] + itemsToSplit[i].width - splitTexts[i][j].width , txPos[1] ] ;
					
					if( j > 0 )
					{ splitTexts[i][j].left
					 = splitTexts[i][j-1].left - splitTexts[i][j].width }
				}

				if( aiVersion == "10" )
				{ splitTexts[i][j].moveBefore( itemsToSplit[i] ) }
				else
				{ splitTexts[i][j].move( itemsToSplit[i] , ElementPlacement.PLACEBEFORE ) }
			}
		}
		itemsToSplit[i].remove() ;
	}
}

エクセルでフォントの一覧を作成 

Sub macro110702a()
'フォント名と見本一覧を作成

    Sheets.Add
    Cells(1, 1) = "フォント名"
    Cells(1, 2) = "見本"
   
    Dim i As Integer
    Dim str1 As String
     Dim str2 As String
    Dim obj As Object
    str1 = "abcdefghijklmnopqrstuvwxyz"
    str2 = "0123456789"
    Set obj = Application.CommandBars("Formatting"). _
        Controls.Item(1)
   
    For i = 1 To obj.ListCount
        Cells(i + 1, 1) = obj.List(i)
        Cells(i + 1, 2) = str1
        Cells(i + 1, 3) = str2
        Cells(i + 1, 2).Font.Name = obj.List(i)
        Cells(i + 1, 3).Font.Name = obj.List(i)
    Next i
   
End Sub

イラストレーターでフォントの一覧を作成_50個ver 


var  txt =  "";
for(var i=0; i<app.textFonts.length; i++){
     txt =  txt +  app.textFonts[i].name+ "     0123456789"+"\r";
     
}
//  テキストフレームを生成しフォント（書体）一覧を表示する
var  txtObj =  app.activeDocument.textFrames.add();
txtObj.contents =  txt;
//txtObj.top =  -10;    //  位置を調整
//txtObj.left =  10;

for(var j=0; j<50; j++){
//app.textFonts.length; j++){
     var  fName =  app.textFonts[app.textFonts[j].name];
     txtObj.paragraphs[j].characterAttributes.textFont =  fName;
     
}

テストテスト 

Sub 添付ファイル一括保存()

    Dim sl As Object, attachFile As Object
    Dim app As New Outlook.Application
    Dim exp As Outlook.Explorer
    Dim sel As Outlook.Selection
    Dim sh As Object, f As Object
    Dim path As String
    Dim checkExpath As String
    Dim lVal As String
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")

    On Error GoTo ErrHandler

    Set app = CreateObject("Outlook.Application")
    Set exp = app.ActiveExplorer
    Set sel = exp.Selection

    ''対象フォルダを指定する
    Set sh = CreateObject("Shell.Application")
    Set f = sh.BrowseForFolder(0, "保存先フォルダを選択", &H1, 0)
    ''フォルダ選択ダイアログでキャンセルされたら抜けます
    If f Is Nothing Then GoTo NormalExit
    ''フォルダパスを指定
    path = f.self.path


    ''添付ファイルを保存する
    ''試してみてわかったけど、画像なんかをOLE埋め込みしてるメールは
    ''画像ファイル名に「ファイルパスに使えない文字」入りで取得される
    ''だから画像埋め込みとかしてるものは保存時にエラーになります
    
    '下記は、送信者名-添付ファイル名で保存する作業
    For Each sl In sel
        For Each attachFile In sl.Attachments
            checkExpath = path & "\" & sl.SenderName & "-" & attachFile.DisplayName
            'すでに同名のファイルがないかをチェックします
            If Not (fs.FileExists(checkExpath)) Then
                attachFile.SaveAsFile checkExpath
            '同名のファイルがあった場合"ファイル名-1""ファイル名-2"と合番をつけます
            Else
                cnt = 0
                Do Until Not (fs.FileExists(checkExpath))
                    cnt = cnt + 1
                    lVal = Mid(attachFile.DisplayName, 1, InStrRev(attachFile.DisplayName, ".") - 1)
                    lVal = lVal & "_" & cnt & Mid(attachFile.DisplayName, InStrRev(attachFile.DisplayName, "."))
                    checkExpath = path & "\" & sl.SenderName & "-" & lVal
                Loop
                attachFile.SaveAsFile checkExpath
            End If
            
        Next
    Next

    MsgBox "終了しました。", vbInfomation, "ファイル一括保存"
    ''おしまい
    GoTo NormalExit

ErrHandler:
    MsgBox "エラーが発生しました" & vbCrLf & Err.Description, vbExclamation, "ファイル一括保存"

NormalExit:
    Set sl = Nothing
    Set attachFile = Nothing
    Set sel = Nothing
    Set exp = Nothing
    Set app = Nothing

End Sub

添付テスト

>||
Sub 添付ファイル一括保存()

    Dim sl As Object, attachFile As Object
    Dim app As New Outlook.Application
    Dim exp As Outlook.Explorer
    Dim sel As Outlook.Selection
    Dim sh As Object, f As Object
    Dim path As String
    Dim checkExpath As String
    Dim lVal As String
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")

    On Error GoTo ErrHandler

    Set app = CreateObject("Outlook.Application")
    Set exp = app.ActiveExplorer
    Set sel = exp.Selection

    ''対象フォルダを指定する
    Set sh = CreateObject("Shell.Application")
    Set f = sh.BrowseForFolder(0, "保存先フォルダを選択", &H1, 0)
    ''フォルダ選択ダイアログでキャンセルされたら抜けます
    If f Is Nothing Then GoTo NormalExit
    ''フォルダパスを指定
    path = f.self.path


    ''添付ファイルを保存する
    ''試してみてわかったけど、画像なんかをOLE埋め込みしてるメールは
    ''画像ファイル名に「ファイルパスに使えない文字」入りで取得される
    ''だから画像埋め込みとかしてるものは保存時にエラーになります
    
    '下記は、送信者名-添付ファイル名で保存する作業
    For Each sl In sel
        For Each attachFile In sl.Attachments
            checkExpath = path & "" & sl.SenderName & "-" & attachFile.DisplayName
            'すでに同名のファイルがないかをチェックします
            If Not (fs.FileExists(checkExpath)) Then
                attachFile.SaveAsFile checkExpath
            '同名のファイルがあった場合"ファイル名-1""ファイル名-2"と合番をつけます
            Else
                cnt = 0
                Do Until Not (fs.FileExists(checkExpath))
                    cnt = cnt + 1
                    lVal = Mid(attachFile.DisplayName, 1, InStrRev(attachFile.DisplayName, ".") - 1)
                    lVal = lVal & "_" & cnt & Mid(attachFile.DisplayName, InStrRev(attachFile.DisplayName, "."))
                    checkExpath = path & "" & sl.SenderName & "-" & lVal
                Loop
                attachFile.SaveAsFile checkExpath
            End If
            
        Next
    Next

    MsgBox "終了しました。", vbInfomation, "ファイル一括保存"
    ''おしまい
    GoTo NormalExit

ErrHandler:
    MsgBox "エラーが発生しました" & vbCrLf & Err.Description, vbExclamation, "ファイル一括保存"

NormalExit:
    Set sl = Nothing
    Set attachFile = Nothing
    Set sel = Nothing
    Set exp = Nothing
    Set app = Nothing

End Sub
<||

特定の名前のメールを受信すると差出人の名前をメッセージボックスに表示

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    SaveToCsv EntryIDCollection
End Sub
'
Private Sub SaveToCsv(ByVal EntryIDCollection As String)
    Const AUTO_SAVE_TITLE = "受注" ' 自動処理するメールの件名
    Const CSV_FILE = "c:UserssibikoDesktopdata.csv" ' データを保存する CSV ファイルの名前
    Dim i As Integer
    Dim j As Integer
    Dim arrEntryId
    Dim myMsg
    Dim stmCsv
    Set stmCsv = Nothing
    arrEntryId = Split(EntryIDCollection, ",")
    For i = LBound(arrEntryId) To UBound(arrEntryId)
        Set myMsg = Application.Session.GetItemFromID(arrEntryId(i))
        If myMsg.Subject = AUTO_SAVE_TITLE Then
            MsgBox myMsg.SenderName
            
            
            Dim strCode
            Dim strName
            Dim strQuantity
            If stmCsv Is Nothing Then
                Dim objFSO
                Set objFSO = CreateObject("Scripting.FileSystemObject")
                Set stmCsv = objFSO.OpenTextFile(CSV_FILE, 8, True, 0)
            End If
            stmCsv.WriteLine myMsg.SenderName & j
            j = j + 1
        End If
    Next
    If Not stmCsv Is Nothing Then
        stmCsv.Close
    End If
End Sub