Skip to main content

AccessTr.neT


vba save as dialog box

vba save as dialog box

Çözüldü #12
resim üzerine çift tıklayarak müşteri resmi yoksa;müşteri numarasıyla ,hangi formatta olursa olsun seçtiğiniz resmi daha önceden tanımladığınız klasöre bmp formatında kopyalıyor.eğer müşteri resmi varsa irfan view kullanarak resmi açıyor.
sn.Alpekinin paylaşmış olduğu Resim_Formatini_Degistir.rar kodlarını ihtiyacım olan şekilde değiştirerek programıma uyguladım sorunsuz çalışıyor.Kendisine teşekkür ederim.

Kodları aşağıda yazdım:
-------------------------------------
Option Compare Database
Option Explicit
Private Const Irfan1 As String = "C:\Program Files\IrfanView\i_view32.exe"
Dim ctlCurrentControl As Control, strControlName As String
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal _
dwAccess As Long, ByVal fInherit As Integer, ByVal hObject _
As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal _
hObject As Long) As Long
----------------------
-----------------------
Private Sub RESIM_DblClick(Cancel As Integer)
Dim ekocan As String
Dim altan As String
Dim bute As String
Dim r
altan = StrReverse(CurrentDb.Name)
bute = Trim(Mid(altan, 13))

Dim Temppic1 As String
Dim strFilter As String, strInputFileName As String, path1, fso, stAppName As String, newfilename1 As String
Temppic1 = StrReverse(bute) & "resim\1a.jpg"
If RESIM.Picture = StrReverse(bute) & "resim\ARKAPLAN\LOGOB.BMP" Then
r = MsgBox("Müşteri Resmi Kayıtlarımızda Bulunmamaktadır" & Chr(13) & "Eklemek İstermisiniz!", 32 + vbYesNo)
If r = vbYes Then
Set fso = CreateObject("WScript.Shell")
path1 = fso.SpecialFolders("MyDocuments")
strFilter = ahtAddFilterItem(strFilter, "Resim Dosyaları (*.*)", "*.JPG;*.GIF;*.BMP;*.PNG;*.TIF;*.RAW;*.ICO;*.PCX;*.PBM;*.DCM")
strInputFileName = ahtCommonFileOpenSave( _
InitialDir:=path1, Filter:=strFilter, OpenFile:=True, _
DialogTitle:=" Resim Seçiniz", _
Flags:=ahtOFN_HIDEREADONLY)
Me.OriginalPic1 = strInputFileName
FileCopy strInputFileName, Temppic1
Me.RESIM.Picture = Temppic1
Set fso = CreateObject("WScript.Shell")
path1 = fso.SpecialFolders("MyDocuments")
strFilter = ahtAddFilterItem(strFilter, "Image Files (*.*)", "*.*")
strInputFileName = protokol.Value & ".BMP"
stAppName = Irfan1 & " " & Temppic1
If Me.FileTypeCombo = "JPG" Then
If UCase(Right(strInputFileName, 4)) <> ".JPG" Then strInputFileName = strInputFileName & ".JPG"
stAppName = stAppName & " /jpgq=" & Me.Compression0 & " /convert=" & strInputFileName
Else
If UCase(Right(strInputFileName, 4)) <> UCase("." & Me.FileTypeCombo) Then strInputFileName = strInputFileName & "." & Me.FileTypeCombo
stAppName = stAppName & " /convert=" & strInputFileName
End If
LaunchApp32 (stAppName)
End If
Else

ekocan = "C:\Program Files\IrfanView\i_view32.exe " & StrReverse(bute) & "resim\" & Form_musteri.protokol.Value & ".BMP"
Call Shell(ekocan, 1)
Exit Sub
End If
End Sub
---------------------
Function LaunchApp32(MYAppname As String) As Integer

Const SYNCHRONIZE = 1048576
Const INFINITE = -1&
Dim ProcessID&
Dim ProcessHandle&
Dim Ret&

LaunchApp32 = -1
ProcessID = Shell(MYAppname, vbNormalFocus)
If ProcessID <> 0 Then
ProcessHandle = OpenProcess(SYNCHRONIZE, True, ProcessID&)
Ret = WaitForSingleObject(ProcessHandle, INFINITE)
Ret = CloseHandle(ProcessHandle)


Else
MsgBox "ERROR : Unable to start " & MYAppname
LaunchApp32 = 0
End If
End Function
-----------------
umarım ihtiyacı olan arkadaşların işine yarar
hepinize kolay gelsin arkadaşlar.
vetaltan 16-11-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da

Bu Konudaki Yorumlar
vba save as dialog box - Yazar: vetaltan - 18/08/2010, 01:46
Cvp: vba save as dialog box - Yazar: ozanakkaya - 18/08/2010, 03:57
Cvp: vba save as dialog box - Yazar: vetaltan - 18/08/2010, 15:34
Cvp: vba save as dialog box - Yazar: ozanakkaya - 18/08/2010, 16:29
Cvp: vba save as dialog box - Yazar: alpeki99 - 18/08/2010, 17:18
Cvp: vba save as dialog box - Yazar: alpeki99 - 19/08/2010, 21:55
Cvp: vba save as dialog box - Yazar: vetaltan - 20/08/2010, 16:35
Cvp: vba save as dialog box - Yazar: ozanakkaya - 20/08/2010, 16:37
Cvp: vba save as dialog box - Yazar: vetaltan - 20/08/2010, 19:07
Cvp: vba save as dialog box - Yazar: vetaltan - 31/08/2010, 00:14
Cvp: vba save as dialog box - Yazar: Subco - 31/08/2010, 08:12
Cvp: vba save as dialog box - Yazar: vetaltan - 01/09/2010, 00:43
Cvp: vba save as dialog box - Yazar: vetaltan - 01/09/2010, 00:50