excel dosyasına resim ekleme kod ilavesi hakkında

[mustilem23]

Merhaba arakadaşlar,

Ekte bulunan linkteki dosyamı müşterilerime ileteceğim ve müşteri pörtfeyim en alt seviyeden en üst seviye göre çok değişik insan gurupları mevcut pörtfeyde ,göndereceğim dosya makro içeren bir dosya olduğu için farklı algılayabilir ler etkinleştir dememek için .

etkinleştir demeden makro çaılştırılabilir mi ? yada taleplerim formulle yaplabilmesi mümkün müdür.?

diğer bir sıkıntım resim ekleme tuşuna atadığım makro sürekli sayfa 1 e ekleme yapabiliyor , tuşuna basılan sayfaya ekleme yada control a yöntemi ile kaç adet resim seçildi ise o kadar sayfa oluşturtulabilmesi mümkün müdür ?

diyeceksiniz ne den email de böyle bir imza yapmıyorsunuz ,kişiler form olunca dikkate aldığını tespit ettim ,isteninen verileri alamaz isem sürekli email atmak zorunda kalıyorum bende formu dönüştürmeye çalıştım konumun başarılı olacağını düşünüyorum fakat bazı nüanslar var yukarıdaki gibi yardımcı olabilir misiniz,teşekkürler.

örnek dosyam.

http://s3.dosya.tc/server11/r8rltn/YPARCA_TALEP_FORMU.rar.html

 

[Asri]

Sipariş formunuzu iki sayfa olarak word de hazırlayın. İlk sayfada form olsun ikinci sayfa boş olsun.

Birinci sayfaya not yazın: Örnek resimlerinin tamamını seçip kopyalayın ikinci sayfaya yapıştırın diye.

Bu şekilde makrosuz çözmüş olursunuz diye düşünüyorum.

 

[Asri]

Makrolu çözüm için,

Çoklu resim seçme yapılabilir. Tüm resim ile başlayan sayfaları siler,
Resim1.. Resim seçilen resim kadar sayfa oluşturur.
Resim boyutları için renkli bilgileri değiştirin.

Sub menu()
   Application.DisplayAlerts = False
   Call sayfalari_sil
   Call Coklu_Resim_Ekleme
   Application.DisplayAlerts = True
End Sub

Sub sayfalari_sil()
    For Each WSheet In Worksheets
        If Left(WSheet.Name, 5) = "Resim" Then
            WSheet.Delete  
        End If
    Next
End Sub

Sub Coklu_Resim_Ekleme()
  Dim PicList() As Variant
  Dim PicFormat As String
  Dim Rng As Range
  Dim sShape As Shape
  Dim cel As Range
  Dim selectedRange As Range
  
  Set selectedRange = Application.Selection
  On Error Resume Next
  PicList = Application.GetOpenFilename(PicFormat, MultiSelect:=True)
  If IsArray(PicList) Then
    For i = 1 To UBound(PicList)
      sayfaadi = "Resim" & i
      If WorksheetExists(sayfaadi) Then Sheets(sayfaadi).Delete
      Set newsh = Sheets.Add(After:=Sheets(Sheets.Count))
      newsh.Name = sayfaadi
      Sheets(sayfaadi).Select
      Set Rng = newsh.Cells(1, 1)
      Rng.Select
      Set sShape = ActiveSheet.Shapes.AddPicture(PicList(i), msoFalse, msoCTrue, Rng.Left, Rng.Top, [COLOR=Red]375, 260[/COLOR])
    Next
  End If
End Sub


Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error GoTo 0
End Function

 

[mustilem23]

üstad kusura bakma fuarday dım yeni geldim çok haklısınız ,makro ile olmaz bu iş bayim bile kuşkuyla baktı .
word dosyası + email eklemelerini yazdım kısmen işe yarıyor ,teşekkür ederim makro için .