Ændre størrelsen på JPG

ACDSEE kan klare det!

Hent her:

http://www.acdsystems.com/english/downloads/acdsee31.htm

\' to Do ..Place Two picture boxes in the form
\' name them as pct_src and pct_dest
\' Place a picture in the pct_src
\' Have Two Command Buttons
\' Name them as cmd_horiz and cmd_vert
\' cmd_horiz has the code to stretch the image in the X axis
\' cmd_vert has the code to stretch the image in the Y axis

Private Sub cmd_horiz_Click()
For i = 1 To pct_src.ScaleWidth
    pct_dest.PaintPicture pct_src.Picture, 0, 0, pct_dest.ScaleWidth, pct_dest.ScaleHeight, 0, 0, i, pct_src.ScaleHeight, vbSrcCopy
Next i
End Sub

Private Sub cmd_vert_Click()
For i = 1 To pct_src.ScaleHeight
    pct_dest.PaintPicture pct_src.Picture, 0, 0, pct_dest.ScaleWidth, pct_dest.ScaleHeight, 0, 0, pct_src.ScaleWidth, i, vbSrcCopy
Next i
End Sub

-strech må også kunne virke modsat

Du skal gå ind på et billede. Dobbeltklikke på det. Find så det bibliotek hvor du har dine billeder. Gå ind i menuen Plug-Ins -> HTML Album Generator, og vups så spørger den dig om kvalitet, størrelse o.s.v.

sorry. Så ikke det drejede sig om Programmering: Visual Basic

zycho>> se på spørgsmålet.... visual basic :)

Det går hurtig her...

Det er mange billeder der skal ændres på en gang.
Hvordan laver man et Loop der køre alle billederne igennem (åbner dem, retter dem og gemmer dem)?

Peter lang

Her er et \'lille\' script som gør det for dig. Det eneste du skal gøre er at kalde ReadImg med dit filnavn. Den er lavet i ASP men skulle være til at oversætte uden problemer.
Den er ikke testet.

Dim HW

Function AscAt(s, n)
      AscAt = Asc(Mid(s, n, 1))
End Function

Function HexAt(s, n)
      HexAt = Hex(AscAt(s, n))
End Function


Function isJPG(fichero)
      If inStr(uCase(fichero), \".JPG\") <> 0 Then
      isJPG = true
      Else
      isJPG = false
      End If
End Function


Function isPNG(fichero)
      If inStr(uCase(fichero), \".PNG\") <> 0 Then
      isPNG = true
      Else
      isPNG = false
      End If
End Function


Function isGIF(fichero)
      If inStr(uCase(fichero), \".GIF\") <> 0 Then
      isGIF = true
      Else
      isGIF = false
      End If
End Function


Function isBMP(fichero)
      If inStr(uCase(fichero), \".BMP\") <> 0 Then
      isBMP = true
      Else
      isBMP = false
      End If
End Function


Function isWMF(fichero)
      If inStr(uCase(fichero), \".WMF\") <> 0 Then
      isWMF = true
      Else
      isWMF = false
      End If
End Function


Function isWebImg(f)
      If isGIF(f) Or isJPG(f) Or isPNG(f) Or isBMP(f) Or isWMF(f) Then
      isWebImg = true
      Else
      isWebImg = true
      End If
End Function


Function ReadImg(fichero)
      If isGIF(fichero) Then
      ReadImg = ReadGIF(fichero)
      Else
      If isJPG(fichero) Then
      ReadImg = ReadJPG(fichero)
      Else
      If isPNG(fichero) Then
      ReadImg = ReadPNG(fichero)
      Else
      If isBMP(fichero) Then
      ReadImg = ReadPNG(fichero)
      Else
      If isWMF(fichero) Then
      ReadImg = ReadWMF(fichero)
      Else
      ReadImg = Array(0,0)
      End If
      End If
      End If
      End If
      End If
End Function


Function ReadJPG(fichero)
    Dim fso, ts, s, HW, nbytes
      HW = Array(\"\",\"\")
      Set fso = CreateObject(\"Scripting.FileSystemObject\")
      Set ts = fso.OpenTextFile(Server.MapPath(\"/\" & fichero), 1)
      s = Right(ts.Read(167), 4)
      HW(0) = HexToDec(HexAt(s,3) & HexAt(s,4))
      HW(1) = HexToDec(HexAt(s,1) & HexAt(s,2))
      ts.Close
    ReadJPG = HW
End Function


Function ReadPNG(fichero)
    Dim fso, ts, s, HW, nbytes
      HW = Array(\"\",\"\")
      Set fso = CreateObject(\"Scripting.FileSystemObject\")
      Set ts = fso.OpenTextFile(Server.MapPath(\"/\" & fichero), 1)
      s = Right(ts.Read(24), 8)
      HW(0) = HexToDec(HexAt(s,3) & HexAt(s,4))
      HW(1) = HexToDec(HexAt(s,7) & HexAt(s,8))
      ts.Close
    ReadPNG = HW
End Function


Function ReadGIF(fichero)
    Dim fso, ts, s, HW, nbytes
      HW = Array(\"\",\"\")
      Set fso = CreateObject(\"Scripting.FileSystemObject\")
      Set ts = fso.OpenTextFile(Server.MapPath(\"/\" & fichero), 1)
      s = Right(ts.Read(10), 4)
      HW(0) = HexToDec(HexAt(s,2) & HexAt(s,1))
      HW(1) = HexToDec(HexAt(s,4) & HexAt(s,3))
      ts.Close
    ReadGIF = HW
End Function


Function ReadWMF(fichero)
    Dim fso, ts, s, HW, nbytes
      HW = Array(\"\",\"\")
      Set fso = CreateObject(\"Scripting.FileSystemObject\")
      Set ts = fso.OpenTextFile(Server.MapPath(\"/\" & fichero), 1)
      s = Right(ts.Read(14), 4)
      HW(0) = HexToDec(HexAt(s,2) & HexAt(s,1))
      HW(1) = HexToDec(HexAt(s,4) & HexAt(s,3))
      ts.Close
    ReadWMF = HW
End Function


Function ReadBMP(fichero)
    Dim fso, ts, s, HW, nbytes
      HW = Array(\"\",\"\")
      Set fso = CreateObject(\"Scripting.FileSystemObject\")
      Set ts = fso.OpenTextFile(Server.MapPath(\"/\" & fichero), 1)
      s = Right(ts.Read(24), 8)
      HW(0) = HexToDec(HexAt(s,4) & HexAt(s,3))
      HW(1) = HexToDec(HexAt(s,8) & HexAt(s,7))
      ts.Close
    ReadBMP = HW
End Function


Function isDigit(c)
      If inStr(\"0123456789\", c) <> 0 Then
      isDigit = true
      Else
      isDigit = false
      End If
End Function


Function isHex(c)
      If inStr(\"0123456789ABCDEFabcdef\", c) <> 0 Then
      isHex = true
      Else
      ishex = false
      End If
End Function


Function HexToDec(cadhex)
      Dim n, i, ch, decimal
      decimal = 0
      n = Len(cadhex)
      For i=1 To n
      ch = Mid(cadhex, i, 1)
      If isHex(ch) Then
      decimal = decimal * 16
      If isDigit(c) Then
      decimal = decimal + ch
      Else
      decimal = decimal + Asc(uCase(ch)) - Asc(\"A\")
      End If
      Else
      HexToDec = -1
      End If
      Next
      HexToDec = decimal
End Function

Sorry. Misforstod spørgsmålet. Men det er nu et meget sødt script. :)