精华内容
下载资源
问答
  • https://docs.microsoft.com/zh-cn/office/vba/api/excel.shapes.addcurve 由指定曲线的顶点和控制点的坐标对组成的数组。您指定的第一个点是起始顶点, 接下来的两个点是第一段贝塞尔线段的控制点。该曲线每增加一...

     

    1  Shapes.AddCurve SafeArrayOfPoints:=pts   贝塞尔曲线

    • https://docs.microsoft.com/zh-cn/office/vba/api/excel.shapes.addcurve
    • 由指定曲线的顶点和控制点的坐标对组成的数组。 您指定的第一个点是起始顶点, 接下来的两个点是第一段贝塞尔线段的控制点。 该曲线每增加一条线段,就要为其指定一个顶点和两个控制点。您指定的最后一个点是曲线的结束顶点。 请注意,必须指定的点数始终为 3n + 1,其中 n 为曲线的线段个数。
    • SafeArrayOfPoints:=pts 
    • 贝塞尔曲线
    • 起点,2控制点,2控制点 .....终点------好像必须是3n+1,比如4,7,10等等
    • 第2维只能是2?

     

    1.1 贝塞尔曲线

    https://www.zhihu.com/question/29565629

    https://baike.baidu.com/item/%E8%B4%9D%E5%A1%9E%E5%B0%94%E6%9B%B2%E7%BA%BF/1091769?fr=aladdin

    它通过控制曲线上的四个点(起始点、终止点以及两个相互分离的中间点)来创造、编辑图形。其中起重要作用的是位于曲线中央的控制线。这条线是虚拟的,中间与贝塞尔曲线交叉,两端是控制端点。移动两端的端点时贝塞尔曲线改变曲线的曲率(弯曲的程度);移动中间点(也就是移动虚拟的控制线)时,贝塞尔曲线在起始点和终止点锁定的情况下做均匀移动。注意,贝塞尔曲线上的所有控制点、节点均可编辑。这种“智能化”的矢量线条为艺术家提供了一种理想的图形编辑与创造的工具。


     

    Sub t5()
    Dim pts(1 To 4, 1 To 2) As Single
    pts(1, 1) = 10
    pts(1, 2) = 50
    
    pts(2, 1) = 200
    pts(2, 2) = 120
    
    pts(3, 1) = 150
    pts(3, 2) = 210
    
    pts(4, 1) = 310
    pts(4, 2) = 220
    
    Worksheets("sheet4").Shapes.AddCurve SafeArrayOfPoints:=pts
    
    End Sub

     

    1.2 第2个贝塞尔曲线

     

    Sub t6()
    Dim pts(1 To 10, 1 To 2) As Single
    pts(1, 1) = 10         '
    
    pts(1, 2) = 50         '这种分类是错误的
    pts(2, 1) = 200
    
    pts(2, 2) = 120
    pts(3, 1) = 150
    
    pts(3, 2) = 210
    pts(4, 1) = 310
    
    pts(4, 2) = 220
    pts(5, 1) = 110
    
    pts(5, 2) = 280
    pts(6, 1) = 190
    
    pts(6, 2) = 220
    pts(7, 1) = 150
    
    pts(7, 2) = 210
    pts(8, 1) = 310
    
    pts(8, 2) = 220
    pts(9, 1) = 110
    
    pts(9, 2) = 280
    pts(10, 1) = 190
    
    pts(10, 2) = 210
    
    
    Worksheets("sheet5").Shapes.AddCurve SafeArrayOfPoints:=pts
    
    End Sub

     

    1.3 根据这个原理,控制4个点,果然可以画出想要的这种波浪曲线

    • 起点: 和终点在同一个高度
    • 终点:X大,Y=Y起点
    • 控制点1:X前进,Y往上
    • 控制点2:X继续前进,Y往下

     

     

    Sub t5()
    Dim pts(1 To 4, 1 To 2) As Single
    pts(1, 1) = 0           '第1个点的X坐标
    pts(1, 2) = 150         '第1个点的Y坐标
    
    pts(2, 1) = 150         '第2个点的X坐标
    pts(2, 2) = 0
    
    pts(3, 1) = 200         '第3个点的X坐标
    pts(3, 2) = 300
    
    pts(4, 1) = 400
    pts(4, 2) = 150
    
    Worksheets("sheet4").Shapes.AddCurve SafeArrayOfPoints:=pts
    
    End Sub
    展开全文
  • vba

    2019-10-07 14:22:28
    ActiveDocument.Shapes(i).Type = msoTextEffect ' 文档中的第i个Shape是否为艺术字 超级链接: ActiveDocument.Hyperlinks.Count ' 文档中的超级链接的个数 首行是否缩进: A...

    艺术字:    
      ActiveDocument.Shapes(i).Type   =   msoTextEffect   '   文档中的第i个Shape是否为艺术字  
       
      超级链接:    
      ActiveDocument.Hyperlinks.Count     '   文档中的超级链接的个数  
       
      首行是否缩进:    
      ActiveDocument.Paragraphs(i).FirstLineIndent     '   首行缩进的磅数  
       
      第一段头两个字是否下沉两行:    
      ActiveDocument.Paragraphs(1).DropCap.Position   =   wdDropNone     '   没有下沉  
      ActiveDocument.Paragraphs(1).DropCap.LinesToDrop     '   如果下沉的话,   则为下沉的行数

     

     

    Public Class WordOpLib
      2
      3
      4    Private oWordApplic As Word.ApplicationClass
      5    Private oDocument As Word.Document
      6    Private oRange As Word.Range
      7    Private oShape As Word.Shape
      8    Private oSelection As Word.Selection
      9
     10
     11    Public Sub New()
     12        '激活com  word接口
     13        oWordApplic = New Word.ApplicationClass
     14        oWordApplic.Visible = False
     15
     16    End Sub
     17    '设置选定文本
     18    Public Sub SetRange(ByVal para As Integer)
     19        oRange = oDocument.Paragraphs(para).Range
     20        oRange.Select()
     21    End Sub
     22    Public Sub SetRange(ByVal para As Integer, ByVal sent As Integer)
     23        oRange = oDocument.Paragraphs(para).Range.Sentences(sent)
     24        oRange.Select()
     25    End Sub
     26    Public Sub SetRange(ByVal startpoint As Integer, ByVal endpoint As Integer, ByVal flag As Boolean)
     27        If flag = True Then
     28            oRange = oDocument.Range(startpoint, endpoint)
     29            oRange.Select()
     30        Else
     31
     32        End If
     33    End Sub
     34
     35    '生成空的新文档
     36    Public Sub NewDocument()
     37        Dim missing = System.Reflection.Missing.Value
     38        Dim isVisible As Boolean = True
     39        oDocument = oWordApplic.Documents.Add(missing, missing, missing, missing)
     40        oDocument.Activate()
     41    End Sub
     42    '使用模板生成新文档
     43    Public Sub NewDocWithModel(ByVal FileName As String)
     44        Dim missing = System.Reflection.Missing.Value
     45        Dim isVisible As Boolean = False
     46        Dim strName As String
     47        strName = FileName
     48        oDocument = oWordApplic.Documents.Add(strName, missing, missing, isVisible)
     49        oDocument.Activate()
     50    End Sub
     51    '打开已有文档
     52    Public Sub OpenFile(ByVal FileName As String)
     53        Dim strName As String
     54        Dim isReadOnly As Boolean
     55        Dim isVisible As Boolean
     56        Dim missing = System.Reflection.Missing.Value
     57
     58        strName = FileName
     59        isReadOnly = False
     60        isVisible = True
     61
     62        oDocument = oWordApplic.Documents.Open(strName, missing, isReadOnly, missing, missing, missing, missing, missing, missing, missing, missing, isVisible, missing, missing, missing, missing)
     63        oDocument.Activate()
     64
     65    End Sub
     66    Public Sub OpenFile(ByVal FileName As String, ByVal isReadOnly As Boolean)
     67        Dim strName As String
     68        Dim isVisible As Boolean
     69        Dim missing = System.Reflection.Missing.Value
     70
     71        strName = FileName
     72        isVisible = True
     73
     74        oDocument = oWordApplic.Documents.Open(strName, missing, isReadOnly, missing, missing, missing, missing, missing, missing, missing, missing, isVisible, missing, missing, missing, missing)
     75        oDocument.Activate()
     76    End Sub
     77    '退出Word
     78    Public Sub Quit()
     79        Dim missing = System.Reflection.Missing.Value
     80        oWordApplic.Quit()
     81        System.Runtime.InteropServices.Marshal.ReleaseComObject(oWordApplic)
     82        oWordApplic = Nothing
     83    End Sub
     84    '关闭所有打开的文档
     85    Public Sub CloseAllDocuments()
     86        oWordApplic.Documents.Close(Word.WdSaveOptions.wdDoNotSaveChanges)
     87    End Sub
     88    '关闭当前的文档
     89    Public Sub CloseCurrentDocument()
     90
     91        oDocument.Close(Word.WdSaveOptions.wdDoNotSaveChanges)
     92    End Sub
     93    '保存当前文档
     94    Public Sub Save()
     95        Try
     96            oDocument.Save()
     97        Catch
     98            MsgBox(Err.Description)
     99        End Try
    100    End Sub
    101    '另存为文档
    102    Public Sub SaveAs(ByVal FileName As String)
    103        Dim strName As String
    104        Dim missing = System.Reflection.Missing.Value
    105
    106        strName = FileName
    107
    108        oDocument.SaveAs(strName, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing)
    109    End Sub
    110    '保存为Html文件
    111    Public Sub SaveAsHtml(ByVal FileName As String)
    112        Dim missing = System.Reflection.Missing.Value
    113        Dim strName As String
    114
    115        strName = FileName
    116        Dim format = CInt(Word.WdSaveFormat.wdFormatHTML)
    117
    118        oDocument.SaveAs(strName, format, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing, missing)
    119    End Sub
    120    '插入文本
    121    Public Sub InsertText(ByVal text As String)
    122        oWordApplic.Selection.TypeText(text)
    123    End Sub
    124    '插入一个空行
    125    Public Sub InsertLineBreak()
    126        oWordApplic.Selection.TypeParagraph()
    127    End Sub
    128    '插入指定行数的空行
    129    Public Sub InsertLineBreak(ByVal lines As Integer)
    130        Dim i As Integer
    131        For i = 1 To lines
    132            oWordApplic.Selection.TypeParagraph()
    133        Next
    134    End Sub
    135    '插入表格
    136    Public Sub InsertTable(ByRef table As DataTable)
    137        Dim oTable As Word.Table
    138        Dim rowIndex, colIndex, NumRows, NumColumns As Integer
    139        rowIndex = 1
    140        colIndex = 0
    141        If (table.Rows.Count = 0) Then
    142            Exit Sub
    143        End If
    144
    145        NumRows = table.Rows.Count + 1
    146        NumColumns = table.Columns.Count
    147        oTable = oDocument.Tables.Add(oWordApplic.Selection.Range(), NumRows, NumColumns)
    148
    149
    150        '初始化列
    151        Dim Row As DataRow
    152        Dim Col As DataColumn
    153        'For Each Col In table.Columns
    154        '    colIndex = colIndex + 1
    155        '    oTable.Cell(1, colIndex).Range.InsertAfter(Col.ColumnName)
    156        'Next
    157
    158        '将行添入表格
    159        For Each Row In table.Rows
    160            rowIndex = rowIndex + 1
    161            colIndex = 0
    162            For Each Col In table.Columns
    163                colIndex = colIndex + 1
    164                oTable.Cell(rowIndex, colIndex).Range.InsertAfter(Row(Col.ColumnName))
    165            Next
    166        Next
    167        oTable.Rows(1).Delete()
    168        oTable.AllowAutoFit = True
    169        oTable.ApplyStyleFirstColumn = True
    170        oTable.ApplyStyleHeadingRows = True
    171
    172    End Sub
    173    '插入表格(修改为在原有表格的基础上添加数据)
    174    Public Sub InsertTable2(ByRef table As DataTable, ByVal strbmerge As String, ByVal totalrow As Integer)
    175        Dim oTable As Word.Table
    176        Dim rowIndex, colIndex, NumRows, NumColumns As Integer
    177        Dim strm() As String
    178        Dim i As Integer
    179        rowIndex = 1
    180        colIndex = 0
    181
    182        If (table.Rows.Count = 0) Then
    183            Exit Sub
    184        End If
    185
    186        NumRows = table.Rows.Count + 1
    187        NumColumns = table.Columns.Count
    188        'oTable = oDocument.Tables.Add(oWordApplic.Selection.Range(), NumRows, NumColumns)
    189
    190
    191        '初始化列
    192        Dim Row As DataRow
    193        Dim Col As DataColumn
    194        'For Each Col In table.Columns
    195        '    colIndex = colIndex + 1
    196        '    oTable.Cell(1, colIndex).Range.InsertAfter(Col.ColumnName)
    197        'Next
    198
    199        '将行添入表格
    200        For Each Row In table.Rows
    201            colIndex = 0
    202            GotoRightCell()
    203            oWordApplic.Selection.InsertRows(1)
    204            For Each Col In table.Columns
    205                GotoRightCell()
    206                colIndex = colIndex + 1
    207                Try
    208                    oWordApplic.Selection.TypeText(Row(Col.ColumnName))
    209                Catch ex As Exception
    210                    oWordApplic.Selection.TypeText(" ")
    211                End Try
    212                'oWordApplic.Selection.Cell(rowIndex, colIndex).Range.InsertAfter(Row(Col.ColumnName))
    213            Next
    214        Next
    215        '如果strbmerge不为空.则要合并相应的行和列
    216        If strbmerge.Trim().Length <> 0 Then
    217            strm = strbmerge.Split(";")
    218            For i = 1 To strm.Length - 1
    219                If strm(i).Split(",").Length = 2 Then
    220                    MergeDouble(totalrow, strm(0), strm(i).Split(",")(1), strm(i).Split(",")(0))
    221                End If
    222                MergeSingle(totalrow, strm(0), strm(i))
    223            Next
    224        End If
    225        '删除可能多余的一行
    226        'GotoRightCell()
    227        'GotoDownCell()
    228        'oWordApplic.Selection.Rows.Delete()
    229        'oTable.AllowAutoFit = True
    230        'oTable.ApplyStyleFirstColumn = True
    231        'oTable.ApplyStyleHeadingRows = True
    232    End Sub
    233    '插入表格(专门适应工程结算工程量清单)
    234    Public Sub InsertTableQD(ByRef table As DataTable, ByRef table1 As DataTable)
    235        Dim oTable As Word.Table
    236        Dim rowIndex, colIndex, NumRows, NumColumns As Integer
    237        Dim xmmc As String
    238        Dim i As Integer
    239        Dim j As Integer
    240        rowIndex = 1
    241        colIndex = 0
    242
    243        If (table.Rows.Count = 0) Then
    244            Exit Sub
    245        End If
    246
    247        NumRows = table.Rows.Count + 1
    248        NumColumns = table.Columns.Count
    249        'oTable = oDocument.Tables.Add(oWordApplic.Selection.Range(), NumRows, NumColumns)
    250
    251
    252        '初始化列
    253        Dim Row As DataRow
    254        Dim rowtemp As DataRow
    255        Dim row1() As DataRow
    256        Dim Col As DataColumn
    257        Dim coltemp As DataColumn
    258        'For Each Col In table.Columns
    259        '    colIndex = colIndex + 1
    260        '    oTable.Cell(1, colIndex).Range.InsertAfter(Col.ColumnName)
    261        'Next
    262
    263        '将行添入表格
    264        For Each Row In table.Rows
    265            colIndex = 0
    266            xmmc = Row("项目名称")
    267            GotoRightCell()
    268            oWordApplic.Selection.InsertRows(1)
    269            For Each Col In table.Columns
    270                GotoRightCell()
    271                Try
    272                    If (Col.ColumnName = "项目序号") Then
    273                        oWordApplic.Selection.TypeText(intToUpint(Val(Row(Col.ColumnName))))
    274                    Else
    275                        oWordApplic.Selection.TypeText(Row(Col.ColumnName))
    276                    End If
    277                Catch ex As Exception
    278                    oWordApplic.Selection.TypeText(" ")
    279                End Try
    280                'oWordApplic.Selection.Cell(rowIndex, colIndex).Range.InsertAfter(Row(Col.ColumnName))
    281            Next
    282            row1 = table1.Select("项目名称='" + xmmc + "'")
    283
    284            For i = 0 To row1.Length - 1
    285                GotoRightCell()
    286                oWordApplic.Selection.InsertRows(1)
    287                For j = 0 To table1.Columns.Count - 1
    288                    If (table1.Columns(j).ColumnName <> "项目名称") Then
    289                        GotoRightCell()
    290                        Try
    291                            oWordApplic.Selection.TypeText(row1(i)(j))
    292                        Catch ex As Exception
    293                            oWordApplic.Selection.TypeText(" ")
    294                        End Try
    295                    End If
    296                    'oWordApplic.Selection.Cell(rowIndex, colIndex).Range.InsertAfter(Row(Col.ColumnName))
    297                Next
    298            Next
    299
    300
    301
    302        Next
    303        '删除可能多余的一行
    304        'GotoRightCell()
    305        'GotoDownCell()
    306        'oWordApplic.Selection.Rows.Delete()
    307        'oTable.AllowAutoFit = True
    308        'oTable.ApplyStyleFirstColumn = True
    309        'oTable.ApplyStyleHeadingRows = True
    310    End Sub
    311    '插入表格,为了满足要求,在中间添加一根竖线
    312    Public Sub InsertTable3(ByRef table As DataTable, ByVal introw As Integer, ByVal intcol As Integer)
    313        Dim rowIndex, colIndex, NumRows, NumColumns As Integer
    314        Dim Row As DataRow
    315        Dim Col As DataColumn
    316        If (table.Rows.Count = 0) Then
    317            Exit Sub
    318        End If
    319        '首先是拆分选中的单元格
    320        oDocument.Tables(1).Cell(introw, 3).Split(table.Rows.Count, 2)
    321        '选中初始的单元格
    322        oDocument.Tables(1).Cell(introw, 3).Select()
    323        '将行添入表格
    324        For Each Row In table.Rows
    325            Try
    326                oDocument.Tables(1).Cell(introw, 3).Range.InsertAfter(Row(0))
    327                oDocument.Tables(1).Cell(introw, 4).Range.InsertAfter(Row(1))
    328            Catch ex As Exception
    329                oDocument.Tables(1).Cell(introw, 3).Range.InsertAfter(" ")
    330                oDocument.Tables(1).Cell(introw, 4).Range.InsertAfter(" ")
    331            End Try
    332            introw = introw + 1
    333        Next
    334    End Sub
    335    '设置对齐
    336    Public Sub SetAlignment(ByVal strType As String)
    337        Select Case strType
    338            Case "center"
    339                oWordApplic.Selection.ParagraphFormat.Alignment = Word.WdParagraphAlignment.wdAlignParagraphCenter
    340            Case "left"
    341                oWordApplic.Selection.ParagraphFormat.Alignment = Word.WdParagraphAlignment.wdAlignParagraphLeft
    342            Case "right"
    343                oWordApplic.Selection.ParagraphFormat.Alignment = Word.WdParagraphAlignment.wdAlignParagraphRight
    344            Case "justify"
    345                oWordApplic.Selection.ParagraphFormat.Alignment = Word.WdParagraphAlignment.wdAlignParagraphJustify
    346        End Select
    347    End Sub
    348    '设置字体
    349    Public Sub SetStyle(ByVal strFont As String)
    350        Select Case strFont
    351            Case "bold"
    352                oWordApplic.Selection.Font.Bold = 1
    353            Case "italic"
    354                oWordApplic.Selection.Font.Italic = 1
    355            Case "underlined"
    356                oWordApplic.Selection.Font.Subscript = 1
    357        End Select
    358    End Sub
    359    '取消字体风格
    360    Public Sub DissableStyle()
    361        oWordApplic.Selection.Font.Bold = 0
    362        oWordApplic.Selection.Font.Italic = 0
    363        oWordApplic.Selection.Font.Subscript = 0
    364    End Sub
    365    '设置字体字号
    366    Public Sub SetFontSize(ByVal nSize As Integer)
    367        oWordApplic.Selection.Font.Size = nSize
    368    End Sub
    369    '跳过本页
    370    Public Sub InsertPageBreak()
    371        Dim pBreak As Integer
    372        pBreak = CInt(Word.WdBreakType.wdPageBreak)
    373        oWordApplic.Selection.InsertBreak(pBreak)
    374    End Sub
    375    '转到书签
    376    Public Sub GotoBookMark(ByVal strBookMark As String)
    377        Dim missing = System.Reflection.Missing.Value
    378        Dim BookMark = CInt(Word.WdGoToItem.wdGoToBookmark)
    379        oWordApplic.Selection.GoTo(BookMark, missing, missing, strBookMark)
    380    End Sub
    381    '判断书签是否存在
    382    Public Function BookMarkExist(ByVal strBookMark As String) As Boolean
    383        Dim Exist As Boolean
    384        Exist = oDocument.Bookmarks.Exists(strBookMark)
    385        Return Exist
    386    End Function
    387    '替换书签的内容
    388    Public Sub ReplaceBookMark(ByVal icurnum As String, ByVal strcontent As String)
    389        strcontent = strcontent.Replace("0:00:00""")
    390        oDocument.Bookmarks(icurnum).Select()
    391        oWordApplic.Selection.TypeText(strcontent)
    392    End Sub
    393
    394    '得到书签的名称
    395    Public Function GetBookMark(ByVal icurnum As String, ByRef bo As Boolean) As String
    396        Dim strReturn As String
    397        If Right(oDocument.Bookmarks(icurnum).Name, 5= "TABLE" Then
    398            bo = True
    399            Dim strTemp As String
    400            strTemp = oDocument.Bookmarks(icurnum).Name()
    401            strReturn = Mid(strTemp, 1, Len(strTemp) - 5)
    402        Else
    403            bo = False
    404            strReturn = oDocument.Bookmarks(icurnum).Name
    405        End If
    406        Return strReturn
    407    End Function
    408    '得到书签的名称
    409    Public Function GetBookMark1(ByVal icurnum As String) As String
    410        Return oDocument.Bookmarks(icurnum).Name
    411    End Function
    412    '转到文档结尾
    413    Public Sub GotoTheEnd()
    414        Dim missing = System.Reflection.Missing.Value
    415        Dim unit = Word.WdUnits.wdStory
    416        oWordApplic.Selection.EndKey(unit, missing)
    417    End Sub
    418    '转到文档开头
    419    Public Sub GotoTheBegining()
    420        Dim missing = System.Reflection.Missing.Value
    421        Dim unit = Word.WdUnits.wdStory
    422        oWordApplic.Selection.HomeKey(unit, missing)
    423    End Sub
    424    '删除多余的一行
    425    Public Sub DelUnuseRow()
    426        oWordApplic.Selection.Rows.Delete()
    427    End Sub
    428    '转到表格
    429    Public Sub GotoTheTable(ByVal ntable As Integer)
    430        'Dim missing = System.Reflection.Missing.Value
    431        'Dim what = Word.WdGoToItem.wdGoToTable
    432        'Dim which = Word.WdGoToDirection.wdGoToFirst
    433        'Dim count = ntable
    434
    435        'oWordApplic.Selection.GoTo(what, which, count, missing)
    436        'oWordApplic.Selection.ClearFormatting()
    437
    438        'oWordApplic.Selection.Text = ""
    439        oRange = oDocument.Tables(ntable).Cell(11).Range
    440        oRange.Select()
    441
    442    End Sub
    443    '转到表格的某个单元格
    444    Public Sub GotoTableCell(ByVal ntable As Integer, ByVal nRow As Integer, ByVal nColumn As Integer)
    445        oRange = oDocument.Tables(ntable).Cell(nRow, nColumn).Range
    446        oRange.Select()
    447    End Sub
    448    '表格中转到右面的单元格
    449    Public Sub GotoRightCell()
    450        Dim missing = System.Reflection.Missing.Value
    451        Dim direction = Word.WdUnits.wdCell
    452        oWordApplic.Selection.MoveRight(direction, missing, missing)
    453    End Sub
    454    '表格中转到左面的单元格
    455    Public Sub GotoLeftCell()
    456        Dim missing = System.Reflection.Missing.Value
    457        Dim direction = Word.WdUnits.wdCell
    458        oWordApplic.Selection.MoveLeft(direction, missing, missing)
    459    End Sub
    460    '表格中转到下面的单元格
    461    Public Sub GotoDownCell()
    462        Dim missing = System.Reflection.Missing.Value
    463        Dim direction = Word.WdUnits.wdCell
    464        oWordApplic.Selection.MoveDown(direction, missing, missing)
    465    End Sub
    466    '表格中转到上面的单元格
    467    Public Sub GotoUpCell()
    468        Dim missing = System.Reflection.Missing.Value
    469        Dim direction = Word.WdUnits.wdCell
    470        oWordApplic.Selection.MoveUp(direction, missing, missing)
    471    End Sub
    472    '文档中所有的书签总数
    473    Public Function TotalBkM() As Integer
    474        Return oDocument.Bookmarks.Count
    475    End Function
    476    '选中书签
    477    Public Sub SelectBkMk(ByVal strName As String)
    478        oDocument.Bookmarks.Item(strName).Select()
    479    End Sub
    480    '插入图片
    481    Public Sub InsertPic(ByVal FileName As String)
    482        Dim missing = System.Reflection.Missing.Value
    483        oWordApplic.Selection.InlineShapes.AddPicture(FileName, False, True, missing).Select()
    484        oShape = oWordApplic.Selection.InlineShapes(1).ConvertToShape
    485        oWordApplic.Selection.WholeStory()
    486        oShape.ZOrder(Microsoft.Office.Core.MsoZOrderCmd.msoSendBehindText)
    487    End Sub
    488    '统一调整图片的位置.也就是往上面调整图片一半的高度
    489    Public Sub SetCurPicHei()
    490        Dim e As Word.Shape
    491        For Each e In oDocument.Shapes
    492            oDocument.Shapes(e.Name).Select()
    493            oWordApplic.Selection.ShapeRange.RelativeHorizontalPosition = Word.WdRelativeHorizontalPosition.wdRelativeHorizontalPositionPage
    494            oWordApplic.Selection.ShapeRange.RelativeVerticalPosition = Word.WdRelativeVerticalPosition.wdRelativeVerticalPositionParagraph
    495            oWordApplic.Selection.ShapeRange.LockAnchor = True
    496            'oWordApplic.Selection.ShapeRange.IncrementTop(oDocument.Shapes(e.Name).Height)
    497        Next
    498    End Sub
    499
    500    Public Sub SetCurPicHei1()
    501        Dim e As Word.Shape
    502        For Each e In oDocument.Shapes
    503            oDocument.Shapes(e.Name).Select()
    504            oWordApplic.Selection.ShapeRange.IncrementTop(oDocument.Shapes(e.Name).Height / 2)
    505        Next
    506    End Sub
    507    Public Sub SetCurPicHei2()
    508        Dim e As Word.Shape
    509        For Each e In oDocument.Shapes
    510            oDocument.Shapes(e.Name).Select()
    511            oWordApplic.Selection.ShapeRange.IncrementTop(-oDocument.Shapes(e.Name).Height / 2)
    512        Next
    513    End Sub
    514    Public Function intToUpint(ByVal a As Integer) As String
    515        Dim result As String = "一百"
    516        Dim a1, a2 As Integer
    517ExpandedBlockStart.gifContractedBlock.gif        Dim strs() As String = {""""""""""""""""""""""}
    518        If (a <= 10) Then
    519            result = strs(a)
    520        ElseIf (a < 100) Then
    521            a1 = a / 10
    522            a2 = a Mod 10
    523            If (a = 1) Then
    524                result = "" + strs(a2)
    525            End If
    526        Else
    527            result = strs(a1) + "" + strs(a2)
    528        End If
    529        Return result
    530    End Function
    531    '合并没有参照的某一列,一般来讲对应第一列
    532    'itotalrow 总行数
    533    'initrow   初始开始的行数,一般情况下该值不为0,没有标题栏的一般为0
    534    'intcol    列数
    535    Public Sub MergeSingle(ByVal itotalrow As Integer, ByVal initrow As Integer, ByVal intcol As Integer)
    536        oDocument.Tables(1).Cell(initrow + 1, intcol).Select()
    537        Dim irow As Integer      '当前行数
    538        Dim strValue As String   '循环比较的行初值
    539        Dim i As Integer
    540        Dim direction = Word.WdUnits.wdLine
    541        Dim extend = Word.WdMovementType.wdExtend
    542
    543        i = 0
    544        irow = 1 + initrow '初始值为1
    545        For i = 2 + initrow To itotalrow + initrow
    546
    547            strValue = oDocument.Tables(1).Cell(irow, intcol).Range.Text
    548            If (oDocument.Tables(1).Cell(i, intcol).Range.Text = oDocument.Tables(1).Cell(irow, intcol).Range.Text) Then
    549                '这是对最后一次处理的特殊情况.
    550                If (i = itotalrow + initrow) Then
    551                    oWordApplic.Selection.MoveDown(direction, (i - irow), extend)
    552                    If (i - irow >= 1) Then
    553                        oWordApplic.Selection.Cells.Merge()
    554                    End If
    555                    oDocument.Tables(1).Cell(irow, intcol).Range.Text = strValue
    556                End If
    557            Else
    558                oWordApplic.Selection.MoveDown(direction, (i - irow - 1), extend)
    559                If (i - irow - 1 >= 1) Then
    560                    oWordApplic.Selection.Cells.Merge()
    561                End If
    562                oDocument.Tables(1).Cell(irow, intcol).Range.Text = strValue
    563                irow = i
    564                oDocument.Tables(1).Cell(irow, intcol).Select()
    565            End If
    566        Next i
    567    End Sub
    568    '合并有参照的某一列
    569    'itotalrow 总行数
    570    'initrow   初始开始的行数,一般情况下该值不为0,没有标题栏的一般为0
    571    'intcol    列数
    572    'basecol   参照合并的那一列
    573    Public Sub MergeDouble(ByVal itotalrow As Integer, ByVal initrow As Integer, ByVal intcol As Integer, ByVal basecol As Integer)
    574        oDocument.Tables(1).Cell(initrow + 1, intcol).Select()
    575        Dim irow As Integer      '当前行数
    576        Dim strValue As String   '循环比较的行初值
    577        Dim i As Integer
    578        Dim direction = Word.WdUnits.wdLine
    579        Dim extend = Word.WdMovementType.wdExtend
    580
    581        i = 0
    582        irow = 1 + initrow '初始值为1
    583        For i = 2 + initrow To itotalrow + initrow
    584
    585            strValue = oDocument.Tables(1).Cell(irow, intcol).Range.Text
    586            If (oDocument.Tables(1).Cell(i, intcol).Range.Text = oDocument.Tables(1).Cell(irow, intcol).Range.Text) And (getdata(i, basecol) = getdata(irow, basecol)) Then
    587                '这是对最后一次处理的特殊情况.
    588                If (i = itotalrow + initrow) Then
    589                    oWordApplic.Selection.MoveDown(direction, (i - irow), extend)
    590                    If (i - irow >= 1) Then
    591                        oWordApplic.Selection.Cells.Merge()
    592                    End If
    593                    oDocument.Tables(1).Cell(irow, intcol).Range.Text = strValue
    594                End If
    595            Else
    596                oWordApplic.Selection.MoveDown(direction, (i - irow - 1), extend)
    597                If (i - irow - 1 >= 1) Then
    598                    oWordApplic.Selection.Cells.Merge()
    599                End If
    600                oDocument.Tables(1).Cell(irow, intcol).Range.Text = strValue
    601                irow = i
    602                oDocument.Tables(1).Cell(irow, intcol).Select()
    603            End If
    604        Next i
    605    End Sub
    606    '得到某个单元的值,如果为空的话,有两种情况.
    607    '其一:是一个合并的单元格,取其上面的值
    608    '其二:该单元格本来就是空值
    609    Public Function getdata(ByVal introw As Integer, ByVal intcol As Integer) As String
    610        Try
    611            If (oDocument.Tables(1).Cell(introw, intcol).Range.Text = "" Or (oDocument.Tables(1).Cell(introw, intcol).Range.Text = Nothing)) Then
    612                getdata = getdata(introw - 1, intcol)
    613            Else
    614                getdata = oDocument.Tables(1).Cell(introw, intcol).Range.Text
    615            End If
    616        Catch ex As Exception
    617            getdata = getdata(introw - 1, intcol)
    618        End Try
    619
    620
    621    End Function
    622End Class
    623

    转载于:https://www.cnblogs.com/aloha/archive/2008/08/27/1277317.html

    展开全文
  • Section or row ...REF:http://www.helpdoc-online.com/Microsoft_Visio_2002_Developing_Solutions_en/Section_Row_and_Cell_Indices_Shapes.htm 转载于:https://www.cnblogs.com/xiyoulhj/p/4248092.html

    Section or row

    Cell

    Section index

    Row index

    Cell index

    <no name>1

    HelpTopic
    Copyright2

    visSectionObject

    visRowHelpCopyright

    visObjHelp
    visCopyright

    1-D Endpoints
    section3

    BeginX
    BeginY
    EndX
    EndY

    visSectionObject

    visRowXForm1D

    vis1DBeginX
    vis1DBeginY
    vis1DEndX
    vis1DEndY

    Actions
    section

    Actions.Action[i]
    Actions.Menu[i]
    Actions.Ci
    Actions.Di

    visSectionAction

    visRowAction + i

    visActionAction
    visActionMenuvisActionChecked
    visActionDisabled

    Alignment
    section4

    AlignLeft
    AlignCenter
    AlignRight
    AlignTop
    AlignMiddle
    AlignBottom

    visSectionObject

    visRowAlign

    visAlignLeft
    visAlignCenter
    visAlignRight
    visAlignTop
    visAlignMiddle
    visAlignBottom

    Character
    section

    Char.Font[i]
    Char.Size[i]
    Char.FontScale[i]
    Char.Letterspace[i]
    Char.Color[i]
    Char.Style[i]
    Char.Case[i]
    Char.Pos[i]
    Char.Strikethru[i]
    Char.DblUnderline[i]
    Char.Overline[i]
    Char.Perpendicular[i]
    Char.Locale[i]5
    Char.ColorTrans[i]

    visSectionCharacter

    visRowCharacter + i

    visCharacterFont
    visCharacterSize
    visCharacterFontScale
    visCharacterLetterspace
    visCharacterColor
    visCharacterStyle
    visCharacterCase
    visCharacterPos
    visCharacterStrikethru
    visCharacterDblUnderline
    visCharacterOverline
    visCharacterPerpendicular
    visCharacterLocale
    visCharacterColorTrans

    Connection
    Points
    section
    (non-extended row6)

    Connections.Xi
    Connections.Yi
    Connections.DirX[i]
    Connections.DirY[i]
    Connections.Type[i]
    Connections.AutoGen[i]

    visSectionConnectionPts

    visRowConnectionPts + i

    visCnnctX
    visCnnctY
    visCnnctDirX
    visCnnctDirY
    visCnnctType
    visCnnctAutoGen

    Connection
    Points
    section
    (extended row7)

    Connections.Xi
    Connections.Yi
    Connections.Ai
    Connections.Bi
    Connections.Ci
    Connections.Di

    visSectionConnectionPts

    visRowConnectionPts + i

    visCnnctX
    visCnnctY
    visCnnctA
    visCnnctB
    visCnnctC
    visCnnctD

    Controls
    section

    Controls.Xi
    Controls.Yi
    Controls.XDyn[i]
    Controls.YDyn[i]
    Controls.XCon[i]
    Controls.YCon[i]
    Controls.CanGlue[i]
    Controls.Prompt[i]8

    visSectionControls

    visRowControl + i

    visCtlX
    visCtlY
    visCtlXDyn
    visCtlYDyn
    visCtlXCon
    visCtlYCon
    visCtlGlue
    visCtlTip

    Custom
    Properties
    section

    Prop.Name.Label
    Prop.Name.Prompt
    Prop.Name.SortKey
    Prop.Name.Type
    Prop.Name.Format
    Prop.Name.Value9
    Prop.Name.Invisible
    Prop.Name.Verify

    visSectionProp

    visRowProp + i

    visCustPropsLabel
    visCustPropsPrompt
    visCustPropsSortKey
    visCustPropsType
    visCustPropsFormat
    visCustPropsValue
    visCustPropsInvis
    visCustPropsAsk

    Events section

    TheData10
    TheText
    EventDblClick
    EventXFMod
    EventDrop

    visSectionObject

    visRowEvent

    visEvtCellTheData
    visEvtCellTheText
    visEvtCellDblClick
    visEvtCellXFMod
    visEvtCellDrop

    Fill Format section

    FillBkgnd
    FillPattern
    FillForegnd
    ShdwBkgnd
    ShdwPattern
    ShdwForegnd
    FillForegndTrans
    FillBkgndTrans
    ShdwForegndTrans
    ShdwBkgndTrans

    visSectionObject

    visRowFill

    visFillBkgnd
    visFillPattern
    visFillForegnd
    visFillShdwBkgnd
    visFillShdwPattern
    visFillShdwForegnd
    visFillForegndTrans
    visFillBkgndTrans
    visFillShdwForegndTrans
    visFillShdwBkgndTrans

    Foreign Image Info section11

    ImgWidth
    ImgHeight
    ImgOffsetY
    ImgOffsetX

    visSectionObject

    visRowForeign

    visFrgnImgWidth
    visFrgnImgHeight
    visFrgnImgOffsetY
    visFrgnImgOffsetX

    Geometryisection

    Geometryi.NoFill
    Geometryi.NoLine
    Geometryi.NoShow
    Geometryi.NoSnap

    VisSectionFirstComponent + i

    visRowComponent

    visCompNoFill
    visCompNoLine
    visCompNoShow
    visCompNoSnap

    MoveTo row
    (in Geometryisection)

    Geometryi.Xj
    Geometryi.Yj

     

    visRowVertex + j

    visX
    visY

    LineTo row
    (in Geometryisection)

    Geometryi.Xj
    Geometryi.Yj

     

    visRowVertex + j

    visX
    visY

    ArcTo row
    (in Geometryisection)

    Geometryi.Xj
    Geometryi.Yj
    Geometryi.Aj

     

    visRowVertex + j

    visX
    visY
    visBow

    EllipticalArcTo row
    (in Geometryisection)

    Geometryi.Xj
    Geometryi.Yj
    Geometryi.Aj
    Geometryi.Bj
    Geometryi.Cj
    Geometryi.Dj

     

    visRowVertex + j

    visX
    visY
    visControlX
    visControlY
    visEccentricityAngle
    visAspectRatio

    PolylineTo row
    (in Geometryisection)

    Geometryi.Xj
    Geometryi.Yj
    Geometryi.Aj

     

    visRowVertex + j

    visX
    visY
    visPolylineData

    NURBSTo row
    (in Geometryisection)

    Geometryi.Xj
    Geometryi.Yj
    Geometryi.Aj
    Geometryi.Bj
    Geometryi.Cj
    Geometryi.Dj
    Geometryi.Ej

     

    visRowVertex + j

    visX
    visY
    visNURBSKnot
    visNURBSWeight
    visNURBSKnotPrev
    visNURBSWeightPrev
    visNURBSData

    SplineStart row (in Geometryisection)

    Geometryi.Xj
    Geometryi.Yj
    Geometryi.Aj
    Geometryi.Bj
    Geometryi.Cj
    Geometryi.Dj

     

    visRowVertex + j

    visX
    visY
    visSplineKnot
    visSplineKnot2
    visSplineKnot3
    visSplineDegree

    SplineKnot row
    (in Geometryisection)

    Geometryi.Xj
    Geometryi.Yj
    Geometryi.Aj

     

    visRowVertex + j

    visX
    visY
    visSplineKnot

    InfiniteLine row
    (in Geometryisection)

    Geometryi.X1
    Geometryi.Y1
    Geometryi.A1
    Geometryi.B1

     

    visRowVertex

    visInfiniteLineX1
    visInfiniteLineY1
    visInfiniteLineX2
    visInfiniteLineY2

    Ellipse row
    (in Geometryisection)

    Geometryi.X1
    Geometryi.Y1
    Geometryi.A1
    Geometryi.B1
    Geometryi.C1
    Geometryi.D1

     

    visRowVertex

    visEllipseCenterX
    visEllipseCenterY
    visEllipseMajorX
    visEllipseMajorY
    visEllipseMinorX
    visEllipseMinorY

    Glue Info section

    GlueType
    WalkPreference
    BegTrigger
    EndTrigger

    visSectionObject

    visRowMisc

    visGlueType
    visWalkPref
    visBegTrigger
    visEndTrigger

    Group Properties section12

    SelectMode
    DisplayMode
    IsTextEditTarget
    IsSnapTarget
    IsDropTarget
    DontMoveChildren

    visSectionObject

    visRowGroup

    visGroupSelectMode
    visGroupDisplayMode
    visGroupIsTextEditTarget
    visGroupIsSnapTarget
    visGroupIsDropTarget
    visGroupDontMoveChildren

    HyperLinks section

    Hyperlink.Name.Description
    Hyperlink.Name.Address
    Hyperlink.Name.SubAddress
    Hyperlink.Name.ExtraInfo
    Hyperlink.Name.Frame
    Hyperlink.Name.NewWindow
    Hyperlink.Name.Default

    visSectionHyperlink

    visRow1stHyperlink +i

    visHLinkDescription
    visHLinkAddress
    visHLinkSubAddress
    visHLinkExtraInfo
    visHLinkFrame
    visHLinkNewWin
    visHLinkDefault

    Image Properties section13

    Contrast
    Brightness
    Gamma
    Blur
    Sharpen
    Denoise
    Transparency

    visSectionObject

    visRowImage

    visImageContrast
    visImageBrightness
    visImageGamma
    visImageBlur
    visImageSharpen
    visImageDenoise
    visImageTransparency

    Layer Membership section

    LayerMember

    visSectionObject

    visRowLayerMem

    visLayerMember

    Line Format section

    LineWeight
    LineColor
    LinePattern
    BeginArrow
    EndArrow
    LineCap
    BeginArrowSize
    EndArrowSize
    Rounding
    LineColorTrans

    visSectionObject

    visRowLine

    visLineWeight
    visLineColor
    visLinePattern
    visLineBeginArrow
    visLineEndArrow
    visLineEndCap
    visLineBeginArrowSize
    visLineEndArrowSize
    visLineRounding
    visLineColorTrans

    Miscellaneous section

    NoObjHandles
    NonPrinting
    NoCtlHandles
    NoAlignBox
    UpdateAlignBox
    HideText
    ObjType
    DynFeedback
    NoLiveDynamic
    IsDropSource
    Comment

    visSectionObject

    visRowMisc

    visNoObjHandles
    visNonPrinting
    visNoCtlHandles
    visNoAlignBox
    visUpdateAlignBox
    visHideText
    visLOFlags
    visDynFeedback
    visNoLiveDynamics
    visDropSource
    visComment

    Paragraph section

    Para.IndFirst[i]
    Para.IndLeft[i]
    Para.IndRight[i]
    Para.SpLine[i]
    Para.SpBefore[i]
    Para.SpAfter[i]
    Para.HorzAlign[i]
    Para.Bullet[i]
    Para.BulletStr[i]

    visSectionParagraph

    visRowParagraph + i

    visIndentFirst
    visIndentLeft
    visIndentRight
    visSpaceLine
    visSpaceBefore
    visSpaceAfter
    visHorzAlign
    visBulletIndex
    visBulletString

    Protection section

    LockWidth
    LockHeight
    LockMoveX
    LockMoveY
    LockAspect
    LockDelete
    LockBegin
    LockEnd
    LockRotate
    LockCrop
    LockVtxEdit
    LockTextEdit
    LockFormat
    LockGroup
    LockCalcWH
    LockSelect

    visSectionObject

    visRowLock

    visLockWidth
    visLockHeight
    visLockMoveX
    visLockMoveY
    visLockAspect
    visLockDelete
    visLockBegin
    visLockEnd
    visLockRotate
    visLockCrop
    visLockVtxEdit
    visLockTextEdit
    visLockFormat
    visLockGroup
    visLockCalcWH
    visLockSelect

    Scratch section

    Scratch.Xi
    Scratch.Yi
    Scratch.Ai
    Scratch.Bi
    Scratch.Ci
    Scratch.Di

    visSectionScratch

    visRowScratch + i

    visScratchX
    visScratchY
    visScratchA
    visScratchB
    visScratchC
    visScratchD

    Shape Layout section

    ShapePermeableX
    ShapePermeableY
    ShapePermeablePlace
    ShapeFixedCode
    ShapePlowCode
    ShapeRouteStyle
    ConLineJumpDirX
    ConLineJumpDirY
    ConFixedCode
    ConLineJumpCode
    ConLineJumpStyle
    ShapePlaceFlip
    ConLineRouteExt

    visSectionObject

    visRowShapeLayout

    visSLOPermX
    visSLOPermY
    visSLOPermeablePlace
    visSLOFixedCode
    visSLOPlowCode
    visSLORouteSyle
    visSLOJumpDirX
    visSLOJumpDirY
    visSLOConFixedCode
    visSLOJumpCode
    visSLOJumpStyle
    visSLOPlaceFlip
    visSLOLineRouteExt

    Shape Transform section

    PinX
    PinY
    Width
    Height
    LocPinX
    LocPinY
    Angle
    FlipX
    FlipY
    ResizeMode

    visSectionObject

    visRowXFormOut

    visXFormPinX
    visXFormPinY
    visXFormWidth
    visXFormHeight
    visXFormLocPinX
    visXFormLocPinY
    visXFormAngle
    visXFormFlipX
    visXFormFlipY
    visXFormResizeMode

    Tabs section

    Tabs.ci14
    Tabs.ci14

    visSectionTab

    visRowTab + i

    visTabStopCount5
    (j*3) + visTabPos15
    (j*3) + visTabAlign15

    Text Block Format section

    VerticalAlign
    TopMargin
    BottomMargin
    LeftMargin
    RightMargin
    TextBkgnd
    TextDirection
    DefaultTabStop
    TextBkgndTrans

    visSectionObject

    visRowText

    visTxtBlkVerticalAlign
    visTxtBlkTopMargin
    visTxtBlkBottomMargin
    visTxtBlkLeftMargin
    visTxtBlkRightMargin
    visTxtBlkBkgnd
    visTxtBlkDirection
    visTxtBlkDefaultTabStop
    visTxtBlkBkgndTrans

    Text Fields section16

    Fields.Type[i]
    Fields.Format[i]
    Fields.Value[i]
    Fields.EditMode[i]
    Fields.UICat[i]
    Fields.UICod[i]
    Fields.UIFmt[i]

    visSectionTextField

    visRowField + i

    visFieldType
    visFieldFormat
    visFieldCell
    visFieldEditMode
    visFieldUICategory
    visFieldUICode
    visFieldUIFormat

    Text Transform section

    TxtPinX
    TxtPinY
    TxtWidth
    TxtHeight
    TxtLocPinX
    TxtLocPinY
    TxtAngle

    visSectionObject

    visRowTextXForm

    visXFormPinX
    visXFormPinY
    visXFormWidth
    visXFormHeight
    visXFormLocPinX
    visXFormLocPinY
    visXFormAngle

    User-Defined Cells section

    User.Name.Value9
    User.Name.Prompt

    visSectionUser

    visRowUser + i

    visUserValue
    visUserPrompt

     

    REF:http://www.helpdoc-online.com/Microsoft_Visio_2002_Developing_Solutions_en/Section_Row_and_Cell_Indices_Shapes.htm

    转载于:https://www.cnblogs.com/xiyoulhj/p/4248092.html

    展开全文
  • newChar.word = oSlide.Shapes.Item(1).TextFrame.TextRange.Text Call searchWordFromBaidu(newChar.word, newChar.trans, newChar.phonetic) oSlide.Shapes.Item(2).TextFrame.TextRange.Text = newChar.trans...

    做英语培训,需要对PPT的每一页的单词进行自动查询音标和翻译,简化劳动

    Private Type Character

        word As String
        trans As String
        phonetic As String
    End Type




    Sub getTitles()
    Dim newChar As Character
    Dim oPres As Presentation
    Set oPres = Application.ActivePresentation
    Dim oSlide As Slide
    Dim oShape As Shape
    Dim sTitle As String
    Dim sText As String
    Dim i As Long, j As Long
    '循环每页幻灯
    For i = 2 To oPres.Slides.Count
    Set oSlide = oPres.Slides.Item(i)
    'oSlide.Shapes.Count
    newChar.word = oSlide.Shapes.Item(1).TextFrame.TextRange.Text
    Call searchWordFromBaidu(newChar.word, newChar.trans, newChar.phonetic)
    oSlide.Shapes.Item(2).TextFrame.TextRange.Text = newChar.trans
    Next
    End Sub




    '单词音译写入Excel
    Sub WriteVocabulary()
        Dim iZidian As Integer
        Dim newChar As Character
        Dim R As Range
        Dim rr, dd As Integer


        'strTags = ActiveSheet.Name
        Sheet1.Activate
        ActiveSheet.Names.Add Name:="NewWord", RefersTo:="=OFFSET($A$1,0,0,COUNTA($A:$A))"
        Set R = ActiveSheet.Names("NewWord").RefersToRange
        Sheet1.Cells(1, 6).Value = ""
        dd = R.Count - 1
        
        'rr = 0
        
        'For Each Row In R.Rows
        For rr = 2 To dd + 1
            'rr = rr + 1
            'newChar.word = Trim(Row(1))
            newChar.word = R(rr)
            Select Case iZidian
            Case 1
                Call searchWordFromYoudao(newChar.word, newChar.trans, newChar.phonetic)
            Case 2
                Call searchWordFromBaidu(newChar.word, newChar.trans, newChar.phonetic)
            Case 3
                Call searchWordFromBing(newChar.word, newChar.trans, newChar.phonetic)
            Case 4
                Call searchWordFromCiba(newChar.word, newChar.trans, newChar.phonetic)
            Case Else
                Call searchWordFromYoudao(newChar.word, newChar.trans, newChar.phonetic)
            End Select
            On Error Resume Next
            Sheet1.Cells(rr, 2).Value = newChar.phonetic  '音标
            Sheet1.Cells(rr, 3).Value = newChar.trans     '中文含义
            Sheet1.Cells(1, 6).Value = rr - 1 & "/" & dd
        'Next Row
        Next rr
    End Sub
    Sub searchWordFromYoudao(tmpWord As String, tmpTrans As String, tmpPhonetic As String)
        'http://dict.youdao.com/search?q=单词&keyfrom=dict.index
            Dim XH As Object
            Dim s() As String
            Dim str_tmp As String
            Dim str_base As String
            
            tmpTrans = ""
            tmpPhonetic = ""


            '开启网页
            Set XH = CreateObject("Microsoft.XMLHTTP")
            On Error Resume Next
            XH.Open "get", "http://dict.youdao.com/search?q=" & tmpWord & "&keyfrom=dict.index", False
            XH.send
            On Error Resume Next
            str_base = XH.responseText
            XH.Close
            Set XH = Nothing
            ttt = str_base
            
            yb = Split(Split(str_base, "<div id=""webTrans"" class=""trans-wrapper trans-tab"">")(0), "<span class=""keyword"">")(1)


            '取音标
            If UBound(Split(yb, "<span class=""pronounce"">美")) = 1 Then
            '美式音标
                tmpPhonetic = Split((Split(Split(yb, "<span class=""pronounce"">美")(1), "<span class=""phonetic"">")(1)), "</span>")(0)
                On Error Resume Next
            Else
                tmpPhonetic = Split((Split(yb, "<span class=""phonetic"">")(1)), "</span>")(0)
                On Error Resume Next
            End If


            '取中文翻译
            str_tmp = Split((Split(yb, "<div class=""trans-container"">")(1)), "</div>")(0)
            str_tmp = Split((Split(str_tmp, "<ul>")(1)), "</ul>")(0)
            s = Split(str_tmp, "<li>")
            tmpTrans = Split(s(LBound(s) + 1), "</li")(0)
            For i = LBound(s) + 2 To UBound(s)
                tmpTrans = tmpTrans & Chr(10) & Split(s(i), "</li")(0)
            Next
        End Sub




    Sub searchWordFromBaidu(tmpWord As String, tmpTrans As String, tmpPhonetic As String)
            'http://dict.baidu.com/s?wd=单词
            Dim XH As Object
            Dim s() As String
            Dim str_tmp As String
            Dim str_base As String
            
            tmpTrans = ""
            tmpPhonetic = ""


            '开启网页
            Set XH = CreateObject("Microsoft.XMLHTTP")
            On Error Resume Next
            XH.Open "get", "http://dict.baidu.com/s?wd=" & tmpWord, True
            XH.send (Null)
            On Error Resume Next
            While XH.ReadyState <> 4
                DoEvents
            Wend
            str_base = XH.responseText
            XH.Close
            Set XH = Nothing
                '取得音标部分
                yb = Split(Split(str_base, "<div id=""pronounce"">")(1), "</div>")(0)
                t1 = yb
                '取得中文含义部分
                'hy = Split(Split(tmpstr, "<div class=""tab en-simple-means dict-en-simplemeans-english"" id=""en-simple-means""> <div>")(1), "<p><span>易混淆的单词:")(0)
                hy = Split(Split(str_base, "<div class=""tab en-simple-means dict-en-simplemeans-english"" id=""en-simple-means""> <div>")(1), "以下结果由")(0)
                hy = Split(hy, "易混淆的单词")(0)
                t2 = hy
                '对音标部分进行分解,分别取得英国和美国音标
                yb = Split(yb, "<span>")
                ybEN = Split(yb(1), "<b lang=""EN-US"" xml:lang=""EN-US"">")    '英国音标
                ybEN = ybEN(0) & Split(ybEN(1), "</b>")(0)
                ybUS = Split(yb(2), "<b lang=""EN-US"" xml:lang=""EN-US"">")    '美国音标
                ybUS = ybUS(0) & Split(ybUS(1), "</b>")(0)
            tmpPhonetic = ybEN & ybUS
            
            '对中文含义把全部html标记删除,得到纯净的中文含义
            tmpTrans = DelHtml(hy)
    End Sub


    Sub searchWordFromBing(tmpWord As String, tmpTrans As String, tmpPhonetic As String)
        'http://cn.bing.com/dict/search?q=about+to&go=%E6%8F%90%E4%BA%A4&qs=bs&form=CM
        'http://cn.bing.com/dict/search?q=about+to&go=提交&qs=bs&form=CM
            Dim XH As Object
            Dim s() As String
            Dim str_tmp As String
            Dim str_base As String
            
            tmpTrans = ""
            tmpPhonetic = ""
                Dim url As String
                tmpWord = Replace(tmpWord, " ", "+")
                url = "http://cn.bing.com/dict/search?q=" & tmpWord & "&go=%E6%8F%90%E4%BA%A4&qs=bs&form=CM"


            '开启网页
            Set XH = CreateObject("Microsoft.XMLHTTP")
            On Error Resume Next
            XH.Open "get", url, True
            XH.send (Null)
            On Error Resume Next
            While XH.ReadyState <> 4
                DoEvents
            Wend
            str_base = XH.responseText
            XH.Close
            Set XH = Nothing
                '==第一种分解法========================
                '取得音标部分
                yb = Split(Split(str_base, "<div class=""hd_prUS"">")(1), "<span class=""pos"">")(0)
                '取得中文含义部分
                hy = Split(str_base, "<div class=""hd_div1"">")(0)


                hy = Split(hy, "<span class=""pos"">")
                '对音标部分进行分解,分别取得英国和美国音标
                yb = Split(yb, "<div class=""hd_pr"">")
                ybEN = DelHtml(Split(yb(0), "</div>")(0))
                ybUS = DelHtml(Split(yb(1), "</div>")(0))
                tmpPhonetic = ybEN & ybUS
                
                '对中文含义分解
                hytmp = ""
                For i = LBound(hy) + 1 To UBound(hy)
                    hytmp = hytmp & DelHtml(Split(hy(i), "</span></span>")(0)) & vbCrLf
                Next i
                If UBound(hy) = 0 Then hytmp = ""
                tmpTrans = hytmp
                'hy = Replace(hytmp, "网络", vbCrLf & "网络")
                '==========================
    End Sub


    Sub searchWordFromCiba(tmpWord As String, tmpTrans As String, tmpPhonetic As String)
        '"http://www.iciba.com/" & tmpWord
            Dim XH As Object
            Dim s() As String
            Dim str_tmp As String
            Dim str_base As String
            
            tmpTrans = ""
            tmpPhonetic = ""
                
            Dim url As String
            tmpWord = Replace(tmpWord, " ", "_")
            url = "http://www.iciba.com/" & tmpWord


            '开启网页
            Set XH = CreateObject("Microsoft.XMLHTTP")
            On Error Resume Next
            XH.Open "get", url, True
            XH.send (Null)
            On Error Resume Next
            While XH.ReadyState <> 4
                DoEvents
            Wend
            str_base = XH.responseText
            XH.Close
            Set XH = Nothing
            
                '取得音标部分
            yb = Split(Split(str_base, "<div class=""prons"">")(1), "<div class=""group_prons"">")(0)
                '取得中文含义部分
            hy = Split(Split(str_base, "<div class=""group_prons"">")(1), "</div>")(0)
                '对音标部分进行分解,分别取得英国和美国音标
        
            yb = Split(yb, "<span class=""eg"">")
            ybEN = DelHtml(Split(yb(1), "</div>")(0))
            ybUS = DelHtml(Split(yb(2), "</div>")(0))
            tmpPhonetic = ybEN & ybUS


                 '对中文含义分解
            tmpTrans = DelHtml(hy)
            
    End Sub


    Function DelHtml(strh)
        Dim A As String
        Dim RegEx As Object
        'Dim mMatch As Match
        'Dim Matches As matchcollection
        
        A = strh
        A = Replace(A, Chr(13) & Chr(10), "")
    '    A = Replace(A, Chr(32), "")
        A = Replace(A, Chr(9), "")
        A = Replace(A, "</p>", vbCrLf)   '给段落后加上回车
        Set RegEx = CreateObject("vbscript.regexp")    '引入正则表达式
        With RegEx
            .Global = True
            .Pattern = "\<[^<>]*?\>"   '用<>括起来的html符号
            .MultiLine = True  '多行有效
            .ignorecase = True  '忽略大小写(网页处理时这个参数比较重要)
            A = .Replace(A, "")   '将html符号全部替换为空
        End With
        A = Trim(A)
        '特殊符号处理
        
        A = Replace(A, "&lt;", "<")
        A = Replace(A, "&gt;", ">")
        A = Replace(A, "&amp;", "&")
        A = Replace(A, "&quot;", "\")
        A = Replace(A, "&-->", vbCrLf)
        A = Replace(A, "&#230;", ChrW(230)) '&#230;
        A = Replace(A, "&#160;", ChrW(160)) '&#160;
        A = Replace(A, "&nbsp;", " ")  '&nbsp;?
        DelHtml = A
    End Function















    展开全文
  • 先展示下今天做的效果 按钮1:绑定start1() 按钮2:绑定stop1() 文字旋转效果 图形,形变,变色,旋转效果 四角星是插入的图形,文字是插入的艺术...Set p1 = Worksheets("sheet1").Shapes(1) Set p2 = Workshe...
  • 因为之前木有这个问题的  重装了下Office就出现这个问题了 百度木有百到 然后看到一位仁兄这样说: 我想是不是微软不给力 需要打补丁 于是安装了下面补丁 果然好了:
  • ActiveSheet.Shapes.AddChart.Select[color=#FF0000] 这句经常任打开了一个其他的EXCEL文件时,再执行下面代码都会报错91 对象变量或with块变量未设置错误[/color] Private Sub test() Dim i As Integer Set ...
  • 在前面的例子里,你学习使用了Excel对象库里的Shapes(图形)集合成员的属性。Excel库包含专门使用Excel的对象,而VBA库则提供对许多内置VBA函数的访问,这些函数按类别分组。这些函数是通用的,它们使你能够管理文件...
  • Excel VBA-批量导出图片.vba

    千次阅读 2018-10-24 10:53:50
    'r,c 图片所在单元格的偏移量,用来做图片的名字 Sub exportPic() r = 0 c = -2 For i = 1 To ActiveSheet.Shapes.Count ActiveSheet.Shapes(i).... Name = Range(ActiveSheet.Shapes(i).TopLeftCell.Address).Of...
  • Sub test() Dim st As Worksheet, sp As Shape For Each st In ThisWorkbook.Worksheets For Each sp In st.Shapes sp.PictureFormat.TransparencyColor = RGB(255, 255, 255) Next Next End Sub
  • 图片切换 Sub 显示开或关) If ActiveSheet.Shapes"Picture 2.Visible = True Then ActiveSheet.Shapes"Picture 1.Visible = True ActiveSheet.Shapes"Picture 2.Visible = False Else ActiveSheet.Shapes"Picture 2....
  • VBA之批量导出图片

    2021-03-18 17:00:00
    `Sub Rename() Application.ScreenUpdating = False ...For Each pic In ActiveSheet.Shapes If pic.Type = msoPicture Then RN = pic.TopLeftCell.Offset(0, -1).Value '重命名图片 pic.Copy With ActiveShee
  • 'Shapes 对象'指定的工作表上的所有 Shape 对象的集合。'说明'每个 Shape 对象都代表绘图层中的一个对象,如自选图形、任意多边形、图片、图表等。 下列代码注意其属性即可 Sub 基本的属性() Dim ob As Shape ...
  • C# VBA 删除水印方法

    2021-02-08 09:18:06
    删除水印一般使用的是直接进入页眉视图,然后删除代码如下: ..._appWord.Selection.HeaderFooter.Shapes["PowerPlusWaterMarkObject53265"].Select(); _appWord.Selection.Delete(); _appWord.ActiveWindow.ActivePan
  • VBA是小型数据自动化处理的利器,提高自己,更有利于自己的职场生涯,全面掌握VBA要学习代码解决方案,掌握各个知识点,数据库是数据处理的利器,而要掌握精华部分必须要学习字典的利用。361 ActiveSheet.Shapes....
  • Vba Word Shape&TextBox

    2020-06-29 23:44:47
    因为Word里面不一定全部包含在Application Content里面,有些TEXT是存在在TextBox,而TextBox属于Shape,所以可以循环获取... For Each Shp In ThisDocument.Shapes Debug.Print Shp.TextFrame.TextRange.Text ...
  • VBA导出Excel图片

    千次阅读 2014-11-13 22:11:36
    Excel文档里面的图片都是Shape对象,遍历ActiveSheet的Shapes集合;将对应的Shape对象,设置到临时变量中;在当前的Sheet里面添加ChartObject对象,并用前面取到的Shape的宽和高设置ChartObject对象的区域大小;调用...
  • vba写如下代码: Public Sub Test() Dim str1 As String str1 = "@type='" & "rectangle" & "'" Application.ActivePage.Shapes.FindShapes("", 0, False, str1).CreateSelection End Sub [bool ...
  • 一些PPT VBA语言的收集

    2013-06-07 20:51:20
    http://www.fanhow.com/knowhow:Use_VBA_to_Resize_Multiple_Shapes_in_Microsoft_PowerPoint_42667983 2. Re: Autopaste And Autosize Table In Powerpoint From Clipboard 3. 将一个图像的大小和位置...
  • Microsoft Excel VBA Examples

    千次阅读 2005-09-19 00:11:00
    Send Outlook Mail Message: This sub sends an Outlook mail message from Excel.... & Name of Shapes: To show the index number (ZOrderPosition) and name of all shapes on a worksheet. Create
  • vba学习笔记——图像

    2017-06-01 20:20:22
    1.图形/图片  With ActiveSheet.Shapes.Range(Array("Rectangle 1")) '图片对象   .Width '宽  .Height '高  .Left '左  .Top '上
  • WORD VBA 操作WORD 文本框

    千次阅读 2015-05-17 18:37:14
    '实例1:批量删除WORD文本框中的内容 Sub test1() Dim sha As Shape For Each sha In ActiveDocument.Shapes sha.TextFrame.TextRange.Delete Next end sub '实例2:批量删除WORD文本框而保留文字
  • Shapes对象是指定工作表上的所有Shape对象的集合。 使用Shapes属性可返回Shapes集合 Worksheets(1).Shapes.SelectAll ' ↑ 选定工作表一上的所有形状。 使用Shapes(index)可返回一个Shape对象。index...
  • Sheet1.Shapes("PIC").CopyPicture ‘对图形命名为PIC,也可以用序号调用Shapes(1) With Sheet1.ChartObjects.Add(0, 0, Sheet1.Shapes("PIC").Width, Sheet1.Shapes("PIC").Height).Chart .Paste .Export ...
  • 学习Excel技术,关注微信公众号:excelperfect下面的自定义函数使用Shapes集合对象的AddShape方法及其参数,可以在指定的单元格中插入指定的形状。Function AddShapeToRange( _ ShapeType As MsoAutoShapeType, _ ...
  • 例:VBA获取shape position Public Sub LocationTable() 'This routine will create a text file of the location and size of all 2-d shapes ' on the current page Dim shpObj As Visio.Shap...
  • VBA 插入图片以及对图片进行裁切及位置移动 Set shp = Sheet1.Shapes.AddPicture("路径", msoFalse, msoCTrue, 0, 0, -1, -1) With shp .PictureFormat.CropTop = mTop '下移裁剪 .PictureFormat.CropLeft = m...
  • VBA Excel中绘制箭头

    2013-04-28 22:40:00
    With ActiveSheet.Shapes.AddLine(Cells(2, 3).Left, Cells(2, 3).Top, Cells(4, 5).Left, Cells(4, 5).Top) .Line.EndArrowheadStyle = msoArrowheadTriangle .Line.EndArrowheadLength = msoArrowhead...
  • 关于vba条件删除图片

    2012-07-24 08:14:10
    保留Ole控件对象,删除其他所有 Private Sub CommandButton3_Click() ...For Each shp In ActiveSheet.Shapes If shp.Type = msoOLEControlObject Then Else shp.Delete End If Next shp En...
  • Sub hong3()'' 宏3 宏d Dim a, b As Integer Dim str As String For a = 227 To 947 Step 15 b = a + 5 str = "Sheet1!B" + CStr(a) + ":G" + CStr(b) sh = ActiveSheet.Shapes.AddChar...

空空如也

空空如也

1 2 3 4 5 6
收藏数 108
精华内容 43
关键字:

shapesvba