常用代码归集

jiminyanyan

作个WORD文档整理一下，好一些…………

sunxh

建议楼主上传附件，谢谢！

jsgj2023

Sub 同兴结算平台型号整理()
    Dim ws  As Worksheet, d As Object, L%, x&, y&, c&, r&
    If MsgBox("请确保活动工作表第一行存在“商品名称”关键字。", vbYesNo + vbQuestion + vbDefaultButton1) = vbYes Then
        GoTo 100
    Else
        Exit Sub
    End If
100:
    On Error GoTo 1000
    L = Application.InputBox("请选择商品名称所在的列", "温馨提示", Type:=8).Column
    On Error GoTo 0
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    With GetObject("C:\Users\Administrator\AppData\Roaming\Microsoft\AddIns" & "\单品名称和型号标准数据表.xlsx")
        arr = .Sheets("同兴结算系统型号提取-字典法").[a1].CurrentRegion
        .Close False
    End With
    For x = 2 To UBound(arr)
        If Not d.exists(arr(x, 1)) Then
            d(arr(x, 1)) = Array(arr(x, 2), arr(x, 3))
        End If
    Next x
    Set ws = ActiveSheet
    With ws
        c = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
        r = .Cells(Rows.Count, L).End(3).Row
        brr = Range(Cells(1, L), Cells(r, L))
        For y = 2 To UBound(brr)
            If d.exists(brr(y, 1)) Then
                sss = d(brr(y, 1))
                Cells(y, c).Resize(1, 2) = d(brr(y, 1))
            End If
        Next y
    End With
1000:
Set d = Nothing
Application.ScreenUpdating = True
End Sub

jsgj2023

Sub 将表格中的图表制作为幻灯片()
    Dim ws As Worksheet
    Dim pptApp As PowerPoint.Application
    Dim pptPrs As PowerPoint.Presentation
    Dim i As Long
    Dim myppt As String
    myppt = ThisWorkbook.Path & "\PowerPoint试验.ppt"
    Set ws = Worksheets(1)    '指定工作表
    ws.ChartObjects(1).Copy    '复制指定的图表
    Set pptApp = New PowerPoint.Application
    pptApp.Visible = True
    Set pptPrs = pptApp.Presentations.Open(myppt)    '打开PowerPoint文档
    With pptPrs    '在文档最后插入一个新幻灯片,并粘贴图表
        .Slides.Add(Index:=.Slides.Count + 1, Layout:=ppLayoutText).Shapes.Paste
        .Save
'        .Close         '设置此语句可关闭创建的文档
    End With
'    pptApp.Quit       '设置此语句可关闭PowerPoint应用程序
    Set ws = Nothing
    Set pptPrs = Nothing
    Set pptApp = Nothing
End Sub

jsgj2023

Sub 发送邮件()
    Dim n As Integer, i As Integer
    Dim ws As Worksheet
    Dim OutlookApp As Outlook.Application
    Dim newMail As Outlook.MailItem
    Set OutlookApp = New Outlook.Application
    Set ws = Worksheets("sheet1")
    n = ws.Range("A65536").End(xlUp).Row
    For i = 2 To n
       Set newMail = OutlookApp.CreateItem(olMailItem)    '创建新邮件
       With newMail
            .Subject = "实验"      '设置邮件主题
            .Body = "实验数据：" & ws.Range("B" & i)      '设置邮件正文
            .To = ws.Range("A" & i)       '设置收件人地址
            .Send        '开始发送
        End With
    Next i
    Set ws = Nothing
    Set newMail = Nothing
    Set OutlookApp = Nothing
End Sub

jsgj2023

Sub 邮件发送_2()
    Dim wbStr As String
    Dim OutlookApp As Outlook.Application
    Dim newMail As Outlook.MailItem
    Dim myAttachments As Outlook.Attachments
    Set OutlookApp = New Outlook.Application
    wbStr = ThisWorkbook.FullName    '指定要发送发工作簿名称字符串
    Set newMail = OutlookApp.CreateItem(olMailItem)    '创建新邮件
    With newMail
        .Subject = "附件实验"      '设置邮件主题
        .Body = "附件工作簿实验："     '设置邮件正文
        Set myAttachments = newMail.Attachments
        myAttachments.Add wbStr, olByValue, 1, "工作簿"
        .To = "1454870494@qq.com"       '设置收件人地址
        .Send        '开始发送
     End With
    Set newMail = Nothing
    Set myAttachments = Nothing
    Set OutlookApp = Nothing
End Sub

jsgj2023

Sub 判断shape对象的类型()
    Dim myType As String
    Dim myShape As Shape
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)    '指定工作表
    Set myShape = ws.Shapes(1)       '指定Shape对象
    With myShape
        Select Case .Type
            Case msoShapeTypeMixed
                myType = "混合型图形"
            Case msoAutoShape
                myType = "自选图形"
            Case msoCallout
                myType = "没有边框线的标注"
            Case msoChart
                myType = "图表"
            Case msoComment
                myType = "批注"
            Case msoFreeform
                myType = "任意多边形"
            Case msoGroup
                myType = "图形组合"
            Case msoFormControl
                myType = "窗体控件"
            Case msoLine
                myType = "线条"
            Case msoLinkedOLEObject
                myType = "链接式或内嵌OLE对象"
            Case msoLinkedPicture
                myType = "剪贴画或图片"
            Case msoOLEControlObject
                myType = "ActiveX 控件"
            Case msoPicture
                myType = "图片"
            Case msoTextEffect
                myType = "艺术字"
            Case msoTextBox
                myType = "文本框"
            Case msoDiagram
                myType = "组织结构图或其他图示"
            Case Else
                myType = "其他类型的图形"
        End Select
    End With
    MsgBox "该Shape对象的类型为：" & myType
    Set myShape = Nothing
    Set ws = Nothing
End Sub

jsgj2023

Sub 判断shape对象的名称()
    Dim myName As String
    Dim myShape As Shape
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)    '指定工作表
    Set myShape = ws.Shapes(2)       '指定Shape对象
    myName = myShape.Name
    MsgBox "该Shape对象的名称为：" & myName
    Set myShape = Nothing
    Set ws = Nothing
End Sub

jsgj2023

Sub 获取指定shape对象的标题文字内容()
    Dim myCaption As String
    Dim myShape As Shape
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)    '指定工作表
    Set myShape = ws.Shapes(2)       '指定Shape对象
    If myShape.Type = msoTextEffect Then
        myCaption = myShape.TextEffect.Text
    Else
        myCaption = myShape.TextFrame.Characters.Text
    End If
    MsgBox "该Shape对象的标题文字为：" & myCaption
    Set myShape = Nothing
    Set ws = Nothing
End Sub

jsgj2023

Sub 获取shape对象的高度和宽度()
    Dim myShape As Shape
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    Set myShape = ws.Shapes(2)
    MsgBox "该Shape对象的高度：" & myShape.Height & vbCrLf _
        & "该Shape对象的宽度：" & myShape.Width
    Set myShape = Nothing
    Set ws = Nothing
End Sub