Snasui Excel Forum

Code: Select all

Sub InsPic2()
    Const strPath As String = "C:\"
    Dim Imge, logopic As Object
    Dim ImgFileFormat As String
    Dim i As Integer
    Dim obj As Object

    For Each obj In ActiveSheet.Shapes
        If obj.Name = "picture 46" Then
            i = 1
        End If
    Next obj
    
    If i = 1 Then
        ActiveSheet.Unprotect Password:="1"
        Range("B1").Select
        ActiveSheet.Shapes("picture 46").Delete
        Range("B1").Select
    End If
    
    Call locksheet2
    Sheets("Logo2").Select
    ChDrive strPath
    ImgFileFormat = "Image Files (*.jpg*),*.jpg*"
    ImgFileFormat = ImgFileFormat & ",PNG Files (*.png*),*.png*"
    ImgFileFormat = ImgFileFormat & ",BMP Files (*.bmp*),*.bmp*"
    Imge = Application.GetOpenFilename(ImgFileFormat)
    
    If Imge <> "False" Then
        ActiveSheet.Unprotect Password:="1"
        Set logopic = ActiveSheet.Shapes.AddPicture(Filename:=Imge, linktofile:=msoFalse, savewithdocument:=msoCTrue, _
        Left:=Range("b1").Left, Top:=Range("b1").Top, Width:=-1, Height:=-1)
        With logopic
            .Name = "picture 46"
            .LockAspectRatio = msoTrue
            .Height = 117.75
            .Width = 66#
            .Rotation = 0#
            .IncrementLeft 3.75
            .IncrementTop 1.25
        End With
        Call locksheet2
    End If
End Sub

Code: Select all

'...other code...
        ImgFileFormat = "Image Files (*.jpg*),*.jpg*"
        ImgFileFormat = ImgFileFormat & ",PNG Files (*.png*),*.png*"
        ImgFileFormat = ImgFileFormat & ",BMP Files (*.bmp*),*.bmp*"
'...other code...

Code: Select all

Sub InsPic2()
    'Code From..
    'http://www.snasui.com/viewtopic.php?f=3&t=1768
    'http://www.mrexcel.com/archive/General/4711.html
    'http://www.ozgrid.com/forum/showthread.php?t=24068
   
    Const strPath As String = "D:\" '<== Change to your path
    Dim Imge
    Dim ImgFileFormat As String
    Dim i As Integer
    Dim obj As Object
    For Each obj In ActiveSheet.Shapes
        If obj.Name = "picture 46" Then
            i = 1
        End If
    Next obj
    If i = 1 Then
'        ChDrive strPath
        ChDir strPath
        ImgFileFormat = "Image Files (*.jpg),*.jpg"
        Imge = Application.GetOpenFilename(ImgFileFormat)
        If Imge <> "False" Then
            ActiveSheet.Unprotect Password = "1"
            ActiveSheet.Shapes("picture 46").Delete
            ActiveSheet.Pictures.Insert(Imge).Name = "picture 46"
            ActiveSheet.Protect Password = "1"
        End If
    End If
End Sub

Code: Select all

Sub InsPic2()
    'Code From..
    'http://www.snasui.com/viewtopic.php?f=3&t=1768
    'http://www.mrexcel.com/archive/General/4711.html
    'http://www.ozgrid.com/forum/showthread.php?t=24068
    
    Const strPath As String = "D:\" '<== Change to your path
    Dim Imge
    Dim ImgFileFormat As String
    Dim i As Integer
    Dim obj As Object
    For Each obj In ActiveSheet.Shapes
        If obj.Name = "picture 46" Then
            i = 1
        End If
    Next obj
    If i = 1 Then
'        ChDrive strPath
        ChDir strPath
        ImgFileFormat = "Image Files (*.jpg),*.jpg"
        Imge = Application.GetOpenFilename(ImgFileFormat)
        If Imge <> "False" Then
            ActiveSheet.Unprotect Password = "1"
            ActiveSheet.Shapes("picture 46").Delete
            ActiveSheet.Pictures.Insert(Imge).Name = "picture 46"
            ActiveSheet.Protect Password = "1"
        End If
    End If
End Sub

Code: Select all

ActiveSheet.Protect True, True, True, True, True

Code: Select all

Sub delpic()
' Macro001 Macro
' แมโครถูกบันทึก ณ วันที่ 25/10/2011 โดย หมู ภูดินแดง
    Dim i As Integer
    Dim obj As Object
    For Each obj In ActiveSheet.Shapes
        If obj.Name = "Picture 46" Then
            i = 1
        End If
    Next obj
    If i = 0 Then
        MsgBox "ไม่มีรูปให้ลบ"
        Exit Sub
    End If
    If MsgBox("คุณต้องการลบตราโรงเรียน?", 36, "ยืนยันการลบ") = 6 Then
        ActiveSheet.Shapes("Picture 46").Select
        Selection.Delete
'         Cancel = True
    End If
End Sub
Sub ChPic()
' Macro001 Macro
' แมโครถูกบันทึก ณ วันที่ 25/10/2011 โดย หมู ภูดินแดง
    Dim i As Integer
    Dim obj As Object
    For Each obj In ActiveSheet.Shapes
        If obj.Name = "Picture 46" Then
            i = 1
        End If
    Next obj
    If i = 1 Then
        Ans = MsgBox("มีรูปอยู่แล้วต้องการลบหรือไม่", vbYesNo)
    End If
    If Ans = vbYes Then
        ActiveSheet.Shapes("picture 46").Delete
    End If
    ActiveSheet.Pictures.Insert("C:\PP51\pic\pd.jpg").Name = "picture 46"
    ActiveSheet.Shapes("picture 46").Select
    Range("B1").Select
End Sub